'///////////////////////////////////////////////////////
'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