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