‘If you work with arrays often this function is very handy, works in any Access db
‘References needed:
‘Microsoft Excel NN.0 Object Library
‘Microsoft ActiveX Data Objects 2.8 Library
‘reference to: Microsoft Forms 2.0 Object Library – is need for the array to Clipboard function.
‘have to browse for it with Office 2010:
‘found here: C:\WINDOWS\system32\FM20.DLL
‘CODED BY T Michael Dunn
‘code need to export any table to .xls or a .txt file
Sub TestMod()
Dim aVal() As Variant, sQL As String, sFilePath As String, sErr As String
sQL = “SELECT * FROM T_AppList” ‘WHERE id<>’zzzz'”
sFilePath = “C:\Users\SomeName\Desktop\Launcher_DB\my.txt” ‘\my.xls”
Call sQLToArray(sQL, aVal, sFilePath, “|”, sErr, , , 1) ‘Chr(9)= tab; 1=text; 2=excel;3=debug
If Len(sErr) > 1 Then MsgBox sErr
End Sub
‘part #1 or 2
Public Sub sQLToArray(ByVal sQL As String, aVal As Variant, Optional ByVal sFilePath As String, _
Optional ByRef sParseToken As String, Optional sSheet As String, Optional ByRef sErr As String, _
Optional bSendNoDataNote As Boolean, Optional sFileType As String = “DoNothing”) ‘1=text, Excel,Table, Debug
On Error GoTo eh
‘places any query’s (SQL) records into a dynamic array for selected file output
Dim rS As New ADODB.Recordset
Dim Fld As Field ‘sQl As String ‘sQl = “SELECT * FROM ” & sTbl
Dim iFields As Integer ‘max fields in table
Dim i As Long, iFld As Long ‘used in For loops
Dim iRec As Long ‘Records in table
Dim aflds As Variant ‘used when we pass data to a temp tbl
Dim aType() As Long ‘field type, used if data is sent to Temp table
If Len(sFilePath) > 0 Then Call Kill(sFilePath) ‘delete last weeks file; back up completed earlier in code
‘Debug.Print sQl
‘Stop
rS.Open sQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
If rS.RecordCount < 1 And bSendNoDataNote = False Then
sErr = “No records!”
rS.Close
Exit Sub
End If
iRec = rS.RecordCount
iFields = rS.Fields.Count
ReDim aVal(iRec, iFields) ‘here we set the array to the size of the recordset SQL passed as Arg 1
ReDim aflds(iFields – 1) ‘if we move data to a temp table
ReDim aType(iFields – 1)
‘FILL ARRAY WITH THE DATA FROM THE QUERY’S SQL WE PASSED IN AS AN ARG 1
‘DATA IS PASTED TO FILE WITH THE SAME ORDER IT IS RECIEVED BELOW
For i = 1 To iRec ‘the array stores the data just like a table record
For iFld = 0 To iFields – 1
aVal(i, iFld) = rS.Fields(iFld)
Next
rS.MoveNext
Next
‘If i = 158 Then ‘this would be used to test/trap/find a specific records
‘ Debug.Print aVal(i, iFld)
‘End If
‘FILL HEADER ROW; THIS GETS PASTED IN EXCEL – NOT IN THE TEXT FILE
For i = 0 To iFields – 1
aVal(0, i) = rS.Fields.Item(i).Name ‘the caption names are collected from the source table derived from the SQL
aflds(i) = rS.Fields.Item(i).Name ‘only used if data is moved to a temp table
aType(i) = rS(i).Type
‘debug.Print rS.Fields.Item(i).Name & vbTab & rS(i).Type
Next
rS.Close
Select Case sFileType ‘once the data has been collected into an array, data can be output from one of the following options (below)
Case “DoNothing”
‘
Case “Text”, “1”
Call ArrayToText(aVal, sFilePath, sParseToken, sErr, bSendNoDataNote) ‘text file
Case “Excel”, “2”
Call ArrayToExcel(aVal, sFilePath, sSheet, sErr) ‘excel
Case “Table”, “3”
Call ArrayToTempTable(aVal, aflds, aType) ‘temp table (T_TempTbl_Array)
Case “Clipboard”, 4
Call ArrayToClipboard(aVal, sFilePath, sParseToken, sErr) ‘debug
Case Else
Call ArrayToDebug(aVal, sFilePath, sParseToken, sErr) ‘debug
End Select
ex:
Exit Sub
eh:
On Error Resume Next
If Err.Number = 53 Then ‘kill file – no file to delete
Resume Next
ElseIf Err.Number = 0 Then
MsgBox “Error opening ADO Recordset; SQL=” & vbCrLf & sQL
‘GoTo ex
Resume Next
Else
MsgBox Err.Description & ” ” & Err.Number
sErr = Err.Description & ” ” & Err.Number
rS.Close
Resume Next
End If
End Sub
Private Sub ArrayToTempTable(aVal As Variant, aflds As Variant, aType As Variant) ‘used when we pass data to a temp tbl
On Error GoTo eh
Dim i As Long, iFld As Long ‘used in For loops
Dim iRec As Long ‘Records in table
Dim rS As New ADODB.Recordset
Call Fn_ReCreateTbl(“T_TempTbl_Array”, aflds, aType) ‘we should create the fields to the proper type
rS.Open “T_TempTbl_Array”, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
For i = 0 To UBound(aVal, 1) – 1 ‘rows
rS.AddNew
For iFld = 0 To UBound(aVal, 2) – 1
If Not IsEmpty(aVal(i, iFld)) Then rS(aVal(0, iFld)).value = aVal(i + 1, iFld)
Next
rS.Update
Next
DoCmd.openTable “T_TempTbl_Array”
ex:
rS.Close
Exit Sub
eh:
MsgBox Error$ & vbCrLf & “ArrayToTempTable”
GoTo ex
End Sub
‘part #2 or 2
Private Sub ArrayToText(aVal As Variant, Optional sFilePath As String, Optional sParseToken As String = “|”, Optional sErr As String, Optional bSendNoDataNote As Boolean)
On Error GoTo eh
Dim i As Long, iFld As Long, sLine As String ‘used in For loops
Close #1 ‘you can close the file anytime without an error
Open sFilePath For Output As #1 ‘ Open file for output.
For i = 1 To UBound(aVal, 1)
‘Debug.Print UBound(aVal, 2)
For iFld = 0 To UBound(aVal, 2) – 1 ‘USE THIS WHEN YOU WANT TO USE EVERY FIELD IN THE ARRAY
sLine = sLine & aVal(i, iFld) & sParseToken
Next
‘REMOVE THE TRAILING PIPE
If Right(sLine, 1) = sParseToken Then sLine = Left(sLine, Len(sLine) – 1)
‘Debug.Print sLine
‘Write #1, aDt(i, 1) & “|” & aDt(i, 2) ‘surrounds text in quotes “Example”
Print #1, sLine
sLine = “” ‘clear variable for next line
Next
If UBound(aVal, 1) = 0 Then Print #1, “No data for run date ” & Format(Date, “mm/dd/yyyy”)
Close #1 ‘ Close file.
Exit Sub
eh:
Close #1 ‘ Close file.
‘MsgBox Err.Description & ” ” & Err.Number
sErr = Err.Description & ” ” & Err.Number
‘Resume Next
End Sub
‘part #2 or 2
‘reference to: Microsoft Forms 2.0 Object Library.
‘have to browse for it with Office 2010:
‘C:\WINDOWS\system32\FM20.DLL
Private Sub ArrayToClipboard(aVal As Variant, Optional sFilePath As String, Optional sParseToken As String = “|”, Optional sErr As String, Optional bSendNoDataNote As Boolean)
On Error GoTo eh
Dim i As Long, iFld As Long, sLine As String ‘used in For loops
Dim DataObj As New MSForms.DataObject
‘Dim S As String
sParseToken = Chr(9)
For i = 1 To UBound(aVal, 1)
For iFld = 0 To UBound(aVal, 2) – 1 ‘USE THIS WHEN YOU WANT TO USE EVERY FIELD IN THE ARRAY
sLine = sLine & aVal(i, iFld) & sParseToken
Next
‘REMOVE THE TRAILING PIPE
If Right(sLine, 1) = sParseToken Then sLine = Left(sLine, Len(sLine) – 1)
sLine = sLine & Chr(13) & Chr(10) ‘add the page break
Next
‘If UBound(aVal, 1) = 0 Then Print #1, “No data for run date ” & Format(Date, “mm/dd/yyyy”)
DataObj.SetText sLine
DataObj.PutInClipboard
Exit Sub
eh:
‘MsgBox Err.Description & ” ” & Err.Number
sErr = Err.Description & ” ” & Err.Number
‘Resume Next
End Sub
‘this code might need to be debuged – seems to run ok 11/19/07
‘takes any 2 dimesional array and exports the data to MS Excel
Private Sub ArrayToExcel(aVal As Variant, Optional sFilePath As String, Optional sSheet As String, Optional sErr As String)
On Error Resume Next ‘until excel file is open the change to: On Error GoTo eh
Const ERR_APP_NOTRUNNING As Long = 429
Dim i As Long, iFld As Long, sLine As String ‘used in For loops
Dim Rng As Range, sCol As String
Dim xlsheet As Excel.Worksheet
Dim XlApp As Excel.Application
Dim wrkbk As Excel.Workbook
‘BYPASS ON OPEN EVENT WHEN OPENING EXCEL WITH CODE
‘If Dir(sFilePath) = “” Then
Set XlApp = GetObject(, “Excel.Application”) ‘IF THE APP IS OPEN USE THAT INSTANCE
If Err = ERR_APP_NOTRUNNING Then
Set XlApp = New Excel.Application ‘THE APP IS NOT OPEN SO WE CREATE A NEW INSTANCE
Err = 0
End If
‘Set xlApp = CreateObject(“Excel.Application”)
XlApp.EnableEvents = False
XlApp.DisplayAlerts = False
On Error GoTo eh
Set wrkbk = XlApp.Workbooks.Open(sFilePath, , , , “IF_PSWRD_ERRS_TO_1004”)
‘Set wrkbk = GetObject(sFilePath) ‘same code as above
Set xlsheet = wrkbk.Worksheets(sSheet) ‘is this Sheet fixed?
xlsheet.Cells.Clear ‘make sure the worksheet is clear for the next set of data
If 2 = 1 Then ‘this is the old method
For i = 1 To UBound(aVal, 1)
For iFld = 0 To UBound(aVal, 2)
xlsheet.Cells(i + 1, iFld + 1) = aVal(i, iFld) ‘start at row 2 (+1) and paste all values into the worksheet
Next
Next
‘ADD HEADER ROW
For i = 0 To UBound(aVal, 2)
xlsheet.Cells(1, i + 1) = aVal(0, i) ‘start at row 2 (+1) and paste all values into the worksheet
Next
Else ‘NEW METHOD; DROP ARRAY INTO WORKSHEET WITH OUT LOOPING THOUGH AN ARRAY
sCol = “a1:” & FnColNumberToLetter(xlsheet, UBound(aVal, 2)) & UBound(aVal, 1) + 1
Set Rng = xlsheet.Range(“a1:” & FnColNumberToLetter(xlsheet, UBound(aVal, 2)) & UBound(aVal, 1) + 1)
Rng = aVal
End If
myExit:
On Error Resume Next
wrkbk.Application.Cursor = xlDefault
wrkbk.Application.ScreenUpdating = True ‘I don’t know why but if you turn on ScreenUpdating = True everything works fine when you want to use excel after having opened it with access!
wrkbk.SaveAs sFilePath ‘works if it’s a new file, but will not over-write an existing file
wrkbk.Application.DisplayAlerts = True
wrkbk.Close SaveChanges:=True, FileName:=sFilePath ‘xlSaveChanges, sFilePath
Set wrkbk = Nothing
Set xlsheet = Nothing
Exit Sub
eh:
If Err.Number = 1004 Then ‘ERRORS HERE: Set wrkbk = xlApp.Workbooks.Open(sFilePath) ; So we add a new workbook and continue
If InStr(1, Err.Description, “password”, vbTextCompare) Then ‘a password protected file
Exit Sub
End If
Set wrkbk = XlApp.Workbooks.Add
Resume Next
ElseIf Err.Number = 9 Then ‘worksheet not found
Set xlsheet = wrkbk.Worksheets(1)
‘sErr = “Worksheet ” & sSheet & ” NOT found; data inserted into ” & xlsheet.Name
Resume Next
Else
‘Debug.Print Err.Description & ” ” & Err.Number
sErr = Err.Description & ” ” & Err.Number
sErr = sErr & vbCrLf & “Err in: Mod.Sub [ArrayToExcel]. xls name: ” & xlsheet.Name
GoTo myExit
End If
‘MsgBox Err.Description & ” ” & Err.Number
End Sub
Private Function FnColNumberToLetter(xlsheet As Excel.Worksheet, i As Integer) As String
FnColNumberToLetter = AlphaOnly(xlsheet.Cells(1, i).Address)
End Function
Private Function AlphaOnly(str As Variant)
Dim i As Long
Dim StrLen As Long
Dim c As String * 1 ‘max string length of 1
‘c = “ccc”
StrLen = Len(str)
AlphaOnly = “”
For i = 1 To StrLen
c = Mid(str, i, 1)
If c Like “[a-zA-Z ]” Then AlphaOnly = AlphaOnly & c
Next i
End Function
Private Sub ArrayToDebug(aVal As Variant, Optional sFilePath As String, Optional sParseToken As String = “|”, Optional sErr As String)
On Error GoTo eh
Dim i As Long, iFld As Long, sLine As String ‘used in For loops
For i = 1 To UBound(aVal, 1)
For iFld = 0 To UBound(aVal, 2)
sLine = sLine & aVal(i, iFld) & sParseToken
Next
sLine = Left(sLine, Len(sLine) – 1)
‘Debug.Print sLine
sLine = “”
Next
Exit Sub
eh:
‘MsgBox Err.Description & ” ” & Err.Number
sErr = Err.Description & ” ” & Err.Number
‘Resume Next
End Sub
‘if the table is not created, create it
‘we do this so we can simply import a form and all the code is included to use in any db
‘how we use this code:
‘Dim aflds As Variant
‘aflds = Array(“FieldName1”, “FieldName2”, “FieldName3”, “FieldName4”, “FieldName5”, “etc”)
‘Fn_ReCreateTbl(“TL_TblSpec”,aflds)
Private Sub Fn_ReCreateTbl(sTblName As String, aflds As Variant, aType As Variant)
On Error GoTo eh
Dim dbs As dao.database, tbl As TableDef, Fld As Object
Dim i As Long
Dim sFld As String
Dim iType As Long
Set dbs = CurrentDb
On Error Resume Next
DoCmd.Close acTable, “T_TempTbl_Array”, acSaveNo
CurrentDb.Execute “DROP TABLE ” & sTblName
On Error GoTo eh
Set tbl = dbs.CreateTableDef(sTblName)
‘Stop
For i = 0 To UBound(aflds)
If aType(i) = 202 Or aType(i) = 203 Then ‘text or memo field, so we can allow zero length string
Set Fld = tbl.CreateField(aflds(i), FnTypeConversion(aType(i))) ‘dbText)
Fld.AllowZeroLength = True
Else
Set Fld = tbl.CreateField(aflds(i), FnTypeConversion(aType(i))) ‘dbText)
End If
sFld = aflds(i) & “,”
tbl.Fields.Append Fld
‘fld.AllowZeroLength = True
Next
‘Stop
dbs.TableDefs.Append tbl
dbs.TableDefs.Refresh
‘If Len(sFld) > 0 Then sFld = Mid(sFld, 1, Len(sFld) – 1) ‘remove trailing comma
ex:
Exit Sub
eh:
MsgBox Err.Description & ” ” & Err.Number
Resume Next
End Sub
Private Function FnTypeConversion(iType As Variant) As Long ‘convert the ADO type to DAO (create table type)…. text, memo, date, integer, long, etc..
‘see
‘http://allenbrowne.com/ser-49.html
On Error GoTo ex
Select Case iType
Case 202, “text”
FnTypeConversion = 10 ‘text
Case 130, “text”
FnTypeConversion = 10 ‘Text
Case 203, “memo”
FnTypeConversion = 12 ‘memo
Case 17, “small int”
FnTypeConversion = 2 ‘small int
Case 2, “integer”
FnTypeConversion = 3 ‘int
Case 3, “auto”
FnTypeConversion = 4 ‘autoNumber
Case 4, “single”
FnTypeConversion = 6 ‘single
Case 5, “double”
FnTypeConversion = 7 ‘dbl
Case 72, “dbguid”
FnTypeConversion = 15 ‘dbguid
Case 131, “decimal”
FnTypeConversion = 20 ‘decimal
Case 7, “date”
FnTypeConversion = 8 ‘date
Case 6, “currency”
FnTypeConversion = 5 ‘currency
Case 11, “boolean”
FnTypeConversion = 1 ‘boolean
Case 205, “bianary”
FnTypeConversion = 11 ‘bianary
Case 203, “hyper”
FnTypeConversion = 12 ‘hyper – goes to memo, see above
Case Else
FnTypeConversion = 10 ‘text
End Select
Exit Function
ex:
MsgBox Error$
FnTypeConversion = 10
End Function
