Automate Array building in MS Access


By: Michael_0097
May 9, 2014

'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


Need more help?
Describe your Problem
Example: Hard Drive Not Detected on My PC

Ask Question