VBA/Excel/Access/Word/Access/Table Column Field

Материал из VB Эксперт
Перейти к: навигация, поиск

Adding a Field with SQL command

   <source lang="vb">

Sub ADOAddField()

   Dim cnn As ADODB.Connection
   Dim cmd As ADODB.rumand
   MyConn = "C:\mydb.mdb"
   End If
   Set cnn = New ADODB.Connection
   With cnn
       .Provider = "Microsoft.Jet.OLEDB.4.0"
       .Open MyConn
   End With
  Set cmd = New ADODB.rumand
  Set cmd.ActiveConnection = cnn
  cmd.rumandText = "ALTER TABLE tbl1 Add Column Grp Char(25)"
  cmd.Execute , , adCmdText
  Set cmd = Nothing
  Set cnn = Nothing

End Sub

</source>
   
  


Adding a New Field to a Table

   <source lang="vb">

Sub Add_NewFields()

  Dim cat As New ADOX.Catalog
  Dim myTable As New ADOX.Table
  Set cat = New ADOX.Catalog
  cat.ActiveConnection = CurrentProject.Connection
  cat.Tables("vbexTable").Columns.Append _
      "MyNewField", adWChar, 15
  Set cat = Nothing

End Sub

</source>
   
  


Adding a New Money type Field to an Existing Table

   <source lang="vb">

Sub AddNewField()

   Dim conn As ADODB.Connection
   Dim strTable As String
   Dim strCol As String
   On Error GoTo ErrorHandler
   Set conn = CurrentProject.Connection
   strTable = "myTable"
   strCol = "newColumn"
   conn.Execute "ALTER TABLE " & strTable & " ADD COLUMN " & strCol & " MONEY;"

ExitHere:

   conn.Close
   Set conn = Nothing
   Exit Sub

ErrorHandler:

   Debug.Print Err.Number & ":" & Err.Description
   Resume ExitHere

End Sub

</source>
   
  


Append new columns to new table

   <source lang="vb">

Sub CreateTable()

   Dim cat As New ADOX.Catalog
   Dim tbl As New ADOX.Table
   
   cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
      "Data Source=C:\mydb.mdb;"
   
   " Assign table name and some columns
   With tbl
      .Name = "NewTable"
      .Columns.Append "Column1", adVarWChar, 250
      .Columns.Append "Column2", adInteger
      .Columns.Append "Column3", adInteger
   End With
   
   cat.Tables.Append tbl

End Sub

</source>
   
  


Changing the Field Data Type with SQL command

   <source lang="vb">

Sub ChangeFieldType()

   Dim conn As ADODB.Connection 
   Dim strTable As String 
   Dim strCol As String 
   On Error GoTo ErrorHandler 
   Set conn = CurrentProject.Connection 
   strTable = "myTable" 
   strCol = "ID" 
   conn.Execute "ALTER TABLE " & strTable & " ALTER COLUMN " & strCol & " CHAR(15);" 

ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   MsgBox Err.Number & ":" & Err.Description 
   Resume ExitHere 

End Sub

</source>
   
  


Changing the Size of a Field with SQL command

   <source lang="vb">

Sub ChangeFieldSize()

   Dim conn As ADODB.Connection 
   Dim strTable As String 
   Dim strCol As String 
   On Error GoTo ErrorHandler 
   Set conn = CurrentProject.Connection 
   strTable = "myTable" 
   strCol = "Name" 

conn.Execute "ALTER TABLE " & strTable & " ALTER COLUMN " & strCol & " CHAR(40);" ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   Debug.Print Err.Number & ":" & Err.Description 
   Resume ExitHere 

End Sub

</source>
   
  


Changing the Start (Seed) Value of the AutoNumber Field with SQL command

   <source lang="vb">

Sub ChangeAutoNumber()

   Dim conn As ADODB.Connection 
   Dim strDb As String 
   Dim strConnect As String 
   Dim strTable As String 
   Dim strCol As String 
   Dim intSeed As Integer 
   On Error GoTo ErrorHandler 
   strDb = CurrentProject.Path & "\" & "mydb.mdb" 
   strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & strDb 
   strTable = "myTable" 
   strCol = "Id" 
   intSeed = 1000 
   Set conn = New ADODB.Connection 
   conn.Open strConnect 
   conn.Execute "ALTER TABLE " & strTable & " ALTER COLUMN " & strCol & " COUNTER (" & intSeed & ");" 

ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   If Err.Number = -2147467259 Then 
       Debug.Print "The database file cannot be located.", _ 
           vbCritical, strDb 
       Exit Sub 
   Else 
       Debug.Print Err.Number & ":" & Err.Description 
       Resume ExitHere 
   End If 

End Sub

</source>
   
  


Checking for Existence of a Field

   <source lang="vb">

Function ColumnExists(WhichColumn, WhichTable)

   Dim cnn As ADODB.Connection
   Dim rst As ADODB.Recordset
   Dim WSOrig As Worksheet
   Dim WSTemp As Worksheet
   Dim fld As ADODB.Field
   ColumnExists = False
   MyConn = MyConn & "\mydb.mdb"
   Set cnn = New ADODB.Connection
   With cnn
       .Provider = "Microsoft.Jet.OLEDB.4.0"
       .Open MyConn
   End With
   Set rst = cnn.OpenSchema(adSchemaColumns)
   Do Until rst.EOF
       If LCase(rst!Column_Name) = LCase(WhichColumn) And _
          LCase(rst!Table_Name) = LCase(WhichTable) Then
           ColumnExists = True
           GoTo ExitMe
       End If
       rst.MoveNext
   Loop

ExitMe:

   rst.Close
   Set rst = Nothing
   cnn.Close

End Function

</source>
   
  


Delete a column

   <source lang="vb">

Sub ChangeColumn()

   Dim cat As New ADOX.Catalog
   Dim tbl As New ADOX.Table
   
   cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
      "Data Source=C:\mydb.mdb;"
   Set tbl = cat.Tables("Newtable")
   tbl.Columns("Column2").Name = "Column2X"
   tbl.Columns.Delete "Column3"

End Sub

</source>
   
  


Deleting a Field from a Table with SQL command

   <source lang="vb">

Sub DeleteField()

   Dim conn As ADODB.Connection 
   Dim strTable As String 
   Dim strCol As String 
   On Error GoTo ErrorHandler 
   Set conn = CurrentProject.Connection 
   strTable = "myTable" 
   strCol = "myCol" 
   conn.Execute "ALTER TABLE " & strTable & " DROP COLUMN " & strCol & ";" 

ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   Debug.Print Err.Number & ":" & Err.Description 
   Resume ExitHere 

End Sub

</source>
   
  


Get field properties

   <source lang="vb">

Public Sub DescribeARow()

 Const SQL As String = "SELECT * FROM Customers"
 Const ConnectionString As String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\mydb.mdb;Persist Security Info=False"
 Dim Recordset As Recordset
 Set Recordset = New Recordset
 Call Recordset.Open(SQL, ConnectionString, adOpenDynamic)
 Recordset.MoveFirst
 Dim Field As Field
 For Each Field In Recordset.Fields
   Debug.Print "Name: " & Field.Name
   Debug.Print "Type: " & Field.Type
   Debug.Print "Size: " & Field.ActualSize
   Debug.Print "Value: " & Field.Value
 Next

End Sub

</source>
   
  


Listing Field Properties

   <source lang="vb">

Sub List_FieldProperties()

  Dim cat As ADOX.Catalog
  Dim col As ADOX.Column
  Dim pr As ADOX.Property
  Set cat = New ADOX.Catalog
  Set cat.ActiveConnection = CurrentProject.Connection
  Set col = New ADOX.Column
  Set col = cat.Tables("vbexTable").Columns("Id")
  MsgBox col.Properties.Count
  For Each pr In col.Properties
     Debug.Print pr.Name & "="; pr.Value
  Next
  Set cat = Nothing

End Sub

</source>
   
  


Listing Tables and Their Fields Using the OpenSchema Method

   <source lang="vb">

Sub ListTblsAndFields()

  Dim conn As ADODB.Connection
  Dim rst As ADODB.Recordset
  Dim curTable As String
  Dim newTable As String
  Dim counter As Integer
  Set conn = New ADODB.Connection
  conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & CurrentProject.Path & "\mydb.mdb"
  Set rst = conn.OpenSchema(adSchemaColumns)
  curTable = ""
  newTable = ""
  counter = 1
  Do Until rst.EOF
     curTable = rst!table_Name
     If (curTable <> newTable) Then
        newTable = rst!table_Name
        Debug.Print "Table: " & rst!table_Name
        counter = 1
     End If
     Debug.Print "Field" & counter & ": " & rst!Column_Name
     counter = counter + 1
     rst.MoveNext
  Loop
  rst.Close
  conn.Close
  Set rst = Nothing
  Set conn = Nothing

End Sub

</source>
   
  


Open a table and read data by column

   <source lang="vb">

Sub LoopProjects()

   Dim rst As ADODB.Recordset
   Set rst = New ADODB.Recordset
   rst.Open "Employees", CurrentProject.Connection
   Do Until rst.EOF
       Debug.Print rst!Title, rst!City
       If IsNull(rst!Region) Then
           Debug.Print "No Value!!"
       End If
       rst.MoveNext
   Loop

End Sub

</source>
   
  


Read record in recordset by referening the field name with "!"

   <source lang="vb">

Public Sub Loops()

   Dim con As ADODB.Connection
   Dim rs As New ADODB.Recordset
   Set con = New ADODB.Connection
   
   con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\store.mdb;"
   
   rs.CursorLocation = adUseServer
   rs.Open "SELECT * FROM Employees", con, adOpenStatic, adLockOptimistic
   
   Do While Not rs.EOF
       Dim strName As String
       Debug.Print rs!txtCustFirstName & " " & rs!txtCustLastName
       rs.MoveNext
   Loop
   Debug.Print rs.RecordCount & " records: "
  
   Set rs = Nothing
   Set con = Nothing

End Sub

</source>
   
  


Read specific columns from Recordset

   <source lang="vb">

Sub MyFirstConnection()

   Dim myConnection As ADODB.Connection
   Dim myRecordset As ADODB.Recordset
   Dim strSQL As String
  
   strSQL = "SELECT FirstName, LastName FROM Employees"
   
   Set myConnection = CurrentProject.Connection
   
   Set myRecordset = New ADODB.Recordset
   myRecordset.Open strSQL, myConnection
   
   Do Until myRecordset.EOF
      Debug.Print myRecordset.Fields("FirstName") & " " & myRecordset.Fields("LastName")
      myRecordset.moveNext
   Loop
   myRecordset.Close
   myConnection.Close
   Set myConnection = Nothing
   Set myRecordset = Nothing

End Sub

</source>
   
  


Removing a Field from a Table

   <source lang="vb">

Sub Delete_Field()

  Dim cat As New ADOX.Catalog
  Set cat = New ADOX.Catalog
  cat.ActiveConnection = CurrentProject.Connection
  cat.Tables("vbexTable").Columns.Delete "Type"
  Set cat = Nothing

End Sub

</source>
   
  


Set column properties by using ADOX.Table

   <source lang="vb">

ADO Equivalents to Access Data Types

Microsoft Access Data Type ADO Equivalent Binary adBinary Boolean adBoolean Byte adUnsignedTinyInt Currency adCurrency Date adDate Numeric adNumeric Double adDouble Small Integer adSmallInt Integer adInteger Long Binary adLongBinary Memo adLongVarWChar Single adSingle Text adWChar

Sub makeTable()

  Dim currCat As New ADOX.Catalog
  Dim newTable As New ADOX.Table
  Dim newKey As New ADOX.Key
  
  currCat.ActiveConnection = CurrentProject.Connection
  
  With newTable
     .Name = "tblTestTable"
     .Columns.Append "custNumber", adInteger
     .Columns("custNumber").ParentCatalog = currCat
     .Columns("custNumber").Properties("AutoIncrement") = True
     
     newKey.Name = "PrimaryKey"
     newKey.Columns.Append "custNumber"
     .Keys.Append newKey, adKeyPrimary
     
     .Columns.Append "custFirstName", adWChar
     .Columns.Append "custLastName", adWChar
    End With
    
    currCat.Tables.Append newTable
    
    Set currCat = Nothing

End Sub

</source>
   
  


Setting a Default Value for a Field with SQL command

   <source lang="vb">

Sub SetDefaultFieldValue()

   Dim conn As ADODB.Connection 
   Dim strTable As String 
   Dim strCol As String 
   Dim strDefVal As String 
   Dim strSQL As String 
   On Error GoTo ErrorHandler 
   Set conn = CurrentProject.Connection 
   strTable = "myTable" 
   strCol = "City" 
   strDefVal = "Boston" 
   strSQL = "ALTER TABLE " & strTable & _ 
       " ALTER " & strCol & " SET DEFAULT " & strDefVal 
   conn.Execute strSQL 

ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   Debug.Print Err.Number & ":" & Err.Description 
   Resume ExitHere 

End Sub

</source>
   
  


Show field name, type and value data type

   <source lang="vb">

Sub rec_fields()

 Dim conn As New Connection
 Dim rec As New Recordset
 Dim f As Field
 Dim ws As Worksheet
 Dim i&
 Set ws = ThisWorkbook.Worksheets("fields")
 conn.Open "Provider=microsoft.jet.oledb.4.0;" + _
   "Data Source=" + ThisWorkbook.Path + "\nwind.mdb;"
 rec.Open "employees", conn
 For Each f In rec.Fields
   i = i + 1
   ws.[a1].Cells(i) = f.Name
   ws.[b1].Cells(i) = f.Type
   ws.[c1].Cells(i) = TypeName(f.Value)
 Next
 rec.Close: conn.Close

End Sub

</source>