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

问题：

如何设置表的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

发布人:cg1翻译-access911.net

分享到：

点击次数：更新时间：2009-04-01 14:32:19 【打印此页】【关闭】

上一条：如何设定表的某字段默认值？下一条：外部驱动程序（8961）中的意外错误