VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   6960
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   9060
   LinkTopic       =   "Form1"
   ScaleHeight     =   6960
   ScaleWidth      =   9060
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdOK 
      Caption         =   "開始轉換"
      Height          =   615
      Left            =   6840
      TabIndex        =   8
      Top             =   3960
      Width           =   1815
   End
   Begin VB.TextBox txtChar 
      Height          =   615
      Left            =   2880
      TabIndex        =   7
      Top             =   4680
      Width           =   2895
   End
   Begin VB.TextBox txtTable 
      Height          =   615
      Left            =   2880
      TabIndex        =   5
      Top             =   3480
      Width           =   2895
   End
   Begin VB.TextBox Text2 
      Height          =   495
      Left            =   3000
      TabIndex        =   3
      Top             =   2160
      Width           =   2775
   End
   Begin VB.TextBox txtSource 
      Height          =   495
      Left            =   2880
      TabIndex        =   1
      Top             =   840
      Width           =   2775
   End
   Begin VB.Label Label4 
      Caption         =   "分隔符："
      Height          =   495
      Left            =   960
      TabIndex        =   6
      Top             =   4800
      Width           =   1575
   End
   Begin VB.Label Label3 
      Caption         =   "表名："
      Height          =   495
      Left            =   1080
      TabIndex        =   4
      Top             =   3600
      Width           =   1335
   End
   Begin VB.Label Label2 
      Caption         =   "Access數據庫："
      Height          =   615
      Left            =   1080
      TabIndex        =   2
      Top             =   2040
      Width           =   1335
   End
   Begin VB.Label Label1 
      Caption         =   "Txt文件名："
      Height          =   495
      Left            =   1080
      TabIndex        =   0
      Top             =   840
      Width           =   1215
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'編程實現Txt文件轉化為Access數據庫實例
Option Explicit
Dim Cat As New ADOX.Catalog
Dim Col As Column
Dim Tbl As Table
Dim lFieldLength() As Long
Dim strFieldName() As String
Dim strFieldValue() As String
Dim FieldCount As Long
Public Function CreateDatabase()
'建立一個空的目標數據庫
On Error GoTo PROC_ERR
    '在指定目標建立數據庫
    Cat.Create "Provider=Microsoft.jet.oledb.4.0; Data Source = test1"
    
    CreateDatabase = True
Exit Function
PROC_ERR:
    CreateDatabase = False
    If Err.Number = -2147217897 Then
        MsgBox "數據庫已經存在"
        Exit Function
    Else
        MsgBox Err.Number & vbNewLine & Err.Description
    End If

End Function
Private Function CreateTables()
    '建立表，并根據txt文件內容建立表結構
    Dim i As Long
    Set Tbl = New ADOX.Table
    With Tbl
        '表名為指定
        .Name = 試驗表1
        Set .ParentCatalog = Cat
        With .Columns
            '向表中添加字段
            For i = 0 To FieldCount - 1
                .Append strFieldName(i), adVarWChar, lFieldLength(i)
                .Item(strFieldName(i)).Properties("Description").Value = strFieldName(i)
            Next i
        End With
    End With
    '向數據庫中添加表
    Cat.Tables.Append Tbl
    Set Tbl = Nothing
End Function
Private Sub GetFieldInfo()
    '從Txt文件中獲取目標Access數據庫格式
    Dim Readline As String
    Dim lSeek As Long
    
    Open "D:\work\新建文件夾\人民幣.txt" For Input As #1
    If EOF(1) Then Exit Sub
    
    Line Input #1, Readline
    '獲取字段數量
    FieldCount = 3
    '獲取字段名
    strFieldName(0) = Mid$(Readline, 4, 16)
    strFieldName(1) = Mid$(Readline, 27, 6)
    strFieldName(2) = Mid$(Readline, 48, 4)
    Close #1
    
    Call GetFieldLength

    
End Sub
Private Sub GetFieldLength()
    '遍歷Txt文件，獲取字段的最大長度
    Dim Readline As String
    Dim i As Long
    Open "D:\work\新建文件夾\人民幣" For Input As #1
    If EOF(1) Then Exit Sub
    '跳過表頭
    Line Input #1, Readline
    
    Do Until EOF(1)
        Line Input #1, Readline
        '獲取Txt文件中每個字段的值
        strFieldValue(0) = Mid$(Readline, 4, 16)
        strFieldValue(1) = Mid$(Readline, 27, 6)
        strFieldValue(2) = Mid$(Readline, 48, 4)
         For i = 0 To FieldCount - 1
            If lFieldLength(i) < Len(strFieldValue) Then
                lFieldLength(i) = Len(strFieldValue)
            End If
        Next i
    Loop
    
    Close #1
End Sub
Private Sub Export2Database()

    '建立一個ADO數據連接
    Dim DataConn As New ADODB.Connection
    Dim DataRec As New ADODB.Recordset
    Dim Readline As String
    Dim i As Long
    
    Dim strSQL As String
    Set Cat = Nothing
    
'若數據庫連接出錯，則轉向ConnectionERR
On Error GoTo ConnectionERR
    
    '建立一個連接字串
    DataConn.ConnectionString = "Provider=Microsoft.jet.oledb.4.0; Data Source = test1"
    '建立數據庫連接
    DataConn.Open
    
'若RecordSet建立出錯，則轉向RecordsetERR
On Error GoTo RecordSetERR
    
    strSQL = "SELECT * FROM " & 試驗表1
On Error GoTo ExportErr
    Open test1 For Input As #1
    If EOF(1) Then Exit Sub
    
    Line Input #1, Readline
    
    Do Until EOF(1)
        
        Line Input #1, Readline
        strFieldValue(0) = Mid$(Readlinne, 4, 16)
        strFieldValue(1) = Mid$(Readline, 27, 6)
        strFieldValue(2) = Mid$(Readline, 48, 4)
        '向Access數據庫添加數據
        DataRec.AddNew
        For i = 0 To FieldCount - 1
            DataRec.Fields(i).Value = strFieldValue(i)
        Next i
        DataRec.Update
        
    Loop
    DataRec.UpdateBatch
        
    Close #1
    DataRec.Close
    Set DataRec = Nothing
    Exit Sub

ConnectionERR:
    '錯誤處理程序
    MsgBox "數據庫連接錯誤，" & Err.Description, vbCritical, "出錯"
    Exit Sub
    
RecordSetERR:
    MsgBox "RecordSet生成錯誤，" & Err.Description, vbCritical, "出錯"
    DataConn.Close
    Exit Sub
    
DocERR:
    MsgBox "導入Access數據庫錯誤，" & Err.Description, vbCritical, "出錯"
    DataRec.Close
    DataConn.Close
End Sub
Private Sub cmdOK_Click()
    
    Call GetFieldInfo
    If CreateDatabase Then
        Call CreateTables
        Call Export2Database
    End If
    MsgBox "導出成功。", vbInformation, "完成"
End Sub