Dim Tbf As DAO.TableDef
Dim fld As DAO.Field
Dim p As DAO.Property
Dim cp As DAO.Property
On Error Resume Next
Dim i As Integer
Dim TableName As String
Dim FieldName As String
FieldName = "First_name"
TableName = "test"
For Each Tbf In CurrentDb.TableDefs
'Debug.Print Tbf.Name
For Each fld In Tbf.Fields
'Debug.Print Fld.Name
If fld.Name = FieldName And Tbf.Name = TableName Then
Set cp = fld.CreateProperty("Caption", 12, "aa")
fld.Properties.Append cp
Set cp = fld.CreateProperty("Description", 10, "aa")
fld.Properties.Append cp
End If
For Each p In fld.Properties
If p.Name = "caption" Then
Debug.Print Tbf.Name & ":" & fld.Name & ":" & "pro:"; p.Name & "--" & p.Value
'Fld.Properties.Delete "Caption" '删除属性
End If
Next
Next
Next
End Function
下面再给一段函数
Function GetFieldProperty(F As Field, _
ByVal PropName As String) As Variant
'
' Returns NULL if the property doesn't exist
'
On Error Resume Next
GetFieldProperty = F.Properties(PropName)
End Function
Sub ModifyFieldProperty(F As Field, ByVal PropName As String, _
ByVal PropType As Long, _
ByVal NewVal As Variant)
Dim P As Property
On Error Resume Next
Set P = F.Properties(PropName)
If Err Then
'
' Add property (as long as NewVal isn't Null)
'
If Not IsNull(NewVal) Then
On Error Goto 0 ' fail if can't add
Set P = F.CreateProperty(PropName, PropType, NewDesc)
F.Properties.Append P
End If
ElseIf IsNull(NewVal) Then
'
' Delete property
'
On Error Goto 0 ' fail if can't delete
F.Properties.Delete PropName
Else
'
' Modify property
'
On Error Goto 0 ' fail if can't alter
P.Value = NewDesc
End If
Set P = Nothing
End Sub
调用函数如下：
Sub Test()
Dim db As Database, F As Field
Dim v As Variant
v = "This is a description"
Set db = DBEngine(0).OpenDatabase("NWIND.MDB") ' change name/path
Set F = db!Employees!Title
' Get existing description
Debug.Print "Existing Title Description is: ";
Debug.Print GetFieldProperty(F, "Description")
' Delete description
ModifyFieldProperty F, "Description", dbText, v
Debug.Print "After deleting Description: ";
Debug.Print GetFieldProperty(F, "Description")
' Add description
ModifyFieldProperty F, "Description", dbText, "Employee's Title"
Debug.Print "After adding new Description: ";
Debug.Print GetFieldProperty(F, "Description")
' Modify existing title
ModifyFieldProperty F, "Description", dbText, "Emp Title"
Debug.Print "After modifying Description: ";
Debug.Print GetFieldProperty(F, "Description")
' Clean-up
Set F = Nothing
db.Close
End Sub
再提供一个别人发表的代码（未测试）
'*******************************************************************************
'Function: TableDefExist(strTableDef)
'Description: Returns a Boolean value that indicates whether an table define
' in currently database.
'Example: TableDefExist("TEXT")=True
'*******************************************************************************
Function TableDefExist(ByVal strTableDef As String) As Boolean
On Error GoTo TableDefExist_Err
If CurrentDb.TableDefs(strTableDef).Name = strTableDef Then
TableDefExist = True
End If
TableDefExist = True
Exit Function
TableDefExist_Err:
TableDefExist = False
Exit Function
End Function
Private Sub CreateTRDTableDef()
On Error GoTo Err_CreateTRDTableDef
Dim rstTRDTableSource As DAO.Recordset
Dim rstTableDefine As DAO.Recordset
Dim tdfTable As DAO.TableDef
Dim dbCurrentDatabase As DAO.Database
Dim fldField As Field
Dim intCount As Integer
Dim strTableName As String
DoCmd.Echo True, "Creating table definition......"
Set dbCurrentDatabase = CurrentDb
Set rstTRDTableSource = dbCurrentDatabase.OpenRecordset("SELECT DISTINCT TRD_NAME,TABLE_NAME FROM TBL_TABLE_SOURCE", dbOpenDynaset)
Do While Not rstTRDTableSource.EOF
strTableName = rstTRDTableSource("TRD_NAME") & " - " & rstTRDTableSource("TABLE_NAME")
DoCmd.Echo True, "Creating " & strTableName & " table definition....."
If TableDefExist(strTableName) Then
dbCurrentDatabase.TableDefs.Delete strTableName
End If
Set rstTableDefine = CurrentDb.OpenRecordset("SELECT * FROM TBL_TABLE_SOURCE WHERE TRD_NAME=" & "'" & _
rstTRDTableSource("TRD_NAME") & "' AND TABLE_NAME='" & rstTRDTableSource("TABLE_NAME") & "' ORDER BY SEQUENCE", dbOpenDynaset)
Set tdfTable = dbCurrentDatabase.CreateTableDef(strTableName)
Set fldField = tdfTable.CreateField(rstTableDefine.Fields("FIELD_NAME"), GedFieldType(rstTableDefine.Fields("DATA_TYPE")), rstTableDefine.Fields("FIELD_SIZE"))
With rstTableDefine
Do While Not .EOF
Set fldField = tdfTable.CreateField(.Fields("FIELD_NAME"), GedFieldType(.Fields("DATA_TYPE")), .Fields("FIELD_SIZE"))
'*******************************************************************************
'Function: GedFieldType(strDataType)
'Description: Returns a integer value that indicates data types
'Example: GedFieldType("dbText")=10
'*******************************************************************************
Function GedFieldType(strDataType As String) As Integer
Select Case strDataType
Case "dbText"
GedFieldType = 10
Case "dbDate"
GedFieldType = 8
Case "dbDouble"
GedFieldType = 7
Case "dbFloat"
GedFieldType = 21
Case "dbInteger"
GedFieldType = 3
Case "dbLong"
GedFieldType = 4
Case "dbMemo"
GedFieldType = 12
Case "dbNumeric"
GedFieldType = 6 'old is 19
Case "dbSingle"
GedFieldType = 6
Case "dbTime"
GedFieldType = 22
Case "dbChar"
GedFieldType = 18
Case "dbCurrency"
GedFieldType = 5
Case Else
GedFieldType = 0
End Select
End Function
'*******************************************************************************
'Sub: SetMyProperty(Obj,Name,Type,Setting)
'Description: Custom a user property
'Example: SetMyProperty fldField, "Caption", dbText, "Test Information"
'*******************************************************************************
Sub SetMyProperty(Obj As Object, strName As String, intType As Integer, strSetting As String)
Dim Prp As Property
Const PrpFail As Integer = 3270
On Error GoTo Err_SetMyProperty
