'///'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 IfEnd Sub
Private Function CSV2MDB(CSVFileName As String, MDBFileName As String, Optional TableName As String = "") As BooleanOn 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 FunctionErrHandler: MsgBox "Error:" & Err.Description, vbCritical, "Error"End Function
Private Function MDB2CSV(MDBFileName As String, CSVFileName As String, TableName As String) As BooleanOn 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 StringDim strTemp As String strTemp = Mid(FileName, InStrRev(FileName, "/") + 1) GetFileName = Left(strTemp, Len(strTemp) - 4)End Function
