'///' 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 <> "" 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 fascist3_click () if Option1.value = true kilobox "CSV file does not exist!", Vbcritical, "Error" EXIT SUB END IF CSV2MDB (Text1.Text, Text2. Text) = true kilobox "Import Table Success!", Vbinformation, "Tips" end if else if Dir (text2.text) = "" The msgbox "CSV file does not exist!", Vbcritical, "error" EXIT SUB END IF IF MDB2CSV (Text2.Text, Text1.Text, "Book1") THEN MSGBOX "Export CSV Success!", Vbinformation, "Tips" 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 theen if stratsvfile = "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" " End If Wend Close FileNum If Len (strCSVFile) = 0 Then MsgBox "The CSV file is blank!", VbCritical, "Error" 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, "error" 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 already exists, is it necessary? replace? ", vbOKCancel vbQuestion," prompt ") 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 (strrcsvhead (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 FunctionPrivate 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 file is existing, is it overwritten?", VBOKCANCEL VBQUESTION, "Tips") if Ret = Vbok Then Kill CSVFileName Else EXIT FUNCTION END if end if strcn = "provike = 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 = adorse.fields (i) .name else strcsvl INE = 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 FunctionPrivate Function GetFileName (FileName As String) As StringDim strTemp As String strTemp = Mid (FileName, InStrRev (FileName, "/" ) 1) getFileName = Left (Strtemp, Len (Strtemp) - 4) End Function
