form1.frm

对已经存在的Accsess数据库表添加新字段并复值

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox txtType 
      Height          =   375
      Left            =   2400
      TabIndex        =   2
      Text            =   "type"
      Top             =   480
      Width           =   1455
   End
   Begin VB.TextBox txtName 
      Height          =   375
      Left            =   240
      TabIndex        =   1
      Text            =   "name"
      Top             =   480
      Width           =   1335
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   735
      Left            =   1320
      TabIndex        =   0
      Top             =   2160
      Width           =   1575
   End
   Begin VB.Label Label2 
      Caption         =   "Label2"
      Height          =   255
      Left            =   2400
      TabIndex        =   4
      Top             =   120
      Width           =   615
   End
   Begin VB.Label Label1 
      Caption         =   "Label1"
      Height          =   255
      Left            =   240
      TabIndex        =   3
      Top             =   120
      Width           =   855
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private connDB As New ADODB.Connection

Private Sub Form_Load()
   connDB.Open "Dsn=JYDB"
End Sub



Private Sub Command1_Click()
    Dim data(), Field() As String, fieldtype() As Integer
    Dim i As Integer, j As Integer

    Dim recDataIn As New ADODB.Recordset
    Dim intRecNums As Integer, intFieldNums As Integer

    recDataIn.Open "Select * From table1 ", connDB, adOpenStatic, adLockOptimistic
    intRecNums = recDataIn.RecordCount
    intFieldNums = recDataIn.Fields.Count

    ReDim data(intRecNums, intFieldNums), Field(intFieldNums) As String, fieldtype(intFieldNums) As Integer
    Dim strQYJC As String, fldname As String

    For i = 0 To intFieldNums - 1
        Field(i) = recDataIn.Fields(i).Name
        fieldtype(i) = recDataIn.Fields(i).Type
    Next

    For j = 0 To intFieldNums - 1
        For i = 1 To intRecNums
            data(i, j) = recDataIn.Fields(j).Value
            recDataIn.MoveNext
        Next
        recDataIn.MoveFirst
    Next
    recDataIn.Close


    If txtName <> "" And txtType <> "" Then
        Field(intFieldNums) = txtName.Text
        fieldtype(intFieldNums) = Val(txtType.Text)
        CreateTable Field, fieldtype
        WriteValue data
    End If

    MsgBox "complete!"

End Sub

Private Sub CreateTable(Field() As String, fieldtype() As Integer)
    Dim i As Integer
    Dim myTable As TableDef, myField As Field
    Dim myDatabase As Database

    Set myDatabase = OpenDatabase("F:\SetAccessData\JY.mdb")


    Set myTable = myDatabase.TableDefs("subclass")

    For i = 0 To 0
        Set myField = Table.CreateField(Field(i), fieldtype(i))
        Set myField = myTable.CreateField("name1", dbText, 50)

        myTable.Fields.Append myField
    Next i
End Sub


Private Sub WriteValue(data())
    Dim i, j As Integer, FieldCount As Integer
    Dim recDataOut As New ADODB.Recordset

    recDataOut.Open "Select * From 现状评价 ", connDB, adOpenStatic, adLockOptimistic
    FieldCount = recDataOut.Fields.Count

    For i = 1 To UBound(data, 1)

        recDataOut.AddNew

        For j = 0 To FieldCount_1
            recDataOut.Fields(j).Value = data(i, j)

        Next j

        recDataOut.Update
        recDataOut.MoveNext

    Next i

    recDataOut.Close

End Sub