CSV MDB转换程序的详细内容

'///////////////////////////////////////////////////////
'CSV < - >MDB Convert Tool
'Written By griefforyou
'///////////////////////////////////////////////////////
Option Explicit

Private Sub Command1_Click()
On Error GoTo ErrHandler
CommonDialog1.FileName = ""
CommonDialog1.CancelError = True
CommonDialog1.Filter = "CSV File(*.csv;*.txt)|*.csv;*.txt"
CommonDialog1.ShowOpen
If CommonDialog1.FileName <> "" Then
Text1.Text = CommonDialog1.FileName
End If
Exit Sub

ErrHandler:
MsgBox "Error:" & Err.Description, vbCritical, "Error"
End Sub

Private Sub Command2_Click()
On Error GoTo ErrHandler
CommonDialog1.FileName = ""
CommonDialog1.CancelError = True
CommonDialog1.Filter = "Access File(*.mdb)|*.mdb"
CommonDialog1.ShowOpen
If CommonDialog1.FileName <> "" Then
Text2.Text = CommonDialog1.FileName
End If
Exit Sub

ErrHandler:
MsgBox "Error:" & Err.Description, vbCritical, "Error"
End Sub

Private Sub Command3_Click()
If Option1.Value = True Then
If Dir(Text1.Text) = "" Then
MsgBox "CSV文件不存在！", vbCritical, "错误"
Exit Sub
End If

If CSV2MDB(Text1.Text, Text2.Text) = True Then
MsgBox "导入表成功！", vbInformation, "提示"
End If
Else
If Dir(Text2.Text) = "" Then
MsgBox "CSV文件不存在！", vbCritical, "错误"
Exit Sub
End If

If MDB2CSV(Text2.Text, Text1.Text, "Book1") Then
MsgBox "导出CSV成功！", vbInformation, "提示"
End If
End If
End Sub

Private Function CSV2MDB(CSVFileName As String, MDBFileName As String, Optional TableName As String = "") As Boolean
On Error GoTo ErrHandler
Dim strTemp As String
Dim strCSVFile As String, strCSVLineSplit As String
Dim iCSVLineCount As Integer, iCSVFieldCount As Integer
Dim strArrCSVLine() As String, strArrCSVHead() As String, strArrCSVData() As String

Dim i As Integer, j As Integer, Ret As Long

Dim ADOXCat As ADOX.Catalog, ADOXTable As ADOX.Table
Dim ADOConn As ADODB.Connection, ADORs As ADODB.Recordset
Dim strCn As String

Dim FileNum As Integer

CSV2MDB = False

FileNum = FreeFile

Open CSVFileName For Input As FileNum
While Not EOF(FileNum)
strTemp = ""
Line Input #FileNum, strTemp
If Trim(strTemp) <> "" And Trim(strTemp) <> vbCrLf Then
If strCSVFile = "" Then
strCSVFile = strTemp
Else
strCSVFile = strCSVFile & vbCrLf & strTemp
End If
End If
Wend
Close FileNum

If Len(strCSVFile) = 0 Then
MsgBox "The CSV file is blank!", vbCritical, "错误"
Exit Function
End If

If InStr(strCSVFile, vbCrLf) > 0 Then
strCSVLineSplit = vbCrLf
ElseIf InStr(strCSVFile, vbLf) > 0 Then
strCSVLineSplit = vbLf
Else
MsgBox "Error CSV file!", vbCritical, "错误"
Exit Function
End If

strArrCSVLine = Split(strCSVFile, strCSVLineSplit)
iCSVLineCount = UBound(strArrCSVLine)

strArrCSVHead = Split(strArrCSVLine(0), ",")
iCSVFieldCount = UBound(strArrCSVHead)

strCn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & MDBFileName

Set ADOXCat = New ADOX.Catalog
If Dir(MDBFileName) = "" Then
ADOXCat.Create strCn
End If

If TableName = "" Then
TableName = GetFileName(CSVFileName)
End If

ADOXCat.ActiveConnection = strCn
For i = 0 To ADOXCat.Tables.Count - 1
If ADOXCat.Tables(i).Name = TableName Then
Ret = MsgBox("表名已经存在，是否要替换？", vbOKCancel + vbQuestion, "提示")
If Ret = vbOK Then
ADOXCat.Tables.Delete TableName
Exit For
Else
Set ADOXCat = Nothing
Exit Function
End If
End If
Next

Set ADOXTable = New ADOX.Table
ADOXTable.ParentCatalog = ADOXCat
ADOXTable.Name = TableName
For i = 0 To iCSVFieldCount
ADOXTable.Columns.Append strArrCSVHead(i), adVarWChar, 250
ADOXTable.Columns(strArrCSVHead(i)).Properties("NullAble") = True
Next

ADOXCat.Tables.Append ADOXTable

Set ADOConn = New ADODB.Connection
Set ADORs = New ADODB.Recordset
ADOConn.ConnectionString = strCn
ADOConn.Open
ADORs.CursorLocation = adUseClient
ADORs.Open TableName, ADOConn, adOpenKeyset, adLockPessimistic

ReDim strArrCSVData(iCSVLineCount) As String
For i = 1 To UBound(strArrCSVData)
strArrCSVData = Split(strArrCSVLine(i), ",")
ADORs.AddNew
For j = 0 To iCSVFieldCount
ADORs.Fields(j) = strArrCSVData(j)
Next
ADORs.Update
Next

ADORs.Close
Set ADORs = Nothing
ADOConn.Close
Set ADOConn = Nothing

CSV2MDB = True
Exit Function
ErrHandler:
MsgBox "Error:" & Err.Description, vbCritical, "Error"
End Function

Private Function MDB2CSV(MDBFileName As String, CSVFileName As String, TableName As String) As Boolean
On Error GoTo ErrHandler

Dim ADOConn As New ADODB.Connection
Dim ADORs As New ADODB.Recordset
Dim Ret As Long
Dim strCn As String, strCSVLine As String
Dim i As Integer, j As Integer
Dim FileNum As Integer

MDB2CSV = False
If Dir(CSVFileName) <> "" Then
Ret = MsgBox("CSV文件己存在，是否覆盖？", vbOKCancel + vbQuestion, "提示")
If Ret = vbOK Then
Kill CSVFileName
Else
Exit Function
End If
End If

strCn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & MDBFileName
ADOConn.ConnectionString = strCn
ADOConn.Open
ADORs.Open TableName, ADOConn, adOpenKeyset, adLockOptimistic

If ADORs.EOF Then
ADORs.Close
Set ADORs = Nothing
ADOConn.Close
Set ADOConn = Nothing
Exit Function
End If
FileNum = FreeFile

Open CSVFileName For Output As FileNum
For i = 0 To ADORs.Fields.Count - 1
If strCSVLine = "" Then
strCSVLine = ADORs.Fields(i).Name
Else
strCSVLine = strCSVLine & "," & ADORs.Fields(i).Name
End If
Next
Print #FileNum, strCSVLine

While Not ADORs.EOF
strCSVLine = ""
For i = 0 To ADORs.Fields.Count - 1
If strCSVLine = "" Then
strCSVLine = ADORs.Fields(i)
Else
strCSVLine = strCSVLine & "," & ADORs.Fields(i)
End If
Next
Print #FileNum, strCSVLine
ADORs.MoveNext
Wend
Close FileNum

ADORs.Close
Set ADORs = Nothing
ADOConn.Close
Set ADOConn = Nothing

MDB2CSV = True
Exit Function

ErrHandler:
MsgBox "Error:" & Err.Description, vbCritical, "Error"
End Function

Private Function GetFileName(FileName As String) As String
Dim strTemp As String
strTemp = Mid(FileName, InStrRev(FileName, "/") + 1)
GetFileName = Left(strTemp, Len(strTemp) - 4)
End Function