利用VBA动态新建SQLSERVER表字段

Private Sub CmdRfhRts_Click()
   Dim i As Integer, HasIt As Boolean
  
   Dim rs1 As ADODB.Recordset
  
   Set rs1 = New ADODB.Recordset
  
   rs1.Open "Select * from System_MdlsRts Where MdlName='" & Me.CboDept & "'", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
   If rs1.RecordCount = 0 Then Exit Sub
  
   SysCmd acSysCmdInitMeter, "Refreshing modles rights...", rs1.RecordCount
  
    ' Search for open AccessObject objects in AllTables collection.
   rs1.MoveFirst
        Dim tbl As ADOX.Table, fid As ADOX.column, fidn As New ADOX.column
        Dim cat As New ADOX.Catalog, cn As New ADODB.Connection
        Dim tes As String
        cn.ConnectionString = "Provider=SQLOLEDB.1;Password=mysql;Persist Security Info=True;User ID=sa;Initial Catalog=TaiShanERP;Data Source=MIS-JAMESCHS"
        cn.Open
        Set cat.ActiveConnection = cn
        Set tbl = cat.Tables(CboDept & "_Users")
        '.ParentCatalog = cat
       
   While Not rs1.EOF
     With tbl
          HasIt = False
          tes = rs1("RtsName")
          For Each fid In .Columns
            If fid.Name = tes Then  'have the field
              HasIt = True
              Exit For
            End If
          Next
          If Not HasIt Then  '如果没有这个字段就增加一个
            fidn.Name = tes
            fidn.Type = adBoolean
            fidn.Attributes = adColNullable
            .Columns.Append fidn
            .Columns.Refresh
            Set fidn = Nothing
             'cat.Tables.Append tbl
          End If
     End With
     SysCmd acSysCmdUpdateMeter, rs1.AbsolutePosition
     rs1.MoveNext
   Wend
   SysCmd acSysCmdClearStatus
   Set tbl = Nothing
   Set cat.ActiveConnection = Nothing
   Set cat = Nothing
   Set cn = Nothing
   rs1.Close
   Set rs1 = Nothing
  
End Sub