如何设置表的Caption和Description属性，即“标题”和“说明”属-Access交流网触屏版

表设计

如何设置表的Caption和Description属性，即“标题”和“说明”属

2009-04-01 14:32:19

问题：

如何设置表的Caption和Description属性，即“标题”和“说明”属性

回答：

注意！无法通过 JET SQL 来设置或者修改上述属性，JET SQL 不支持此功能，你可以联系微软开发小组要他们在下一个版本中增加此功能。

Function AppendCaption()     '引用DAO          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"))                  tdfTable.Fields.Append fldField         dbCurrentDatabase.TableDefs.Append tdfTable                  SetMyProperty fldField, "Caption", dbText, rstTableDefine.Fields("Caption")         SetMyProperty fldField, "Description", dbText, rstTableDefine.Fields("DESCRIPTION")         rstTableDefine.MoveNext                  With rstTableDefine             Do While Not .EOF                 Set fldField = tdfTable.CreateField(.Fields("FIELD_NAME"), GedFieldType(.Fields("DATA_TYPE")), .Fields("FIELD_SIZE"))                                  tdfTable.Fields.Append fldField                 SetMyProperty fldField, "Caption", dbText, rstTableDefine.Fields("Caption")                 SetMyProperty fldField, "Description", dbText, rstTableDefine.Fields("DESCRIPTION")                                  .MoveNext             Loop         End With                  Set tdfTable = Nothing         rstTableDefine.Close         Set rstTableDefine = Nothing         rstTRDTableSource.MoveNext     Loop          rstTRDTableSource.Close     Set rstTRDTableSource = Nothing          DoCmd.Echo True, "Ready"           Exit_CreateTRDTableDef:     Exit Sub      Err_CreateTRDTableDef:     MsgBox "Error: " & Err & vbCrLf & Err.Description     Resume Exit_CreateTRDTableDef      End Sub

'******************************************************************************* '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          Obj.Properties(strName) = strSetting     Obj.Properties.Refresh

Exit_SetMyProperty:     Exit Sub

Err_SetMyProperty:

    If Err = PrpFail Then       Set Prp = Obj.CreateProperty(strName, intType, strSetting)       Obj.Properties.Append Prp       Obj.Properties.Refresh     Else       MsgBox "Error: " & Err & vbCrLf & Err.Description     End If          Resume Exit_SetMyProperty

End Sub