wizards/source/access2base/Database.xba | 108 +++++++++++++++++++++--------
wizards/source/access2base/acConstants.xba | 1
2 files changed, 80 insertions(+), 29 deletions(-)
New commits:
commit feed5f8a4b3f995a9591a015ba1554078cad9f9f
Author: Jean-Pierre Ledure <j...@ledure.be>
Date: Sat Nov 12 14:55:51 2016 +0100
Access2Base - OutputTo method accepts input from array
in addition to tables and queries.
(only for internal use - arguments not published in documentation)
Change-Id: I4c7aff878a4ff1a03dcc32baae740559d034d3ca
diff --git a/wizards/source/access2base/Database.xba
b/wizards/source/access2base/Database.xba
index 1f44cf7..8853295 100644
--- a/wizards/source/access2base/Database.xba
+++ b/wizards/source/access2base/Database.xba
@@ -629,8 +629,11 @@ Public Function OutputTo(ByVal pvObjectType 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"
@@ -638,7 +641,7 @@ Const cstThisSub = "Database.OutputTo"
OutputTo = False
- If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(),
Array(acOutputTable, acOutputQuery)) Then Goto Exit_Function
+ 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 = ""
@@ -663,13 +666,21 @@ Const cstThisSub = "Database.OutputTo"
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
- '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
+ 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
@@ -698,7 +709,11 @@ Dim sOutputFormat As String, iTemplate As Integer,
iOutputFile As Integer, bOutp
'Create file
Select Case sOutputFormat
Case UCase(acFormatHTML), "HTML"
- bOutput = _OutputToHTML(oTable, sOutputFile,
pvTemplateFile)
+ 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"
@@ -708,7 +723,6 @@ Dim sOutputFormat As String, iTemplate As Integer,
iOutputFile As Integer, bOutp
Case UCase(acFormatTXT), "TXT", "CSV"
bOutput = _OutputToCalc(oTable, sOutputFile,
acFormatTXT, pvEncoding)
End Select
- oTable.Dispose()
'Launch application, if requested
If bOutput Then
@@ -720,6 +734,10 @@ Dim sOutputFormat As String, iTemplate As Integer,
iOutputFile As Integer, bOutp
OutputTo = True
Exit_Function:
+ If Not IsNull(oTable) Then
+ oTable.Dispose()
+ Set oTable = Nothing
+ End If
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotFound:
@@ -1225,36 +1243,50 @@ Private Function _OutputClassToHTML(ByVal pvArray As
variant) As String
End Function ' _OutputClassToHTML V1.4.0
REM
-----------------------------------------------------------------------------------------------------------------------
-Private Function _OutputDataToHTML(poTable As Object, piFile As Integer) As
Boolean
-' Write html tags around data found in poTable
+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>" & poTable._Name &
"</caption>"
+ Print #piFile, " <caption>" & pvName &
"</caption>"
- Set oTableRS = poTable.OpenRecordset( , , dbReadOnly)
vFieldsBin() = Array()
- iNumFields = oTableRS.Fields.Count
- ReDim vFieldsBin(0 To iNumFields - 1)
- With com.sun.star.sdbc.DataType
+ If bDataArray Then
+ Set oTableRS = Nothing
+ iNumFields = UBound(pvHeaders) + 1
+ ReDim vFieldsBin(0 To iNumFields - 1)
For i = 0 To iNumFields - 1
- iDataType = oTableRS.Fields(i).DataType
- vFieldsBin(i) = False
- If iDataType = .BINARY Or iDataType = .VARBINARY Or
iDataType = .LONGVARBINARY Or iDataType = .BLOB Or iDataType = .CLOB Then
vFieldsBin(i) = True
+ vFieldsBin(i) = False
Next i
- End With
+ 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
- Print #piFile, " <th
scope=""col"">" & .Fields(i)._Name &
"</th>"
+ 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>"
@@ -1262,13 +1294,21 @@ Const cstMaxRows = 200
Print #piFile, " </tfoot>"
Print #piFile, " <tbody>"
- .MoveLast
- iLastRow = .RecordCount
- .MoveFirst
+ If bDataArray Then
+ iLastRow = UBound(pvData, 2) + 1
+ Else
+ .MoveLast
+ iLastRow = .RecordCount
+ .MoveFirst
+ End If
iCountRows = 0
- Do While Not .EOF()
- vData() = .GetRows(cstMaxRows)
- iNumRows = UBound(vData, 2) + 1
+ 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()
@@ -1281,7 +1321,7 @@ Const cstMaxRows = 200
If i = 0 Then vTdClass() =
_AddArray(vTdClass, "firstcol")
If i = iNumFields - 1 Then vTdClass() =
_AddArray(vTdClass, "lastcol")
If Not vFieldsBin(i) Then
- vDataCell = vData(i, j)
+ If bDataArray Then vDataCell =
pvData(i, j) Else vDataCell = vData(i, j)
Select Case VarType(vDataCell)
Case vbEmpty, vbNull
vTdClass() =
_AddArray(vTdClass, "null")
@@ -1310,7 +1350,7 @@ Const cstMaxRows = 200
Next j
Loop
- .mClose()
+ If Not bDataArray Then .mClose()
End With
Set oTableRS = Nothing
@@ -1537,9 +1577,13 @@ Error_Function:
End Function ' OutputToCalc V1.4.0
REM
-----------------------------------------------------------------------------------------------------------------------
-Public Function _OutputToHTML(poTable As Object, ByVal psOutputFile As String,
ByVal psTemplateFile As String) As Boolean
+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-->"
@@ -1560,6 +1604,8 @@ Const cstTitleAlt =
"<!--AccessTemplate_Title-->", cstBodyAlt =
vTemplate = _ReadFileIntoArray(psTemplateFile)
If LBound(vTemplate) > UBound(vTemplate) Then vTemplate() =
vMinimalTemplate()
+
+ bDataArray = IsNull(pvTable)
' Write output file
iFile = FreeFile()
@@ -1570,12 +1616,16 @@ Const cstTitleAlt =
"<!--AccessTemplate_Title-->", cstBodyAlt =
sLine = Join(Split(sLine, cstBodyAlt), cstBody)
Select Case True
Case InStr(sLine, cstTitle) > 0
- sLine = Join(Split(sLine, cstTitle),
poTable._Name)
+ 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)
- _OutputDataToHTML(poTable, iFile)
+ 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
diff --git a/wizards/source/access2base/acConstants.xba
b/wizards/source/access2base/acConstants.xba
index f804074..446d1aa 100644
--- a/wizards/source/access2base/acConstants.xba
+++ b/wizards/source/access2base/acConstants.xba
@@ -277,6 +277,7 @@ REM
-----------------------------------------------------------------
Global Const acOutputTable = 0
Global Const acOutputQuery = 1
Global Const acOutputForm = 2
+Global Const acOutputArray = -1
REM AcEncoding
REM -----------------------------------------------------------------
_______________________________________________
Libreoffice-commits mailing list
libreoffice-comm...@lists.freedesktop.org
https://lists.freedesktop.org/mailman/listinfo/libreoffice-commits
