Write DBF File From Excel 2007 With VBScript

Write DBF File From Excel 2007 With VBScript

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

[Via]