wizards/source/access2base/Database.xba | 404 +++++++++++++++++++++++++++++
wizards/source/access2base/DoCmd.xba | 38 ++
wizards/source/access2base/Recordset.xba | 6
wizards/source/access2base/Utils.xba | 58 +++-
wizards/source/access2base/acConstants.xba | 11
5 files changed, 502 insertions(+), 15 deletions(-)
New commits:
commit 32686b0d0a15a653f831d0645e5b7c1145860570
Author: Jean-Pierre Ledure <j...@ledure.be>
Date: Wed Nov 11 14:37:29 2015 +0100
Access2Base - Implements OutputTo table/query in HTML format
Functions to export database data contents into an HTML table
with - template file
- use of classes for CSS styling
Change-Id: Ib62b103445ba47e2fe77c45109a62b2e49fcbbc5
diff --git a/wizards/source/access2base/Database.xba
b/wizards/source/access2base/Database.xba
index a8fd3e2..4d605d0 100644
--- a/wizards/source/access2base/Database.xba
+++ b/wizards/source/access2base/Database.xba
@@ -582,6 +582,104 @@ Error_NotApplicable:
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 _
+ ) As Boolean
+'Supported: acFormatHTML for tables and queries
+
+ 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)) 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", "")) _
+ 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(), Array(0,
acUTF8Encoding)) Then Goto Exit_Function
+ If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint
+ If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(),
Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function
+
+Dim sOutputFile As String, bFound As Boolean, i As Integer, iCount As Integer,
oTable As Object
+Dim sOutputFormat As String, iTemplate As Integer, iOutputFile As Integer,
bOutput As Boolean
+ 'Find applicable table or query
+ bFound = False
+ If pvObjectType = acOutputTable Then iCount = TableDefs.Count Else
iCount = Querydefs.Count
+ For i = 0 To iCount
+ If pvObjectType = acOutputTable Then Set oTable = TableDefs(i)
Else Set oTable = Querydefs(i)
+ If UCase(oTable._Name) = UCase(pvObjectName) Then
+ bFound = True
+ Exit For
+ End If
+ Next i
+ If Not bFound Then Goto Error_NotFound
+
+ 'Determine format and parameters
+ If pvOutputFormat = "" Then
+ sOutputFormat = _PromptFormat() ' Prompt
user for format
+ If sOutputFormat = "" Then Goto Exit_Function
+ If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString,
Array(UCase(acFormatHTML), "HTML", "")) _
+ Then Goto Exit_Function '
Today only value, later maybe Calc ?
+ Else
+ sOutputFormat = UCase(pvOutputFormat)
+ End If
+
+ '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
+ bOutput = _OutputToHTML(oTable, sOutputFile, pvTemplateFile)
+ Set oTable = Nothing
+
+ 'Launch application, if requested
+ If bOutput Then
+ If pvAutoStart Then Call _ShellExecute(sOutputFile)
+ Else
+ GoTo Error_File
+ End If
+
+ 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_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
@@ -906,6 +1004,312 @@ Error_Function: ' Item by key aborted
End Function ' _hasRecordset V0.9.5
REM
-----------------------------------------------------------------------------------------------------------------------
+Private Function _OutputBooleanToHTML(ByVal pbBool As Boolean) As String
+' Converts input boolean value to HTML compatible string
+
+ _OutputBooleanToHTML = Iif(pbBool, "&#9745;",
"&#9746;")
+
+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(poTable As Object, piFile As Integer) As
Boolean
+' Write html tags around data found in poTable
+' 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 vFieldsSkip() As Variant, iDataType As Integer, iNumRows As Integer,
iNumFields As Integer, vDataCell As Variant
+Dim vTrClass() As Variant, vTdClass As Variant, iCountRows As Integer,
iLastRow As Integer, iFirstCol As Integer, iLastCol As Integer
+Const cstMaxRows = 200
+ On Local Error GoTo Error_Function
+
+ Print #piFile, " <table
class=""dbdatatable"">"
+ Print #piFile, " <caption>" & poTable._Name &
"</caption>"
+
+ Set oTableRS = poTable.OpenRecordset( , , dbReadOnly)
+ vFieldsSkip() = Array()
+ iNumFields = oTableRS.Fields.Count
+ ReDim vFieldsSkip(0 To iNumFields - 1)
+ With com.sun.star.sdbc.DataType
+ iFirstCol = -1
+ iLastCol = -1
+ For i = 0 To iNumFields - 1
+ iDataType = oTableRS.Fields(i).DataType
+ vFieldsSkip(i) = False
+ If iDataType = .BINARY Or iDataType = .VARBINARY Or
iDataType = .LONGVARBINARY Or iDataType = .BLOB Or iDataType = .CLOB Then
vFieldsSkip(i) = True
+ If Not vFieldsSkip(i) Then
+ If iFirstCol < 0 Then iFirstCol = i
+ iLastCol = i
+ End If
+ Next i
+ End With
+
+ With oTableRS
+ Print #piFile, " <thead>"
+ Print #piFile, " <tr>"
+ For i = 0 To iNumFields - 1
+ If Not vFieldsSkip(i) Then
+ Print #piFile, " <th
scope=""col"">" & .Fields(i)._Name &
"</th>"
+ End If
+ Next i
+ Print #piFile, " </tr>"
+ Print #piFile, " </thead>"
+ Print #piFile, " <tfoot>"
+ Print #piFile, " </tfoot>"
+
+ Print #piFile, " <tbody>"
+ .MoveLast
+ iLastRow = .RecordCount
+ .MoveFirst
+ iCountRows = 0
+ Do While Not .EOF()
+ vData() = .GetRows(cstMaxRows)
+ iNumRows = UBound(vData, 2) + 1
+ 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 = iFirstCol Then vTdClass() =
_AddArray(vTdClass, "firstcol")
+ If i = iLastCol Then vTdClass() =
_AddArray(vTdClass, "lastcol")
+ If Not vFieldsSkip(i) Then
+ vDataCell = vData(i, j)
+ 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")
+ 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
+ End If
+ Next i
+ Print #piFile, " </tr>"
+ Next j
+ Loop
+
+ .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
+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 date 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 = Int(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>", "<img src=""" _
+ , "<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=""",
"<img src="""
+ ' 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 &
ConvertToUrl(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
-----------------------------------------------------------------------------------------------------------------------
+Public Function _OutputToHTML(poTable As Object, ByVal psOutputFile As String,
ByVal psTemplateFile As String) As Boolean
+' http://www.ehow.com/how_5652706_create-html-template-ms-access.html
+
+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()
+
+' 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),
poTable._Name)
+ 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 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("ObjectType")
diff --git a/wizards/source/access2base/DoCmd.xba
b/wizards/source/access2base/DoCmd.xba
index 28e2bc3..b5c0e9f 100644
--- a/wizards/source/access2base/DoCmd.xba
+++ b/wizards/source/access2base/DoCmd.xba
@@ -1210,14 +1210,18 @@ Public Function OutputTo(ByVal pvObjectType As Variant _
, ByVal Optional
pvAutoStart As Variant _
, ByVal Optional
pvTemplateFile As Variant _
, ByVal Optional
pvEncoding As Variant _
+ , ByVal Optional
pvQuality As Variant _
) As Boolean
'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for
forms
+' acFormatHTML for tables and queries
If _ErrorHandler() Then On Local Error Goto Error_Function
- Utils._SetCalledSub("OutputTo")
+Const cstThisSub = "OutputTo"
+ Utils._SetCalledSub(cstThisSub)
+
OutputTo = False
- If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(),
acSendForm) Then Goto Exit_Function
+ 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 = ""
@@ -1233,15 +1237,31 @@ Public Function OutputTo(ByVal pvObjectType As Variant _
If IsMissing(pvAutoStart) Then pvAutoStart = False
If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto
Exit_Function
If IsMissing(pvTemplateFile) Then pvTemplateFile = ""
- If Not Utils._CheckArgument(pvTemplateFile, 6, vbString, "")
Then Goto Exit_Function
- If IsMissing(pvEncoding) Then pvEncoding = ""
- If Not Utils._CheckArgument(pvEncoding, 7, vbString, "") Then
Goto Exit_Function
+ If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto
Exit_Function
+ If IsMissing(pvEncoding) Then pvEncoding = 0
+ If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric(), Array(0,
acUTF8Encoding)) 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 <> acSendForm Then Goto Error_Action
+ If vWindow.WindowType <> acOutoutForm Then Goto
Error_Action
Set ofForm = Application.Forms(vWindow._Name)
Else
bFound = False
@@ -1309,7 +1329,7 @@ Dim sOutputFormat As String, sFilter As String,
oFilterData As Object, oExport A
OutputTo = True
Exit_Function:
- Utils._ResetCalledSub("OutputTo")
+ Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, ,
Array(_GetLabel("OBJECT"), pvObjectName))
@@ -1318,7 +1338,7 @@ Error_Action:
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Function:
- TraceError(TRACEABORT, Err, "OutputTo", Erl)
+ TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_File:
TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, ,
sOutputFile)
@@ -2436,7 +2456,7 @@ Const cstComma = ","
& Iif(psSubject = "",
"", "subject=" & psSubject & "&") _
& Iif(psBody = "", "",
"body=" & psBody & "&")
If Right(sMailTo, 1) = "&" Or Right(sMailTo, 1) =
"?" Then sMailTo = Left(sMailTo, Len(sMailTo) - 1)
- sMailTo = Utils._URLEncode(sMailTo)
+ sMailTo = ConvertToUrl(sMailTo)
oDispatch = createUnoService(
"com.sun.star.frame.DispatchHelper")
oDispatch.executeDispatch(StarDesktop, sMailTo, "", 0,
Array())
diff --git a/wizards/source/access2base/Recordset.xba
b/wizards/source/access2base/Recordset.xba
index 28bc2b1..8638e0d 100644
--- a/wizards/source/access2base/Recordset.xba
+++ b/wizards/source/access2base/Recordset.xba
@@ -559,17 +559,17 @@ Dim vMatrix() As Variant, lSize As Long, iNumFields As
Integer, i As Integer
iNumFields = RowSet.getColumns().Count - 1
If iNumFields < 0 Then Goto Exit_Function
- ReDim vMatrix(0 To pvNumRows - 1, 0 To iNumFields)
' Conscious opposite of MSAccess !!
+ ReDim vMatrix(0 To iNumFields, 0 To pvNumRows - 1)
Do While Not _EOF And lSize < pvNumRows - 1
lSize = lSize + 1
For i = 0 To iNumFields
- vMatrix(lSize, i) = _getResultSetColumnValue(RowSet, i
+ 1)
+ vMatrix(i, lSize) = _getResultSetColumnValue(RowSet, i
+ 1)
Next i
_Move("NEXT")
Loop
If lSize < pvNumRows - 1 Then '
Resize to number of fetched records
- ReDim Preserve vMatrix(0 To lSize, 0 To iNumFields)
+ ReDim Preserve vMatrix(0 To iNumFields, 0 To lSize)
End If
Exit_Function:
diff --git a/wizards/source/access2base/Utils.xba
b/wizards/source/access2base/Utils.xba
index 321db78..3a2420e 100644
--- a/wizards/source/access2base/Utils.xba
+++ b/wizards/source/access2base/Utils.xba
@@ -13,6 +13,18 @@ REM
----------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS
---
REM
-----------------------------------------------------------------------------------------------------------------------
+Public Function _AddArray(ByVal pvArray As Variant, pvItem As Variant) As
Variant
+'Add the item at the end of the array
+
+Dim vArray() As Variant
+ If IsArray(pvArray) Then vArray = pvArray Else vArray = Array()
+ ReDim Preserve vArray(LBound(vArray) To UBound(vArray) + 1)
+ vArray(UBound(vArray)) = pvItem
+ _AddArray() = vArray()
+
+End Function
+
+REM
-----------------------------------------------------------------------------------------------------------------------
Public Function _AddNumeric(ByVal Optional pvTypes As Variant) As Variant
'Return on top of argument the list of all numeric types
'Facilitates the entry of the list of allowed types in _CheckArgument
calls
@@ -596,11 +608,11 @@ Dim lChar As Long, sByte1 As String, sByte2 As String,
sByte3 As String
Select Case lChar
Case 48 To 57, 65 To 90, 97 To 122 ' 0-9,
A-Z, a-z
_PercentEncode = psChar
- Case "-", ".", "_", "~"
+ Case Asc("-"), Asc("."),
Asc("_"), Asc("~")
_PercentEncode = psChar
- Case "!", "$", "&",
"'", "(", ")", "*", "+",
",", ";", "=" ' Reserved
characters used as delimitors in query strings
+ Case Asc("!"), Asc("$"),
Asc("&"), Asc("'"), Asc("("),
Asc(")"), Asc("*"), Asc("+"), Asc(","),
Asc(";"), Asc("=") ' Reserved characters used
as delimitors in query strings
_PercentEncode = psChar
- Case " ", "%"
+ Case Asc(" "), Asc("%")
_PercentEncode = "%" &
Right("00" & Hex(lChar), 2)
Case 0 To 127
_PercentEncode = psChar
@@ -622,6 +634,46 @@ Dim lChar As Long, sByte1 As String, sByte2 As String,
sByte3 As String
End Function ' _PercentEncode V1.4.0
REM
-----------------------------------------------------------------------------------------------------------------------
+Public Function _ReadFileIntoArray(ByVal psFileName) As Variant
+' Loads all lines of a text file into a variant array
+' Any error reduces output to an empty array
+' Input file name presumed in URL form
+
+Dim vLines() As Variant, iFile As Integer, sLine As String, iCount1 As
Integer, iCount2 As Integer
+Const cstMaxLines = 16000 ' +/- the limit of array sizes in
Basic
+ On Local Error GoTo Error_Function
+ vLines = Array()
+ _ReadFileIntoArray = Array()
+ If psFileName = "" Then Exit Function
+
+ iFile = FreeFile()
+ Open psFileName For Input Access Read Shared As #iFile
+ iCount1 = 0
+ Do While Not Eof(iFile) And iCount1 < cstMaxLines
+ Line Input #iFile, sLine
+ iCount1 = iCount1 + 1
+ Loop
+ Close #iFile
+
+ ReDim vLines(0 To iCount1 - 1) ' Reading file twice
preferred to ReDim Preserve for performance reasons
+ iFile = FreeFile()
+ Open psFileName For Input Access Read Shared As #iFile
+ iCount2 = 0
+ Do While Not Eof(iFile) And iCount2 < iCount1
+ Line Input #iFile, vLines(iCount2)
+ iCount2 = iCount2 + 1
+ Loop
+ Close #iFile
+
+Exit_Function:
+ _ReadFileIntoArray() = vLines()
+ Exit Function
+Error_Function:
+ vLines = Array()
+ Resume Exit_Function
+End Function ' _ReadFileIntoArray V1.4.0
+
+REM
-----------------------------------------------------------------------------------------------------------------------
Public Sub _ResetCalledSub(ByVal psSub As String)
' Called in bottom of each public function. _A2B_.CalledSub variable is
used for error handling
' Used to trace routine in/outs and to clarify error messages
diff --git a/wizards/source/access2base/acConstants.xba
b/wizards/source/access2base/acConstants.xba
index b89e279..3f30ba0 100644
--- a/wizards/source/access2base/acConstants.xba
+++ b/wizards/source/access2base/acConstants.xba
@@ -273,8 +273,14 @@ Global Const acSendTable = 0
REM AcOutputObjectType
REM -----------------------------------------------------------------
+Global Const acOutputTable = 0
+Global Const acOutputQuery = 1
Global Const acOutputForm = 2
+REM AcEncoding
+REM -----------------------------------------------------------------
+Global Const acUTF8Encoding = 65001
+
REM AcFormat
REM -----------------------------------------------------------------
Global Const acFormatPDF = "writer_pdf_Export"
@@ -282,6 +288,11 @@ Global Const acFormatODT = "writer8"
Global Const acFormatDOC = "MS Word 97"
Global Const acFormatHTML = "HTML"
+REM AcExportQuality
+REM -----------------------------------------------------------------
+Global Const acExportQualityPrint = 0
+Global Const acExportQualityScreen = 1
+
REM AcSysCmdAction
REM -----------------------------------------------------------------
Global Const acSysCmdAccessDir = 9
_______________________________________________
Libreoffice-commits mailing list
libreoffice-comm...@lists.freedesktop.org
http://lists.freedesktop.org/mailman/listinfo/libreoffice-commits
