diff options
author | Jean-Pierre Ledure <jp@ledure.be> | 2015-11-11 14:37:29 +0100 |
---|---|---|
committer | Jean-Pierre Ledure <jp@ledure.be> | 2015-11-11 14:45:41 +0100 |
commit | 32686b0d0a15a653f831d0645e5b7c1145860570 (patch) | |
tree | e59bb03c21200010c826daf2e87603c593872488 /wizards | |
parent | c65e00d908a2dcf47d3ff925d09e336d9b0939f7 (diff) |
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
Diffstat (limited to 'wizards')
-rw-r--r-- | wizards/source/access2base/Database.xba | 404 | ||||
-rw-r--r-- | wizards/source/access2base/DoCmd.xba | 38 | ||||
-rw-r--r-- | wizards/source/access2base/Recordset.xba | 6 | ||||
-rw-r--r-- | wizards/source/access2base/Utils.xba | 58 | ||||
-rw-r--r-- | wizards/source/access2base/acConstants.xba | 11 |
5 files changed, 502 insertions, 15 deletions
diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba index a8fd3e263e42..4d605d0588c5 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 28e2bc38b944..b5c0e9f22ffa 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 28bc2b12e92a..8638e0d9641b 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 321db78bac67..3a2420e3c22c 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 b89e279d2089..3f30ba00f609 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 |