1889 lines
78 KiB
Java
1889 lines
78 KiB
Java
<?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="Database" 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 Compatible
|
|
Option ClassModule
|
|
|
|
Option Explicit
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- CLASS ROOT FIELDS ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
Private _Type As String ' Must be DATABASE
|
|
Private _This As Object ' Workaround for absence of This builtin function
|
|
Private _Parent As Object
|
|
Private _DbConnect As Integer ' DBCONNECTxxx constants
|
|
Private Title As String
|
|
Private Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj
|
|
Private Connection As Object ' com.sun.star.sdbc.drivers.OConnectionWrapper or com.sun.star.sdbc.XConnection
|
|
Private URL As String
|
|
Private Location As String ' Different from URL for registered databases
|
|
Private _ReadOnly As Boolean
|
|
Private MetaData As Object ' interface XDatabaseMetaData
|
|
Private _RDBMS As Integer ' DBMS constants
|
|
Private _ColumnTypes() As Variant ' Part of Metadata.GetTypeInfo()
|
|
Private _ColumnTypeNames() As Variant
|
|
Private _ColumnPrecisions() As Variant
|
|
Private _ColumnTypesReference() As Variant
|
|
Private _ColumnTypesAlias() As Variant ' To what should a field whose origin is another DBMS be converted ? See DataTypes By RDBMS.ods
|
|
Private _BinaryStream As Boolean ' False = binary fields must NOT be streamed f.i. via ReadAllBytes or WriteAllBytes
|
|
Private Form As Object ' com.sun.star.form.XForm
|
|
Private FormName As String
|
|
Private RecordsetMax As Long ' To make unique names in Collection below (See bug # 121342)
|
|
Private RecordsetsColl As Object ' Collection of active recordsets
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Sub Class_Initialize()
|
|
_Type = OBJDATABASE
|
|
Set _This = Nothing
|
|
Set _Parent = Nothing
|
|
_DbConnect = 0
|
|
Title = ""
|
|
Set Document = Nothing
|
|
Set Connection = Nothing
|
|
URL = ""
|
|
_ReadOnly = False
|
|
Set MetaData = Nothing
|
|
_RDBMS = DBMS_UNKNOWN
|
|
_ColumnTypes = Array()
|
|
_ColumnTypeNames = Array()
|
|
_ColumnPrecisions = Array()
|
|
_ColumnTypesReference = Array()
|
|
_ColumnTypesAlias() = Array()
|
|
_BinaryStream = False
|
|
Set Form = Nothing
|
|
FormName = ""
|
|
RecordsetMax = 0
|
|
Set RecordsetsColl = New Collection
|
|
End Sub ' Constructor
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Sub Class_Terminate()
|
|
On Local Error Resume Next
|
|
Call CloseAllRecordsets()
|
|
If _DbConnect <> DBCONNECTANY Then
|
|
If Not IsNull(Connection) Then
|
|
Connection.close()
|
|
Connection.dispose()
|
|
Set Connection = Nothing
|
|
End If
|
|
Else
|
|
mClose()
|
|
End If
|
|
Call Class_Initialize()
|
|
End Sub ' Destructor
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Sub Dispose()
|
|
Call Class_Terminate()
|
|
End Sub ' Explicit destructor
|
|
|
|
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- CLASS GET/LET/SET PROPERTIES ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
Property Get Connect() As String
|
|
Connect = _PropertyGet("Connect")
|
|
End Property ' Connect (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get Name() As String
|
|
Name = _PropertyGet("Name")
|
|
End Property ' Name (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get ObjectType() As String
|
|
ObjectType = _PropertyGet("ObjectType")
|
|
End Property ' ObjectType (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnCreate() As String
|
|
OnCreate = _PropertyGet("OnCreate")
|
|
End Property ' OnCreate (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnFocus() As String
|
|
OnFocus = _PropertyGet("OnFocus")
|
|
End Property ' OnFocus (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnLoad() As String
|
|
OnLoad = _PropertyGet("OnLoad")
|
|
End Property ' OnLoad (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnLoadFinished() As String
|
|
OnLoadFinished = _PropertyGet("OnLoadFinished")
|
|
End Property ' OnLoadFinished (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnModifyChanged() As String
|
|
OnModifyChanged = _PropertyGet("OnModifyChanged")
|
|
End Property ' OnModifyChanged (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnNew() As String
|
|
OnNew = _PropertyGet("OnNew")
|
|
End Property ' OnNew (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnPrepareUnload() As String
|
|
OnPrepareUnload = _PropertyGet("OnPrepareUnload")
|
|
End Property ' OnPrepareUnload (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnPrepareViewClosing() As String
|
|
OnPrepareViewClosing = _PropertyGet("OnPrepareViewClosing")
|
|
End Property ' OnPrepareViewClosing (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnSave() As String
|
|
OnSave = _PropertyGet("OnSave")
|
|
End Property ' OnSave (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnSaveAs() As String
|
|
OnSaveAs = _PropertyGet("OnSaveAs")
|
|
End Property ' OnSaveAs (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnSaveAsDone() As String
|
|
OnSaveAsDone = _PropertyGet("OnSaveAsDone")
|
|
End Property ' OnSaveAsDone (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnSaveAsFailed() As String
|
|
OnSaveAsFailed = _PropertyGet("OnSaveAsFailed")
|
|
End Property ' OnSaveAsFailed (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnSaveDone() As String
|
|
OnSaveDone = _PropertyGet("OnSaveDone")
|
|
End Property ' OnSaveDone (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnSaveFailed() As String
|
|
OnSaveFailed = _PropertyGet("OnSaveFailed")
|
|
End Property ' OnSaveFailed (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnSubComponentClosed() As String
|
|
OnSubComponentClosed = _PropertyGet("OnSubComponentClosed")
|
|
End Property ' OnSubComponentClosed (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnSubComponentOpened() As String
|
|
OnSubComponentOpened = _PropertyGet("OnSubComponentOpened")
|
|
End Property ' OnSubComponentOpened (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnTitleChanged() As String
|
|
OnTitleChanged = _PropertyGet("OnTitleChanged")
|
|
End Property ' OnTitleChanged (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnUnfocus() As String
|
|
OnUnfocus = _PropertyGet("OnUnfocus")
|
|
End Property ' OnUnfocus (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnUnload() As String
|
|
OnUnload = _PropertyGet("OnUnload")
|
|
End Property ' OnUnload (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnViewClosed() As String
|
|
OnViewClosed = _PropertyGet("OnViewClosed")
|
|
End Property ' OnViewClosed (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get OnViewCreated() As String
|
|
OnViewCreated = _PropertyGet("OnViewCreated")
|
|
End Property ' OnViewCreated (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Property Get Version() As String
|
|
Version = _PropertyGet("Version")
|
|
End Property ' Version (get)
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- CLASS METHODS ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function mClose() As Variant
|
|
' Close the database
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Const cstThisSub = "Database.Close"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
mClose = False
|
|
If _DbConnect <> DBCONNECTANY Then Goto Error_NotApplicable
|
|
|
|
With Connection
|
|
If Utils._hasUNOMethod(Connection, "flush") Then .flush
|
|
.close()
|
|
.dispose()
|
|
End With
|
|
Set Connection = Nothing
|
|
mClose = True
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_NotApplicable:
|
|
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
|
|
GoTo Exit_Function
|
|
End Function ' (m)Close
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Sub CloseAllRecordsets()
|
|
' Clean all recordsets for housekeeping
|
|
|
|
Dim sRecordsets() As String, i As Integer, oRecordset As Object
|
|
On Local Error Goto Exit_Sub
|
|
|
|
If IsNull(RecordsetsColl) Then Exit Sub
|
|
If RecordsetsColl.Count < 1 Then Exit Sub
|
|
For i = 1 To RecordsetsColl.Count
|
|
Set oRecordset = RecordsetsColl.Item(i)
|
|
oRecordset.mClose(False) ' Do not remove entry in collection
|
|
Next i
|
|
Set RecordsetsColl = New Collection
|
|
RecordsetMax = 0
|
|
|
|
Exit_Sub:
|
|
Exit Sub
|
|
End Sub ' CloseAllRecordsets V0.9.5
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function CreateQueryDef(ByVal Optional pvQueryName As Variant _
|
|
, ByVal Optional pvSql As Variant _
|
|
, ByVal Optional pvOption As Variant _
|
|
) As Object
|
|
'Return a (new) QueryDef object based on SQL statement
|
|
Const cstThisSub = "Database.CreateQueryDef"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
Const cstNull = -1
|
|
Dim oQuery As Object, oQueries As Object, i As Integer, sQueryName As String
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
|
|
Set CreateQueryDef = Nothing
|
|
If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
|
|
If IsMissing(pvQueryName) Then Call _TraceArguments()
|
|
If IsMissing(pvSql) Then Call _TraceArguments()
|
|
If IsMissing(pvOption) Then pvOption = cstNull
|
|
|
|
If Not Utils._CheckArgument(pvQueryName, 1, vbString) Then Goto Exit_Function
|
|
If pvQueryName = "" Then Call _TraceArguments()
|
|
If Not Utils._CheckArgument(pvSql, 2, vbString) Then Goto Exit_Function
|
|
If pvSql = "" Then Call _TraceArguments()
|
|
If Not Utils._CheckArgument(pvOption, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
|
|
|
|
If _ReadOnly Then Goto Error_NoUpdate
|
|
|
|
Set oQuery = CreateUnoService("com.sun.star.sdb.QueryDefinition")
|
|
oQuery.rename(pvQueryName)
|
|
oQuery.Command = _ReplaceSquareBrackets(pvSql)
|
|
oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
|
|
|
|
Set oQueries = Document.DataSource.getQueryDefinitions()
|
|
With oQueries
|
|
For i = 0 To .getCount() - 1
|
|
sQueryName = .getByIndex(i).Name
|
|
If UCase(sQueryName) = UCase(pvQueryName) Then
|
|
TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, sQueryName)
|
|
.removeByName(sQueryName)
|
|
Exit For
|
|
End If
|
|
Next i
|
|
.insertByName(pvQueryName, oQuery)
|
|
End With
|
|
Set CreateQueryDef = QueryDefs(pvQueryName)
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_NotApplicable:
|
|
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
|
Goto Exit_Function
|
|
Error_NoUpdate:
|
|
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
End Function ' CreateQueryDef V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function CreateTableDef(ByVal Optional pvTableName As Variant) As Object
|
|
'Return a (new/empty) TableDef object
|
|
Const cstThisSub = "Database.CreateTableDef"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
Dim oTable As Object, oTables As Object, sTables() As String
|
|
Dim i As Integer, sTableName As String, oNewTable As Object
|
|
Dim vNameComponents() As Variant, iNames As Integer
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
|
|
Set CreateTableDef = Nothing
|
|
If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
|
|
If IsMissing(pvTableName) Then Call _TraceArguments()
|
|
|
|
If Not Utils._CheckArgument(pvTableName, 1, vbString) Then Goto Exit_Function
|
|
If pvTableName = "" Then Call _TraceArguments()
|
|
|
|
If _ReadOnly Then Goto Error_NoUpdate
|
|
|
|
Set oTables = Connection.getTables
|
|
With oTables
|
|
sTables = .ElementNames()
|
|
' Check existence of object and find its exact (case-sensitive) name
|
|
For i = 0 To UBound(sTables)
|
|
If UCase(pvTableName) = UCase(sTables(i)) Then
|
|
sTableName = sTables(i)
|
|
TraceError(TRACEWARNING, ERRTABLEDEFDELETED, Utils._CalledSub(), 0, False, sTableName)
|
|
.dropByName(sTableName)
|
|
Exit For
|
|
End If
|
|
Next i
|
|
Set oNewTable = New DataDef
|
|
Set oNewTable._This = oNewTable
|
|
oNewTable._Type = OBJTABLEDEF
|
|
oNewTable._Name = pvTableName
|
|
vNameComponents = Split(pvTableName, ".")
|
|
iNames = UBound(vNameComponents)
|
|
If iNames >= 2 Then oNewtable.CatalogName = vNameComponents(iNames - 2) Else oNewTable.CatalogName = ""
|
|
If iNames >= 1 Then oNewtable.SchemaName = vNameComponents(iNames - 1) Else oNewTable.SchemaName = ""
|
|
oNewtable.TableName = vNameComponents(iNames)
|
|
Set oNewTable._ParentDatabase = _This
|
|
Set oNewTable.TableDescriptor = .createDataDescriptor()
|
|
oNewTable.TableDescriptor.CatalogName = oNewTable.CatalogName
|
|
oNewTable.TableDescriptor.SchemaName = oNewTable.SchemaName
|
|
oNewTable.TableDescriptor.Name = oNewTable.TableName
|
|
oNewTable.TableDescriptor.Type = "TABLE"
|
|
End With
|
|
|
|
Set CreateTabledef = oNewTable
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_NotApplicable:
|
|
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
|
Goto Exit_Function
|
|
Error_NoUpdate:
|
|
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
End Function ' CreateTableDef V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DAvg( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return average of scope
|
|
Const cstThisSub = "Database.DAvg"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DAvg = _DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DAvg
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DCount( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return # of occurrences of scope
|
|
Const cstThisSub = "Database.DCount"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DCount = _DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DCount
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DLookup( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
, ByVal Optional pvOrderClause As Variant _
|
|
) As Variant
|
|
|
|
' Return a value within a table
|
|
'Arguments: psExpr: an SQL expression
|
|
' psDomain: a table- or queryname
|
|
' pvCriteria: an optional WHERE clause
|
|
' pcOrderClause: an optional order clause incl. "DESC" if relevant
|
|
'Return: Value of the psExpr if found, else Null.
|
|
'Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html
|
|
'Examples:
|
|
' 1. To find the last value, include DESC in the OrderClause, e.g.:
|
|
' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
|
|
' 2. To find the lowest non-null value of a field, use the Criteria, e.g.:
|
|
' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")
|
|
|
|
Const cstThisSub = "Database.DLookup"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DLookup = _DFunction("", psExpr, psDomain _
|
|
, Iif(IsMissing(pvCriteria), "", pvCriteria) _
|
|
, Iif(IsMissing(pvOrderClause), "", pvOrderClause) _
|
|
)
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DLookup
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DMax( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return maximum of scope
|
|
Const cstThisSub = "Database.DMax"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DMax = _DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DMax
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DMin( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return minimum of scope
|
|
Const cstThisSub = "Database.DMin"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DMin = _DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DMin
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DStDev( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return standard deviation of scope
|
|
Const cstThisSub = "Database.DStDev"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DStDev = _DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DStDev
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DStDevP( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return standard deviation of scope
|
|
Const cstThisSub = "Database.DStDevP"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DStDevP = _DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DStDevP
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DSum( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return sum of scope
|
|
Const cstThisSub = "Database.DSum"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DSum = _DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DSum
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DVar( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return variance of scope
|
|
Const cstThisSub = "Database.DVar"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DVar = _DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DVar
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function DVarP( _
|
|
ByVal Optional psExpr As String _
|
|
, ByVal Optional psDomain As String _
|
|
, ByVal Optional pvCriteria As Variant _
|
|
) As Variant
|
|
' Return variance of scope
|
|
Const cstThisSub = "Database.DVarP"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
|
|
DVarP = _DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
End Function ' DVarP
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
|
' Return property value of psProperty property name
|
|
|
|
Utils._SetCalledSub("Database.getProperty")
|
|
If IsMissing(pvProperty) Then Call _TraceArguments()
|
|
getProperty = _PropertyGet(pvProperty)
|
|
Utils._ResetCalledSub("Database.getProperty")
|
|
|
|
End Function ' getProperty
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
|
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
|
|
|
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
|
Exit Function
|
|
|
|
End Function ' hasProperty
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function OpenRecordset(ByVal Optional pvSource As Variant _
|
|
, ByVal Optional pvType As Variant _
|
|
, ByVal Optional pvOptions As Variant _
|
|
, ByVal Optional pvLockEdit As Variant _
|
|
) As Object
|
|
'Return a Recordset object based on Source (= SQL, table or query name)
|
|
|
|
Const cstThisSub = "Database.OpenRecordset"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
Const cstNull = -1
|
|
|
|
Dim lCommandType As Long, sCommand As String, oObject As Object
|
|
Dim sSource As String, i As Integer, iCount As Integer
|
|
Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Object
|
|
Dim iType As Integer, iOptions As Integer, iLockEdit As Integer
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Set oObject = Nothing
|
|
If IsMissing(pvSource) Then Call _TraceArguments()
|
|
If pvSource = "" Then Call _TraceArguments()
|
|
If VarType(pvType) = vbError Then
|
|
iType = cstNull
|
|
ElseIf IsMissing(pvType) Then
|
|
iType = cstNull
|
|
Else
|
|
If Not Utils._CheckArgument(pvType, 2, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function
|
|
iType = pvType
|
|
End If
|
|
If VarType(pvOptions) = vbError Then
|
|
iOptions = cstNull
|
|
ElseIf IsMissing(pvOptions) Then
|
|
iOptions = cstNull
|
|
Else
|
|
If Not Utils._CheckArgument(pvOptions, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
|
|
iOptions = pvOptions
|
|
End If
|
|
If VarType(pvLockEdit) = vbError Then
|
|
iLockEdit = cstNull
|
|
ElseIf IsMissing(pvLockEdit) Then
|
|
iLockEdit = cstNull
|
|
Else
|
|
If Not Utils._CheckArgument(pvLockEdit, 4, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function
|
|
iLockEdit = pvLockEdit
|
|
End If
|
|
|
|
sSource = Split(UCase(Trim(pvSource)), " ")(0)
|
|
Select Case True
|
|
Case sSource = "SELECT"
|
|
lCommandType = com.sun.star.sdb.CommandType.COMMAND
|
|
sCommand = _ReplaceSquareBrackets(pvSource)
|
|
Case Else
|
|
sSource = UCase(Trim(pvSource))
|
|
REM Explore tables
|
|
Set oTables = Connection.getTables
|
|
sObjects = oTables.ElementNames()
|
|
bFound = False
|
|
For i = 0 To UBound(sObjects)
|
|
If sSource = UCase(sObjects(i)) Then
|
|
sCommand = sObjects(i)
|
|
bFound = True
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If bFound Then
|
|
lCommandType = com.sun.star.sdb.CommandType.TABLE
|
|
Else
|
|
REM Explore queries
|
|
Set oQueries = Connection.getQueries
|
|
sObjects = oQueries.ElementNames()
|
|
For i = 0 To UBound(sObjects)
|
|
If sSource = UCase(sObjects(i)) Then
|
|
sCommand = sObjects(i)
|
|
bFound = True
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If Not bFound Then Goto Trace_NotFound
|
|
lCommandType = com.sun.star.sdb.CommandType.QUERY
|
|
End If
|
|
End Select
|
|
|
|
Set oObject = New Recordset
|
|
With oObject
|
|
._CommandType = lCommandType
|
|
._Command = sCommand
|
|
._ParentName = Title
|
|
._ParentType = _Type
|
|
._ForwardOnly = ( iType = dbOpenForwardOnly )
|
|
._PassThrough = ( iOptions = dbSQLPassThrough )
|
|
._ReadOnly = ( (iLockEdit = dbReadOnly) Or _ReadOnly )
|
|
Set ._This = oObject
|
|
Set ._ParentDatabase = _This
|
|
Call ._Initialize()
|
|
RecordsetMax = RecordsetMax + 1
|
|
._Name = Format(RecordsetMax, "0000000")
|
|
RecordsetsColl.Add(oObject, UCase(._Name))
|
|
End With
|
|
|
|
If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty
|
|
|
|
Exit_Function:
|
|
Set OpenRecordset = oObject
|
|
Set oObject = Nothing
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
Trace_NotFound:
|
|
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE") & "/" & _GetLabel("QUERY"), pvSource))
|
|
Goto Exit_Function
|
|
End Function ' OpenRecordset V1.1.0
|
|
|
|
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
|
|
|
|
Const cstThisSub = "Database.OpenSQL"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
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(), Array(dbSQLPassThrough, cstNull)) Then Goto Exit_Function
|
|
End If
|
|
If _DbConnect <> DBCONNECTBASE And _DbConnect <> DBCONNECTFORM Then Goto Error_NotApplicable
|
|
|
|
Dim oURL As New com.sun.star.util.URL, oDispatch As Object
|
|
Dim vArgs(8) as New com.sun.star.beans.PropertyValue
|
|
|
|
oURL.Complete = ".component:DB/DataSourceBrowser"
|
|
oDispatch = StarDesktop.queryDispatch(oURL, "_Blank", 8)
|
|
|
|
vArgs(0).Name = "ActiveConnection" : vArgs(0).Value = Connection
|
|
vArgs(1).Name = "CommandType" : vArgs(1).Value = com.sun.star.sdb.CommandType.COMMAND
|
|
vArgs(2).Name = "Command" : vArgs(2).Value = _ReplaceSquareBrackets(pvSQL)
|
|
vArgs(3).Name = "ShowMenu" : vArgs(3).Value = True
|
|
vArgs(4).Name = "ShowTreeView" : vArgs(4).Value = False
|
|
vArgs(5).Name = "ShowTreeViewButton" : vArgs(5).Value = False
|
|
vArgs(6).Name = "Filter" : vArgs(6).Value = ""
|
|
vArgs(7).Name = "ApplyFilter" : vArgs(7).Value = False
|
|
vArgs(8).Name = "EscapeProcessing" : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough ))
|
|
|
|
oDispatch.dispatch(oURL, vArgs)
|
|
OpenSQL = True
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, "OpenSQL", Erl)
|
|
GoTo Exit_Function
|
|
SQL_Error:
|
|
TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
|
|
Goto Exit_Function
|
|
Error_NotApplicable:
|
|
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
|
Goto Exit_Function
|
|
End Function ' OpenSQL V1.1.0
|
|
|
|
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 _
|
|
, ByRef Optional pvHeaders As Variant _
|
|
, ByRef Optional pvData As Variant _
|
|
) As Boolean
|
|
'Supported: acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries
|
|
'pvHeaders and pvData (unpublished) when pvObjectType = acOutputArray
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Const cstThisSub = "Database.OutputTo"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
OutputTo = False
|
|
|
|
If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputArray)) Then Goto Exit_Function
|
|
If IsMissing(pvObjectName) Then Call _TraceArguments()
|
|
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(acFormatHTML), "HTML" _
|
|
, UCase(acFormatODS), "ODS" _
|
|
, UCase(acFormatXLS), "XLS" _
|
|
, UCase(acFormatXLSX), "XLSX" _
|
|
, UCase(acFormatTXT), "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 = acOutputArray Then
|
|
If IsMissing(pvHeaders) Or IsMissing(pvData) Then Call _TraceArguments()
|
|
pvOutputFormat = "HTML"
|
|
End If
|
|
|
|
Dim sOutputFile As String, oTable As Object
|
|
Dim sOutputFormat As String, iTemplate As Integer, iOutputFile As Integer, bOutput As Boolean, sSuffix As String
|
|
|
|
If pvObjectType = acOutputArray Then
|
|
Set oTable = Nothing
|
|
Else
|
|
'Find applicable table or query
|
|
If pvObjectType = acOutputTable Then Set oTable = TableDefs(pvObjectName, True) Else Set oTable = Querydefs(pvObjectName, True)
|
|
If IsNull(oTable) Then Goto Error_NotFound
|
|
End If
|
|
|
|
'Determine format and parameters
|
|
If pvOutputFormat = "" Then
|
|
sOutputFormat = _PromptFormat(Array("HTML", "ODS", "XLS", "XLSX", "TXT")) ' Prompt user for format
|
|
If sOutputFormat = "" Then Goto Exit_Function
|
|
Else
|
|
sOutputFormat = UCase(pvOutputFormat)
|
|
End If
|
|
|
|
'Determine output file
|
|
If pvOutputFile = "" Then ' Prompt file picker to user
|
|
Select Case sOutputFormat
|
|
Case UCase(acFormatHTML), "HTML" : sSuffix = "html"
|
|
Case UCase(acFormatODS), "ODS" : sSuffix = "ods"
|
|
Case UCase(acFormatXLS), "XLS" : sSuffix = "xls"
|
|
Case UCase(acFormatXLSX), "XLSX" : sSuffix = "xlsx"
|
|
Case UCase(acFormatTXT), "TXT", "CSV" : sSuffix = "txt"
|
|
End Select
|
|
sOutputFile = _PromptFilePicker(sSuffix)
|
|
If sOutputFile = "" Then Goto Exit_Function
|
|
Else
|
|
sOutputFile = pvOutputFile
|
|
End If
|
|
sOutputFile = ConvertToURL(sOutputFile)
|
|
|
|
'Create file
|
|
Select Case sOutputFormat
|
|
Case UCase(acFormatHTML), "HTML"
|
|
If pvObjectType = acOutputArray Then
|
|
bOutput = _OutputToHTML(Nothing, pvObjectName, sOutputFile, pvTemplateFile, pvHeaders, pvData)
|
|
Else
|
|
bOutput = _OutputToHTML(oTable, pvObjectName, sOutputFile, pvTemplateFile)
|
|
End If
|
|
Case UCase(acFormatODS), "ODS"
|
|
bOutput = _OutputToCalc(oTable, sOutputFile, acFormatODS)
|
|
Case UCase(acFormatXLS), "XLS"
|
|
bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLS)
|
|
Case UCase(acFormatXLS), "XLSX"
|
|
bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLSX)
|
|
Case UCase(acFormatTXT), "TXT", "CSV"
|
|
bOutput = _OutputToCalc(oTable, sOutputFile, acFormatTXT, pvEncoding)
|
|
End Select
|
|
|
|
'Launch application, if requested
|
|
If bOutput Then
|
|
If pvAutoStart Then Call _ShellExecute(sOutputFile)
|
|
Else
|
|
GoTo Error_File
|
|
End If
|
|
|
|
OutputTo = True
|
|
|
|
Exit_Function:
|
|
If Not IsNull(oTable) Then
|
|
oTable.Dispose()
|
|
Set oTable = Nothing
|
|
End If
|
|
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
|
|
Error_File:
|
|
TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile)
|
|
GoTo Exit_Function
|
|
End Function ' OutputTo V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
|
' Return
|
|
' a Collection object if pvIndex absent
|
|
' a Property object otherwise
|
|
|
|
Utils._SetCalledSub("Database.Properties")
|
|
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
|
vPropertiesList = _PropertiesList()
|
|
sObject = Utils._PCase(_Type)
|
|
If IsMissing(pvIndex) Then
|
|
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
|
Else
|
|
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
|
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
|
End If
|
|
Set vProperty._ParentDatabase = _This
|
|
|
|
Exit_Function:
|
|
Set Properties = vProperty
|
|
Utils._ResetCalledSub("Database.Properties")
|
|
Exit Function
|
|
End Function ' Properties
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function QueryDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
|
|
' Collect all Queries in the database
|
|
' pbCheck unpublished
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Utils._SetCalledSub("Database.QueryDefs")
|
|
If IsMissing(pbCheck) Then pbCheck = False
|
|
|
|
Dim sObjects() As String, sObjectName As String, oObject As Object
|
|
Dim i As Integer, bFound As Boolean, oQueries As Object
|
|
Set oObject = Nothing
|
|
If Not IsMissing(pvIndex) Then
|
|
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
End If
|
|
|
|
Set oQueries = Connection.getQueries
|
|
sObjects = oQueries.ElementNames()
|
|
Select Case True
|
|
Case IsMissing(pvIndex)
|
|
Set oObject = New Collect
|
|
Set oObject._This = oObject
|
|
oObject._CollType = COLLQUERYDEFS
|
|
Set oObject._Parent = _This
|
|
oObject._Count = UBound(sObjects) + 1
|
|
Goto Exit_Function
|
|
Case VarType(pvIndex) = vbString
|
|
bFound = False
|
|
' Check existence of object and find its exact (case-sensitive) name
|
|
For i = 0 To UBound(sObjects)
|
|
If UCase(pvIndex) = UCase(sObjects(i)) Then
|
|
sObjectName = sObjects(i)
|
|
bFound = True
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If Not bFound Then Goto Trace_NotFound
|
|
Case Else ' pvIndex is numeric
|
|
If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
|
|
sObjectName = sObjects(pvIndex)
|
|
End Select
|
|
|
|
Set oObject = New DataDef
|
|
Set oObject._This = oObject
|
|
oObject._Type = OBJQUERYDEF
|
|
oObject._Name = sObjectName
|
|
Set oObject._ParentDatabase = _This
|
|
oObject._readOnly = _ReadOnly
|
|
Set oObject.Query = oQueries.getByName(sObjectName)
|
|
|
|
Exit_Function:
|
|
Set QueryDefs = oObject
|
|
Set oObject = Nothing
|
|
Utils._ResetCalledSub("Database.QueryDefs")
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, "Database.QueryDefs", Erl)
|
|
GoTo Exit_Function
|
|
Trace_NotFound:
|
|
If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("QUERY"), pvIndex))
|
|
Goto Exit_Function
|
|
Trace_IndexError:
|
|
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
|
|
Goto Exit_Function
|
|
End Function ' QueryDefs V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function Recordsets(ByVal Optional pvIndex As Variant) As Object
|
|
' Collect all active recordsets
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Utils._SetCalledSub("Database.Recordsets")
|
|
|
|
Set Recordsets = Nothing
|
|
If Not IsMissing(pvIndex) Then
|
|
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
End If
|
|
|
|
Dim sObjects() As String, sObjectName As String, oObject As Object
|
|
Dim i As Integer, bFound As Boolean, oTables As Object
|
|
|
|
Select Case True
|
|
Case IsMissing(pvIndex)
|
|
Set oObject = New Collect
|
|
Set oObject._This = oObject
|
|
oObject._CollType = COLLRECORDSETS
|
|
Set oObject._Parent = _This
|
|
oObject._Count = RecordsetsColl.Count
|
|
Case VarType(pvIndex) = vbString
|
|
bFound = _hasRecordset(pvIndex)
|
|
If Not bFound Then Goto Trace_NotFound
|
|
Set oObject = RecordsetsColl.Item(pvIndex)
|
|
Case Else ' pvIndex is numeric
|
|
If pvIndex < 0 Or pvIndex >= RecordsetsColl.Count Then Goto Trace_IndexError
|
|
Set oObject = RecordsetsColl.Item(pvIndex + 1) ' Collection members are numERRSQLSTATEMENTbered 1 ... Count
|
|
End Select
|
|
|
|
Exit_Function:
|
|
Set Recordsets = oObject
|
|
Set oObject = Nothing
|
|
Utils._ResetCalledSub("Database.Recordsets")
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, "Database.Recordsets", Erl)
|
|
GoTo Exit_Function
|
|
Trace_NotFound:
|
|
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("RECORDSET"), pvIndex))
|
|
Goto Exit_Function
|
|
Trace_IndexError:
|
|
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
|
|
Goto Exit_Function
|
|
End Function ' Recordsets V0.9.5
|
|
|
|
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
|
|
|
|
Const cstThisSub = "Database.RunSQL"
|
|
Utils._SetCalledSub(cstThisSub)
|
|
|
|
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
|
|
|
|
Dim oStatement As Object, vResult As Variant
|
|
Set oStatement = Connection.createStatement()
|
|
oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
|
|
On Local Error Goto SQL_Error
|
|
vResult = oStatement.execute(_ReplaceSquareBrackets(pvSQL))
|
|
On Local Error Goto Error_Function
|
|
RunSQL = True
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
SQL_Error:
|
|
TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
|
|
Goto Exit_Function
|
|
End Function ' RunSQL V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function TableDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
|
|
' Collect all tables in the database
|
|
' pbCheck unpublished
|
|
|
|
Const cstThisSub = "Database.TableDefs"
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Utils._SetCalledSub(cstThisSub)
|
|
If IsMissing(pbCheck) Then pbCheck = False
|
|
|
|
Dim sObjects() As String, sObjectName As String, oObject As Object
|
|
Dim i As Integer, bFound As Boolean, oTables As Object
|
|
Set oObject = Nothing
|
|
If Not IsMissing(pvIndex) Then
|
|
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
|
End If
|
|
|
|
Set oTables = Connection.getTables
|
|
sObjects = oTables.ElementNames()
|
|
Select Case True
|
|
Case IsMissing(pvIndex)
|
|
Set oObject = New Collect
|
|
Set oObject._This = oObject
|
|
oObject._CollType = COLLTABLEDEFS
|
|
Set oObject._Parent = _This
|
|
oObject._Count = UBound(sObjects) + 1
|
|
Goto Exit_Function
|
|
Case VarType(pvIndex) = vbString
|
|
bFound = False
|
|
' Check existence of object and find its exact (case-sensitive) name
|
|
For i = 0 To UBound(sObjects)
|
|
If UCase(pvIndex) = UCase(sObjects(i)) Then
|
|
sObjectName = sObjects(i)
|
|
bFound = True
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If Not bFound Then Goto Trace_NotFound
|
|
Case Else ' pvIndex is numeric
|
|
If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
|
|
sObjectName = sObjects(pvIndex)
|
|
End Select
|
|
|
|
Set oObject = New DataDef
|
|
With oObject
|
|
._This = oObject
|
|
._Type = OBJTABLEDEF
|
|
._Name = sObjectName
|
|
Set ._ParentDatabase = _This
|
|
._ReadOnly = _ReadOnly
|
|
Set .Table = oTables.getByName(sObjectName)
|
|
.CatalogName = .Table.CatalogName
|
|
.SchemaName = .Table.SchemaName
|
|
.TableName = .Table.Name
|
|
End With
|
|
|
|
Exit_Function:
|
|
Set TableDefs = oObject
|
|
Set oObject = Nothing
|
|
Utils._ResetCalledSub(cstThisSub)
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
|
GoTo Exit_Function
|
|
Trace_NotFound:
|
|
If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE"), pvIndex))
|
|
Goto Exit_Function
|
|
Trace_IndexError:
|
|
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
|
|
Goto Exit_Function
|
|
End Function ' TableDefs V1.1.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
REM --- PRIVATE FUNCTIONS ---
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _DFunction(ByVal psFunction As String _
|
|
, ByVal psExpr As String _
|
|
, ByVal psDomain As String _
|
|
, ByVal pvCriteria As Variant _
|
|
, ByVal Optional pvOrderClause As Variant _
|
|
) As Variant
|
|
'Arguments: psFunction an optional aggregate function
|
|
' psExpr: an SQL expression [might contain an aggregate function]
|
|
' psDomain: a table- or queryname
|
|
' pvCriteria: an optional WHERE clause
|
|
' pcOrderClause: an optional order clause incl. "DESC" if relevant
|
|
|
|
If _ErrorHandler() Then On Local Error GoTo Error_Function
|
|
|
|
Dim oResult As Object 'To retrieve the value to find.
|
|
Dim vResult As Variant 'Return value for function.
|
|
Dim sSql As String 'SQL statement.
|
|
Dim oStatement As Object 'For CreateStatement method
|
|
Dim sExpr As String 'For inclusion of aggregate function
|
|
Dim sTempField As String 'Random temporary field in SQL expression
|
|
|
|
Dim sTarget as String, sWhere As String, sOrderBy As String, sLimit As String
|
|
Dim sProductName As String
|
|
|
|
vResult = Null
|
|
|
|
Randomize 2^14-1
|
|
sTempField = "[TEMP" & Right("00000" & Int(100000 * Rnd), 5) & "]"
|
|
If pvCriteria <> "" Then sWhere = " WHERE " & pvCriteria Else sWhere = ""
|
|
If pvOrderClause <> "" Then sOrderBy = " ORDER BY " & pvOrderClause Else sOrderBy = ""
|
|
sLimit = ""
|
|
|
|
sProductName = UCase(MetaData.getDatabaseProductName())
|
|
|
|
Select Case sProductName
|
|
Case "MYSQL", "SQLITE"
|
|
If psFunction = "" Then
|
|
sTarget = psExpr
|
|
sLimit = " LIMIT 1"
|
|
Else
|
|
sTarget = UCase(psFunction) & "(" & psExpr & ")"
|
|
End If
|
|
sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy & sLimit
|
|
Case "FIREBIRD (ENGINE12)"
|
|
If psFunction = "" Then sTarget = "FIRST 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")"
|
|
sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy
|
|
Case Else ' Standard syntax - Includes HSQLDB
|
|
If psFunction = "" Then sTarget = "TOP 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")"
|
|
sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy
|
|
End Select
|
|
|
|
'Lookup the value.
|
|
Set oStatement = Connection.createStatement()
|
|
With oStatement
|
|
.ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY
|
|
.ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
|
|
.EscapeProcessing = False
|
|
sSql = _ReplaceSquareBrackets(sSql) 'Substitute [] by quote string
|
|
Set oResult = .executeQuery(sSql)
|
|
If Not IsNull(oResult) And Not IsEmpty(oResult) Then
|
|
If Not oResult.next() Then Goto Exit_Function
|
|
vResult = Utils._getResultSetColumnValue(oResult, 1, True) ' Force return of binary field
|
|
End If
|
|
End With
|
|
|
|
Exit_Function:
|
|
'Assign the returned value.
|
|
_DFunction = vResult
|
|
Set oResult = Nothing
|
|
Set oStatement = Nothing
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEFATAL, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
|
|
Goto Exit_Function
|
|
End Function ' DFunction V1.5.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _FilterOptionsDefault(ByVal plEncoding As Long) As String
|
|
' Return the default FilterOptions string for table/query export to csv
|
|
|
|
Dim sFieldSeparator as string
|
|
Const cstComma = ","
|
|
Const cstTextDelimitor = """"
|
|
|
|
If _DecimalPoint() = "," Then sFieldSeparator = ";" Else sFieldSeparator = cstComma
|
|
_FilteroptionsDefault = Trim(Str(Asc(sFieldSeparator))) _
|
|
& cstComma & Trim(Str(Asc(cstTextDelimitor))) _
|
|
& cstComma & Trim(Str(plEncoding)) _
|
|
& cstComma & "1"
|
|
|
|
End Function ' _FilterOptionsDefault V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _hasRecordset(ByVal psName As String) As Boolean
|
|
' Return True if psName if in the collection of Recordsets
|
|
|
|
Dim oRecordset As Object
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Set oRecordset = RecordsetsColl.Item(psName)
|
|
_hasRecordset = True
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Error_Function: ' Item by key aborted
|
|
_hasRecordset = False
|
|
GoTo Exit_Function
|
|
End Function ' _hasRecordset V0.9.5
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Sub _LoadMetadata()
|
|
' Load essentially getTypeInfo() results from Metadata
|
|
|
|
Dim sProduct As String
|
|
Dim iInfo As Integer, oTypeInfo As Object, sName As String, lType As Integer
|
|
|
|
Const cstMaxInfo = 40
|
|
ReDim _ColumnTypes(0 To cstMaxInfo)
|
|
ReDim _ColumnTypeNames(0 To cstMaxInfo)
|
|
ReDim _ColumnPrecisions(0 To cstMaxInfo)
|
|
Const cstHSQLDB1 = "HSQL Database Engine 1."
|
|
Const cstHSQLDB2 = "HSQL Database Engine 2."
|
|
Const cstFirebird = "sdbc:embedded:firebird"
|
|
Const cstMSAccess2003 = "MS Jet 0"
|
|
Const cstMSAccess2007 = "MS Jet 04."
|
|
Const cstMYSQL = "MySQL"
|
|
Const cstPOSTGRES = "PostgreSQL"
|
|
Const cstSQLITE = "SQLite"
|
|
|
|
With com.sun.star.sdbc.DataType
|
|
_ColumnTypesReference = Array( _
|
|
.ARRAY _
|
|
, .BIGINT _
|
|
, .BINARY _
|
|
, .BIT _
|
|
, .BLOB _
|
|
, .BOOLEAN _
|
|
, .CHAR _
|
|
, .CLOB _
|
|
, .DATE _
|
|
, .DECIMAL _
|
|
, .DISTINCT _
|
|
, .DOUBLE _
|
|
, .FLOAT _
|
|
, .INTEGER _
|
|
, .LONGVARBINARY _
|
|
, .LONGVARCHAR _
|
|
, .NUMERIC _
|
|
, .OBJECT _
|
|
, .OTHER _
|
|
, .REAL _
|
|
, .REF _
|
|
, .SMALLINT _
|
|
, .SQLNULL _
|
|
, .STRUCT _
|
|
, .TIME _
|
|
, .TIMESTAMP _
|
|
, .TINYINT _
|
|
, .VARBINARY _
|
|
, .VARCHAR _
|
|
)
|
|
End With
|
|
|
|
With Metadata
|
|
sProduct = .getDatabaseProductName() & " " & .getDatabaseProductVersion
|
|
Select Case True
|
|
Case Len(sProduct) > Len(cstHSQLDB1) And Left(sProduct, Len(cstHSQLDB1)) = cstHSQLDB1
|
|
_RDBMS = DBMS_HSQLDB1
|
|
_ColumnTypesAlias = Array(0, -5, -2, 16, -4, 16, 1, -1, 91, 3, 0, 8, 6, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, 12)
|
|
_BinaryStream = True
|
|
Case Len(sProduct) > Len(cstHSQLDB2) And Left(sProduct, Len(cstHSQLDB2)) = cstHSQLDB2
|
|
_RDBMS = DBMS_HSQLDB2
|
|
_ColumnTypesAlias = Array(0, -5, -3, -7, 2004, 16, 1, 2005, 91, 3, 0, 8, 8, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -3, 12)
|
|
_BinaryStream = True
|
|
Case .URL = cstFirebird ' Only embedded 3.0
|
|
_RDBMS = DBMS_FIREBIRD
|
|
_ColumnTypesAlias = Array(0, -5, -2, 16, 2004, 16, 1, 2005, 91, 3, 0, 8, 6, 4, -4, 2005, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, 4, 2004, 12)
|
|
_BinaryStream = True
|
|
Case Len(sProduct) > Len(cstMSAccess2007) And Left(sProduct, Len(cstMSAccess2007)) = cstMSAccess2007
|
|
_RDBMS = DBMS_MSACCESS2007
|
|
_ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12)
|
|
_BinaryStream = True
|
|
Case Len(sProduct) > Len(cstMSAccess2003) And Left(sProduct, Len(cstMSAccess2003)) = cstMSAccess2003
|
|
_RDBMS = DBMS_MSACCESS2003
|
|
_ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12)
|
|
_BinaryStream = True
|
|
Case Len(sProduct) > Len(cstMYSQL) And Left(sProduct, Len(cstMYSQL)) = cstMYSQL
|
|
_RDBMS = DBMS_MYSQL
|
|
_ColumnTypesAlias = Array(0, -5, -2, -7, -4, -7, 1, -1, 91, 3, 0, 8, 8, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, -1)
|
|
_BinaryStream = False
|
|
Case Len(sProduct) > Len(cstPOSTGRES) And Left(sProduct, Len(cstPOSTGRES)) = cstPOSTGRES
|
|
_RDBMS = DBMS_POSTGRES
|
|
_ColumnTypesAlias = Array(0, -5, -3, 16, -3, 16, 1, 12, 91, 8, 0, 8, 8, 4, -3, 12, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, 4, -3, 12)
|
|
_BinaryStream = True
|
|
Case Len(sProduct) > Len(cstSQLITE) And Left(sProduct, Len(cstSQLITE)) = cstSQLITE
|
|
_RDBMS = DBMS_SQLITE
|
|
_ColumnTypesAlias = Array(0, -5, -4, -7, -4, -7, 1, -1, 91, 8, 0, 8, 6, 4, -4, -1, 8, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -4, 12)
|
|
_BinaryStream = True
|
|
Case Else
|
|
_RDBMS = DBMS_UNKNOWN
|
|
_BinaryStream = True
|
|
End Select
|
|
|
|
iInfo = -1
|
|
Set oTypeInfo = MetaData.getTypeInfo()
|
|
With oTypeInfo
|
|
.next()
|
|
Do While Not .isAfterLast() And iInfo < cstMaxInfo
|
|
sName = .getString(1)
|
|
lType = .getLong(2)
|
|
If _RDBMS = DBMS_POSTGRES And (Left(sName, 1) <> "_" Or lType <> -1) Then ' Skip
|
|
Else
|
|
iInfo = iInfo + 1
|
|
_ColumnTypeNames(iInfo) = sName
|
|
_ColumnTypes(iInfo) = lType
|
|
_ColumnPrecisions(iInfo) = CLng(.getLong(3))
|
|
End If
|
|
.next()
|
|
Loop
|
|
End With
|
|
ReDim Preserve _ColumnTypes(0 To iInfo)
|
|
ReDim Preserve _ColumnTypeNames(0 To iInfo)
|
|
ReDim Preserve _ColumnPrecisions(0 To iInfo)
|
|
End With
|
|
|
|
End Sub ' _LoadMetadata V1.6.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _OutputBinaryToHTML() As String
|
|
' Converts Binary value to HTML compatible string
|
|
|
|
_OutputBinaryToHTML = "&nbsp;"
|
|
|
|
End Function ' _OutputBinaryToHTML V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _OutputBooleanToHTML(ByVal pbBool As Boolean) As String
|
|
' Converts input boolean value to HTML compatible string
|
|
|
|
_OutputBooleanToHTML = Iif(pbBool, "&#x2714;", "&#x2716;") ' ✔ and ✖
|
|
|
|
End Function ' _OutputBooleanToHTML V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _OutputClassToHTML(ByVal pvArray As variant) As String
|
|
' Formats classes attribute of <tr> and <td> tags
|
|
|
|
If Not IsArray(pvArray) Then
|
|
_OutputClassToHTML = ""
|
|
ElseIf UBound(pvArray) < LBound(pvArray) Then
|
|
_OutputClassToHTML = ""
|
|
Else
|
|
_OutputClassToHTML = " class=""" & Join(pvArray, " ") & """"
|
|
End If
|
|
|
|
End Function ' _OutputClassToHTML V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _OutputDataToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal piFile As Integer _
|
|
, ByRef Optional pvHeaders As Variant _
|
|
, ByRef Optional pvData As Variant _
|
|
) As Boolean
|
|
' Write html tags around data found in pvTable
|
|
' Exit when error without execution stop (to avoid file remaining open ...)
|
|
|
|
Dim oTableRS As Object, vData() As Variant, i As Integer, j As Integer
|
|
Dim vFieldsBin() As Variant, iDataType As Integer, iNumRows As Integer, iNumFields As Integer, vDataCell As Variant
|
|
Dim bDataArray As Boolean, sHeader As String
|
|
Dim vTrClass() As Variant, vTdClass As Variant, iCountRows As Integer, iLastRow As Integer
|
|
Const cstMaxRows = 200
|
|
On Local Error GoTo Error_Function
|
|
|
|
bDataArray = IsNull(pvTable)
|
|
Print #piFile, " <table class=""dbdatatable"">"
|
|
Print #piFile, " <caption>" & pvName & "</caption>"
|
|
|
|
vFieldsBin() = Array()
|
|
If bDataArray Then
|
|
Set oTableRS = Nothing
|
|
iNumFields = UBound(pvHeaders) + 1
|
|
ReDim vFieldsBin(0 To iNumFields - 1)
|
|
For i = 0 To iNumFields - 1
|
|
vFieldsBin(i) = False
|
|
Next i
|
|
Else
|
|
Set oTableRS = pvTable.OpenRecordset( , , dbReadOnly)
|
|
iNumFields = oTableRS.Fields.Count
|
|
ReDim vFieldsBin(0 To iNumFields - 1)
|
|
With com.sun.star.sdbc.DataType
|
|
For i = 0 To iNumFields - 1
|
|
iDataType = oTableRS.Fields(i).DataType
|
|
vFieldsBin(i) = Utils._IsBinaryType(iDataType)
|
|
Next i
|
|
End With
|
|
End If
|
|
|
|
With oTableRS
|
|
Print #piFile, " <thead>"
|
|
Print #piFile, " <tr>"
|
|
For i = 0 To iNumFields - 1
|
|
If bDataArray Then sHeader = pvHeaders(i) Else sHeader = .Fields(i)._Name
|
|
Print #piFile, " <th scope=""col"">" & sHeader & "</th>"
|
|
Next i
|
|
Print #piFile, " </tr>"
|
|
Print #piFile, " </thead>"
|
|
Print #piFile, " <tfoot>"
|
|
Print #piFile, " </tfoot>"
|
|
|
|
Print #piFile, " <tbody>"
|
|
If bDataArray Then
|
|
iLastRow = UBound(pvData, 2) + 1
|
|
Else
|
|
.MoveLast
|
|
iLastRow = .RecordCount
|
|
.MoveFirst
|
|
End If
|
|
iCountRows = 0
|
|
Do While iCountRows < iLastRow
|
|
If bDataArray Then
|
|
iNumRows = iLastRow
|
|
Else
|
|
vData() = .GetRows(cstMaxRows)
|
|
iNumRows = UBound(vData, 2) + 1
|
|
End If
|
|
For j = 0 To iNumRows - 1
|
|
iCountRows = iCountRows + 1
|
|
vTrClass() = Array()
|
|
If iCountRows = 1 Then vTrClass() = _AddArray(vTrClass, "firstrow")
|
|
If iCountRows = iLastRow Then vTrClass() = _AddArray(vTrClass, "lastrow")
|
|
If (iCountRows Mod 2) = 0 Then vTrClass() = _AddArray(vTrClass, "even") Else vTrClass() = _AddArray(vTrClass, "odd")
|
|
Print #piFile, " <tr" & _OutputClassToHTML(vTrClass) & ">"
|
|
For i = 0 To iNumFields - 1
|
|
vTdClass() = Array()
|
|
If i = 0 Then vTdClass() = _AddArray(vTdClass, "firstcol")
|
|
If i = iNumFields - 1 Then vTdClass() = _AddArray(vTdClass, "lastcol")
|
|
If Not vFieldsBin(i) Then
|
|
If bDataArray Then vDataCell = pvData(i, j) Else vDataCell = vData(i, j)
|
|
If vDataCell Is Nothing Then vDataCell = Null ' Necessary because Null object has not a VarType = vbNull
|
|
If VarType(vDataCell) = vbString Then ' Null string gives IsDate = True !
|
|
If Len(vDataCell) > 0 And IsDate(vDataCell) Then vDataCell = CDate(vDataCell)
|
|
End If
|
|
Select Case VarType(vDataCell)
|
|
Case vbEmpty, vbNull
|
|
vTdClass() = _AddArray(vTdClass, "null")
|
|
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNullToHTML() & "</td>"
|
|
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal, vbUShort, vbULong, vbBigInt
|
|
vTdClass() = _AddArray(vTdClass, "numeric")
|
|
If vDataCell < 0 Then vTdClass() = _AddArray(vTdClass, "negative")
|
|
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNumberToHTML(vDataCell) & "</td>"
|
|
Case vbBoolean
|
|
vTdClass() = _AddArray(vTdClass, "bool")
|
|
If vDataCell = False Then vTdClass() = _AddArray(vTdClass, "false")
|
|
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBooleanToHTML(vDataCell) & "</td>"
|
|
Case vbDate
|
|
vTdClass() = _AddArray(vTdClass, "date")
|
|
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputDateToHTML(vDataCell) & "</td>"
|
|
Case vbString
|
|
vTdClass() = _AddArray(vTdClass, "char")
|
|
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputStringToHTML(vDataCell) & "</td>"
|
|
Case Else
|
|
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _CStr(vDataCell) & "</td>"
|
|
End Select
|
|
Else ' Binary fields
|
|
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBinaryToHTML() & "</td>"
|
|
End If
|
|
Next i
|
|
Print #piFile, " </tr>"
|
|
Next j
|
|
Loop
|
|
|
|
If Not bDataArray Then .mClose()
|
|
End With
|
|
Set oTableRS = Nothing
|
|
|
|
Print #piFile, " </tbody>"
|
|
Print #piFile, " </table>"
|
|
_OutputDataToHTML = True
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEWARNING, Err, "_OutputDataToHTML", Erl)
|
|
_OutputDataToHTML = False
|
|
Resume Exit_Function
|
|
End Function ' _OutputDataToHTML V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _OutputDateToHTML(ByVal psDate As Date) As String
|
|
' Converts input date to HTML compatible string
|
|
|
|
_OutputDateToHTML = Format(psDate) ' With regional settings - Ignores time if = to 0
|
|
|
|
End Function ' _OutputDateToHTML V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _OutputNullToHTML() As String
|
|
' Converts Null value to HTML compatible string
|
|
|
|
_OutputNullToHTML = "&nbsp;"
|
|
|
|
End Function ' _OutputNullToHTML V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _OutputNumberToHTML(ByVal pvNumber As Variant, ByVal Optional piPrecision As Integer) As String
|
|
' Converts input number to HTML compatible string
|
|
|
|
Dim vNumber As Variant
|
|
If IsMissing(piPrecision) Then piPrecision = -1
|
|
If pvNumber = Int(pvNumber) Then
|
|
vNumber = Int(pvNumber)
|
|
Else
|
|
If piPrecision >= 0 Then vNumber = (Int(pvNumber * 10 ^ piPrecision + 0.5)) / 10 ^ piPrecision Else vNumber = pvNumber
|
|
End If
|
|
_OutputNumberToHTML = Format(vNumber)
|
|
|
|
End Function ' _OutputNumberToHTML V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _OutputStringToHTML(ByVal psString As String) As String
|
|
' Converts input string to HTML compatible string
|
|
' - UTF-8 encoding
|
|
' - recognition of next patterns
|
|
' - &quot; - &amp; - &apos; - &lt; - &gt;
|
|
' - <pre>
|
|
' - <a href="...
|
|
' - <br>
|
|
' - <img src="...
|
|
' - <b>, <u>, <i>
|
|
|
|
Dim vPatterns As Variant
|
|
Dim lCurrentChar as Long, lPattern As Long, lNextPattern As Long, sPattern As String
|
|
Dim sOutput As String, sChar As String
|
|
Dim sUrl As String, lNextQuote As Long, lUrl As Long, bQuote As Boolean, bTagEnd As Boolean
|
|
Dim i As Integer, l As Long
|
|
|
|
vPatterns = Array( _
|
|
"&quot;", "&amp;", "&apos;", "&lt;", "&gt;", "&nbsp;" _
|
|
, "<pre>", "</pre>", "<br>" _
|
|
, "<a href=""", "<a id=""", "</a>", "<img src=""" _
|
|
, "<span class=""", "</span>" _
|
|
, "<b>", "</b>", "<u>", "</u>", "<i>", "</i>" _
|
|
)
|
|
|
|
lCurrentChar = 1
|
|
sOutput = ""
|
|
|
|
Do While lCurrentChar <= Len(psString)
|
|
' Where is next closest pattern ?
|
|
lPattern = Len(psString) + 1
|
|
sPattern = ""
|
|
For i = 0 To UBound(vPatterns)
|
|
lNextPattern = InStr(lCurrentChar, psString, vPatterns(i), 1) ' Text (not case-sensitive) string comparison
|
|
If lNextPattern > 0 And lNextPattern < lPattern Then
|
|
lPattern = lNextPattern
|
|
sPattern = Mid(psString, lPattern, Len(vPatterns(i)))
|
|
End If
|
|
Next i
|
|
' Up to the next pattern or to the end of the string, UTF8-encode each character
|
|
For l = lCurrentChar To lPattern - 1
|
|
sChar = Mid(psString, l, 1)
|
|
sOutput = sOutput & Utils._UTF8Encode(sChar)
|
|
Next l
|
|
' Process hyperlink patterns and keep others
|
|
If Len(sPattern) > 0 Then
|
|
Select Case LCase(sPattern)
|
|
Case "<a href=""", "<a id=""", "<img src=""", "<span class="""
|
|
' Up to next quote, url-encode
|
|
lNextQuote = 0
|
|
lUrl = lPattern + Len(sPattern)
|
|
lNextQuote = InStr(lUrl, psString, """", 1)
|
|
If lNextQuote = 0 Then lNextQuote = Len(psString) ' Should not happen but, if quoted string not closed ...
|
|
sUrl = Mid(psString, lUrl, lNextQuote - lUrl)
|
|
sOutput = sOutput & sPattern & sUrl & """"
|
|
lCurrentChar = lNextQuote + 1
|
|
bQuote = False
|
|
bTagEnd = False
|
|
Do
|
|
sChar = Mid(psString, lCurrentChar, 1)
|
|
Select Case sChar
|
|
Case """"
|
|
bQuote = Not bQuote
|
|
sOutput = sOutput & sChar
|
|
Case ">" ' Tag end if not somewhere between quotes
|
|
If Not bQuote Then
|
|
bTagEnd = True
|
|
sOutput = sOutput & sChar
|
|
Else
|
|
sOutput = sOutput & _UTF8Encode(sChar)
|
|
End If
|
|
Case Else
|
|
sOutput = sOutput & _UTF8Encode(sChar)
|
|
End Select
|
|
lCurrentChar = lCurrentChar + 1
|
|
If lCurrentChar > Len(psString) Then bTagEnd = True ' Should not happen but, if tag not closed ...
|
|
Loop Until bTagEnd
|
|
Case Else
|
|
sOutput = sOutput & sPattern
|
|
lCurrentChar = lPattern + Len(sPattern)
|
|
End Select
|
|
Else
|
|
lCurrentChar = Len(psString) + 1
|
|
End If
|
|
Loop
|
|
|
|
_OutputStringToHTML = sOutput
|
|
|
|
End Function ' _OutputStringToHTML V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _OutputToCalc(poData As Object _
|
|
, ByVal psOutputFile As String _
|
|
, ByVal psFilter As String _
|
|
, Optional ByVal plEncoding As Long _
|
|
) As Boolean
|
|
' https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Database_Import
|
|
' https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Filter_Options
|
|
|
|
Dim oCalcDoc As Object, oSheet As Object, vWin As Variant
|
|
Dim vImportDesc() As Variant, iSource As Integer
|
|
Dim oRange As Object, i As Integer, iCol As Integer, oColumns As Object
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
_OutputToCalc = False
|
|
If IsMissing(plEncoding) Then plEncoding = acUTF8Encoding
|
|
' Create a new OO-Calc-Document
|
|
Set oCalcDoc = StarDesktop.LoadComponentFromURL( _
|
|
"private:factory/scalc" _
|
|
, "_default" ,0, Array() _
|
|
)
|
|
|
|
' Get the unique spreadsheet
|
|
Set oSheet = oCalcDoc.Sheets(0)
|
|
|
|
' Describe import
|
|
With poData
|
|
If ._Type = "TABLEDEF" Then
|
|
iSource = com.sun.star.sheet.DataImportMode.TABLE
|
|
Else
|
|
iSource = com.sun.star.sheet.DataImportMode.QUERY
|
|
End If
|
|
vImportDesc = Array( _
|
|
_MakePropertyValue("DatabaseName", URL) _
|
|
, _MakePropertyValue("SourceType", iSource) _
|
|
, _MakePropertyValue("SourceObject", ._Name) _
|
|
)
|
|
oSheet.Name = ._Name
|
|
End With
|
|
|
|
' Import
|
|
oSheet.getCellByPosition(0, 0).doImport(vImportDesc())
|
|
|
|
Select Case psFilter
|
|
Case acFormatODS, acFormatXLS, acFormatXLSX ' Formatting
|
|
iCol = poData.Fields().Count
|
|
Set oRange = oSheet.getCellRangeByPosition(0, 0, iCol - 1, 0)
|
|
oRange.CharWeight = com.sun.star.awt.FontWeight.BOLD
|
|
oRange.CellBackColor = RGB(200, 200, 200)
|
|
oRange.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER
|
|
Set oColumns = oRange.getColumns()
|
|
For i = 0 To iCol - 1
|
|
oColumns.getByIndex(i).OptimalWidth = True
|
|
Next i
|
|
oCalcDoc.storeAsUrl(psOutputFile, Array( _
|
|
_MakePropertyValue("FilterName", psFilter) _
|
|
, _MakePropertyValue("Overwrite", True) _
|
|
))
|
|
Case Else
|
|
oCalcDoc.storeAsUrl(psOutputFile, Array( _
|
|
_MakePropertyValue("FilterName", psFilter) _
|
|
, _MakePropertyValue("FilterOptions", _FilterOptionsDefault(plEncoding)) _
|
|
, _MakePropertyValue("Overwrite", True) _
|
|
))
|
|
End Select
|
|
|
|
oCalcDoc.close(False)
|
|
_OutputToCalc = True
|
|
|
|
Exit_Function:
|
|
Set oColumns = Nothing
|
|
Set oRange = Nothing
|
|
Set oSheet = Nothing
|
|
Set oCalcDoc = Nothing
|
|
Exit Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
|
|
Goto Exit_Function
|
|
End Function ' OutputToCalc V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _OutputToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal psOutputFile As String, ByVal psTemplateFile As String _
|
|
, ByRef Optional pvHeaders As Variant _
|
|
, ByRef Optional pvData As Variant _
|
|
) As Boolean
|
|
' http://www.ehow.com/how_5652706_create-html-template-ms-access.html
|
|
|
|
Dim bDataArray As Boolean
|
|
Dim vMinimalTemplate As Variant, vTemplate As Variant
|
|
Dim iFile As Integer, i As Integer, sLine As String, lBody As Long
|
|
Const cstTitle = "<!--Template_Title-->", cstBody = "<!--Template_Body-->"
|
|
Const cstTitleAlt = "<!--AccessTemplate_Title-->", cstBodyAlt = "<!--AccessTemplate_Body-->"
|
|
|
|
On Local Error GoTo Error_Function
|
|
vMinimalTemplate = Array( _
|
|
"<!DOCTYPE html>" _
|
|
, "<html>" _
|
|
, " <head>" _
|
|
, " <title>" & cstTitle & "</title>" _
|
|
, " </head>" _
|
|
, " <body>" _
|
|
, " " & cstBody _
|
|
, " </body>" _
|
|
, "</html>" _
|
|
)
|
|
|
|
vTemplate = _ReadFileIntoArray(psTemplateFile)
|
|
If LBound(vTemplate) > UBound(vTemplate) Then vTemplate() = vMinimalTemplate()
|
|
|
|
bDataArray = IsNull(pvTable)
|
|
|
|
' Write output file
|
|
iFile = FreeFile()
|
|
Open psOutputFile For Output Access Write Lock Read Write As #iFile
|
|
For i = 0 To UBound(vTemplate)
|
|
sLine = vTemplate(i)
|
|
sLine = Join(Split(sLine, cstTitleAlt), cstTitle)
|
|
sLine = Join(Split(sLine, cstBodyAlt), cstBody)
|
|
Select Case True
|
|
Case InStr(sLine, cstTitle) > 0
|
|
sLine = Join(Split(sLine, cstTitle), pvName)
|
|
Print #iFile, sLine
|
|
Case InStr(sLine, cstBody) > 0
|
|
lBody = InStr(sLine, cstBody)
|
|
If lBody > 1 Then Print #iFile, Left(sLine, lBody - 1)
|
|
If bDataArray Then
|
|
_OutputDataToHTML(pvTable, pvName, iFile, pvHeaders, pvData)
|
|
Else
|
|
_OutputDataToHTML(pvTable, pvName, iFile)
|
|
End If
|
|
If Len(sLine) > lBody + Len(cstBody) - 1 Then Print #iFile, Right(sLine, Len(sLine) - lBody + Len(cstBody) + 1)
|
|
Case Else
|
|
Print #iFile, sLine
|
|
End Select
|
|
Next i
|
|
Close #iFile
|
|
|
|
_OutputToHTML = True
|
|
|
|
Exit_Function:
|
|
Exit Function
|
|
Error_Function:
|
|
_OutputToHTML = False
|
|
GoTo Exit_Function
|
|
End Function ' _OutputToHTML V1.4.0
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _PropertiesList() As Variant
|
|
|
|
_PropertiesList = Array("Connect", "Name", "ObjectType" _
|
|
, "OnCreate", "OnFocus", "OnLoad", "OnLoadFinished", "OnModifyChanged" _
|
|
, "OnNew", "OnPrepareUnload", "OnPrepareViewClosing", "OnSave", "OnSaveAs" _
|
|
, "OnSaveAsDone", "OnSaveAsFailed", "OnSaveDone", "OnSaveFailed", "OnSaveTo" _
|
|
, "OnSaveToDone", "OnSaveToFailed", "OnSubComponentClosed", "OnSubComponentOpened" _
|
|
, "OnTitleChanged", "OnUnfocus", "OnUnload", "OnViewClosed", "OnViewCreated" _
|
|
, "Version" _
|
|
)
|
|
|
|
End Function ' _PropertiesList
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
|
' Return property value of the psProperty property name
|
|
|
|
Dim i As Integer, vEvents As Variant, sEvent As String, vEvent As Variant
|
|
|
|
If _ErrorHandler() Then On Local Error Goto Error_Function
|
|
Utils._SetCalledSub("Database.get" & psProperty)
|
|
|
|
_PropertyGet = EMPTY
|
|
|
|
Select Case UCase(psProperty)
|
|
Case UCase("Connect")
|
|
If IsNull(Document) Then _PropertyGet = "" Else _PropertyGet = Document.Datasource.URL
|
|
' Location = ConvertFromUrl(URL)
|
|
Case UCase("Name")
|
|
_PropertyGet = Title
|
|
Case UCase("ObjectType")
|
|
_PropertyGet = _Type
|
|
Case UCase("OnCreate"), UCase("OnFocus"), UCase("OnLoad"), UCase("OnLoadFinished"), UCase("OnModifyChanged") _
|
|
, UCase("OnNew"), UCase("OnPrepareUnload"), UCase("OnPrepareViewClosing"), UCase("OnSave"), UCase("OnSaveAs") _
|
|
, UCase("OnSaveAsDone"), UCase("OnSaveAsFailed"), UCase("OnSaveDone"), UCase("OnSaveFailed"), UCase("OnSaveTo") _
|
|
, UCase("OnSaveToDone"), UCase("OnSaveToFailed"), UCase("OnSubComponentClosed"), UCase("OnSubComponentOpened") _
|
|
, UCase("OnTitleChanged"), UCase("OnUnfocus"), UCase("OnUnload"), UCase("OnViewClosed"), UCase("OnViewCreated")
|
|
' Find script event
|
|
sEvent = ""
|
|
If IsNull(Document) Then vEvents = Array() Else vEvents = Document.getEvents().ElementNames ' Returns an array
|
|
For i = 0 To UBound(vEvents)
|
|
If UCase(vEvents(i)) = UCase(psProperty) Then
|
|
sEvent = vEvents(i)
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If sEvent = "" Then
|
|
_PropertyGet = ""
|
|
Else
|
|
vEvent = Document.getEvents().getByName(sEvent)
|
|
If IsEmpty(vEvent) Then
|
|
_PropertyGet = ""
|
|
ElseIf vEvent(0).Value <> "Script" Then
|
|
_PropertyGet = ""
|
|
Else
|
|
_PropertyGet = vEvent(1).Value
|
|
End If
|
|
End If
|
|
Case UCase("Version")
|
|
_PropertyGet = MetaData.getDatabaseProductName() & " " & MetaData.getDatabaseProductVersion
|
|
Case Else
|
|
Goto Trace_Error
|
|
End Select
|
|
|
|
Exit_Function:
|
|
Utils._ResetCalledSub("Database.get" & psProperty)
|
|
Exit Function
|
|
Trace_Error:
|
|
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
|
_PropertyGet = EMPTY
|
|
Goto Exit_Function
|
|
Error_Function:
|
|
TraceError(TRACEABORT, Err, "Database._PropertyGet", Erl)
|
|
_PropertyGet = EMPTY
|
|
GoTo Exit_Function
|
|
End Function ' _PropertyGet
|
|
|
|
REM -----------------------------------------------------------------------------------------------------------------------
|
|
Public Function _ReplaceSquareBrackets(ByVal psSql As String) As String
|
|
' Returns psSql after substitution of [] by quote character
|
|
' [] square brackets in (single) quoted strings not affected
|
|
|
|
Dim sQuote As String 'RDBMS specific quote character
|
|
Dim vSubStrings() As Variant, i As Integer
|
|
Const cstSingleQuote = "'"
|
|
|
|
sQuote = MetaData.IdentifierQuoteString
|
|
If sQuote = " " Then ' IdentifierQuoteString returns a space " " if identifier quoting is not supported.
|
|
_ReplaceSquareBrackets = Trim(psSql)
|
|
Exit Function
|
|
End If
|
|
vSubStrings() = Split(psSql, cstSingleQuote)
|
|
For i = 0 To UBound(vSubStrings)
|
|
If (i Mod 2) = 0 Or (i = UBound(vSubStrings)) Then ' Only even substrings are parsed for square brackets. Last substring is parsed anyway
|
|
vSubStrings(i) = Join(Split(vSubStrings(i), "["), sQuote)
|
|
vSubStrings(i) = Join(Split(vSubStrings(i), "]"), sQuote)
|
|
End If
|
|
Next i
|
|
|
|
_ReplaceSquareBrackets = Trim(Join(vSubStrings, cstSingleQuote))
|
|
|
|
End Function ' ReplaceSquareBrackets V1.1.0
|
|
|
|
</script:module> |