form1.frm

vb实现txt文件的读取

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