会员登录 - 用户注册 - 网站地图 Office中国(office-cn.net),专业Office论坛
当前位置:主页 > 技巧 > Access技巧 > 数据表 > 正文

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

时间:2014-11-17 12:58 来源:access911.net 作者:cg1翻译 阅读:

问题:



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

(责任编辑:admin)

顶一下
(0)
0%
踩一下
(0)
0%
发表评论
请自觉遵守互联网相关的政策法规,严禁发布色情、暴力、反动的言论。
评价: