VBScript / Excel 2007 - An easy way to access DBF files

Introduction

Here are two code snippets covering how to use ADODB to read and write Excel data into/out of DBF files:

I could have tried a lot harder to lay this out, but the day job is getting in the way :( Anyhow, if you're looking to read or write data from DBF files, or any other sort of database, this might be worth a read.

• Reading
• Writing

Opening DBF Files in Excel 2007

It would seem that Excel 2007 has dropped support for DBF files. Here is a very simple script to open DBF files in Excel 2007.

This is a first cut script. I have forced Excel to not do data conversion using the 'formula' trick. So, this is OK for viewing files, but needs more work to be perfect. I'll try and find some more time soon. To use the script, place it on your desktop. Then, drag the DBF file onto it and drop it on the script. The script will then open Excel and load the data from the DBF file into a new spreadsheet in a new workbook.

If you would like to learn more about drag-and-drop scripting, Scripting Macros, and generally become an Excel god, see my book "Baby Steps - how to become an Excel god without really trying". There is a link at the bottom of this page for more information.

' Here is the script,I'll do a DBF write version soon
Option Explicit 
Dim inputFile,path,fileName,tableName
Dim rs,fieldVals,i,myExcel,myWorkBook,mySheet,row,column
Const adOpenDynamic=2
Const adLockPessimistic=2
Const adCmdTable=2
Const adOpenForwardOnly=0

inputFile=WScript.Arguments.Item(0)
path=Split(inputFile,"\")
fileName=path(Ubound(path))
path(Ubound(path))=""
path=Join(path,"\")
tableName=Left(fileName,Len(fileName)-4)
Dim dBConn
Set dBConn=OpenDBFConn(path)

Set rs=CreateObject("ADODB.Recordset")
rs.Open tableName, dbConn, adOpenForwardOnly, _
        adLockPessimistic, adCmdTable

Set myExcel=CreateObject("Excel.Application")
Set myWorkBook=myExcel.Workbooks.Add()
Set mySheet=myWorkBook.Sheets(1)
myExcel.Visible=TRUE

rs.MoveFirst
Dim field
row=1
column=1
For Each field In rs.Fields
    mySheet.Cells(row,column).Value=field.Name
    WScript.Echo field.type
    column=column+1
Next
row=2

Redim fieldVals(rs.Fields.Count - 1)

While Not rs.EOF
    column=0
    For Each field In rs.Fields
        fieldVals(column)="=""" & _
                          field.Value & """"
        column=column+1
    Next
    mySheet.Range(mySheet.Cells(row,1), _
            mySheet.Cells(row,column)).Formula=fieldVals
    row=row+1
    rs.MoveNext
Wend
rs.Close
WScript.Echo "Loading Finished"

Function OpenDBFConn(Path)
    Dim Conn
    Set Conn = CreateObject("ADODB.Connection")
    Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & Path & ";" & _
                   "Extended Properties=""DBASE IV;"";" 
    Set OpenDBFConn = Conn
End Function

Converting Excel Files to DBF Format

Again, it would appear that Excel 2007 has dropped support for DBF format. Here is a simple script which converts Excel (.xls, .xlsx, .csv etc.) files to DBF format.

This is a very long way from being perfect. The worse thing about this implementation is that it only ever stores things as VARCHAR(64). I might have a go at making a slightly more type-friendly version soon.

This script uses the drag-and-drop scripting techniques as explained in my book 'Baby Steps - how to become an Excel god without really trying'. If you would like to know more about how to take over the world with Excel, check out the link to the book at the bottom of my blog pages ;)

The script will produce a xxxx_n.dbf file for each spreadsheet in your workbook, were xxxx is the name of the workbook file and n is the index of the spreadsheet (1, 2 etc.). The script works by using ADODB to create a DBF table with 'Create Table' and then opening a dynamic recordset to that table (creating a table with a DBF provider creates a DBF file). Then, AddNew is called on the recordset for each non-blank row in the spreadsheet. I use array access to the spreadsheet to speed things up.

Option Explicit
Dim inputFile, path, fileName, tableName, createTable
inputFile=WScript.Arguments.Item(0)
path=Split(inputFile,"\")
fileName=path(Ubound(path))
path(Ubound(path))=""
path=Join(path,"\")
Dim dBConn
Set dBConn=OpenDBFConn(path)

' Get the name of the new table in a way will cope with .xls .xlsz etc
tableName=Split(fileName,".")
tableName(Ubound(tableName))=""
tableName=Join(tableName,".")
tableName=Left(tableName,Len(tableName)-1)

'  Open Excel and scan each spreadsheet
Dim myExcel,myWorkbook, mySheet,nColumns,column
Dim fields,row,scan,thisTableName,sheetCount
Dim createString,i

Set myExcel=CreateObject("Excel.Application")
myExcel.Visible=TRUE
Set myWorkbook=myExcel.Workbooks.Open(inputFile)

sheetCount=1
For Each mySheet In myWorkbook.Sheets
    ' Get number of fields from column headers
    scan=mySheet.Rows(1).Value
    For nColumns=1 To UBound(scan,2)
        If IsEmpty(scan(1,nColumns)) Then Exit For
    Next    
    nColumns=nColumns-1
    If nColumns >0 Then
        thisTableName=tableName & "_" & sheetCount
        createString="CREATE TABLE "
        createString=createString & thisTableName & " ("
        For i=1 to nColumns
            createString = createString & "[" & _
                           Replace(scan(1,i)," ","_") & _
                           "] VARCHAR(64) "
            If Not i=nColumns Then
                createString=createString & ", "
        Next
        createString=createString & " )"
        On Error Resume Next
        dbConn.Execute "Drop Table " & thisTableName
        On Error Goto 0
        WScript.Echo createString
        dBConn.Execute createString
        
        ' Now we have the table, let us write to it
        Dim rs,fieldPos,fieldVals
        Redim fieldPos(nColumns-1)
        Redim fieldVals(nColumns-1)
        For i=0 to nColumns-1
           fieldPos(i)=i
        Next
        Set rs=CreateObject("ADODB.Recordset")
        Const adOpenDynamic=2
        Const adLockPessimistic=2
        Const adCmdTable=2

        rs.Open thisTableName, dbConn, adOpenDynamic, _
                adLockPessimistic, adCmdTable

        For row=2 to 1048576
            scan=mySheet.Rows(row).Value
            For i=1 to nColumns
                If Not IsEmpty(scan(1,i)) Then Exit For
            Next
            ' Blank row found
            If i > nColumns Then Exit For
            For i=0 to nColumns-1
                fieldVals(i)=scan(1,i+1)
            Next
            rs.AddNew fieldPos,fieldVals
        Next

        rs.Close

    End If
    sheetCount=sheetCount+1
Next

Function OpenDBFConn(Path)
  Dim Conn
  Set Conn = CreateObject("ADODB.Connection")
  Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & Path & ";" & _
                   "Extended Properties=""DBASE IV;"";" 
  Set OpenDBFConn = Conn
End Function

• Baby Steps - How to become an Excel god without really trying
.