设置指定词典扩展记录(VBA)

CamPtt

'
'设置指定词典扩展记录
'

2. 
   
3. Public Function SetXrecord(objDict As AcadDictionary, _
   
4.     XRecordName As String, XRecordData As Variant) As AcadXRecord
   
5. 
   
6.     Dim objXRecord As AcadXRecord
   
7.     Dim XRecordType As Variant
   
8.     Dim i As Long
   
9.      
   
10.     '检察对象词典是否有该名扩展记录,如果已经存在则删除
    
11.     On Error Resume Next
    
12.     Set objXRecord = objDict.GetObject(XRecordName)
    
13.     If objXRecord Is Nothing Then
    
14.         Err.Clear
    
15.     Else
    
16.         objDict.Remove XRecordName
    
17.     End If
    
18.     On Error GoTo 0
    
19.    
    
20.     '建立扩展记录数据
    
21.     ReDim XRecordType(0 To UBound(XRecordData)) As Integer
    
22.     For i = 0 To UBound(XRecordData)
    
23.         
    
24.         Select Case VarType(XRecordData(i))
    
25.         
    
26.             Case vbInteger, vbLong
    
27.                 XRecordType(i) = 90 '整数组码=90
    
28.             
    
29.             Case vbSingle, vbDouble
    
30.                 XRecordType(i) = 40 '实数组码=40
    
31.             
    
32.             Case vbString
    
33.                 XRecordType(i) = 2 '字符组码=2
    
34.         
    
35.         End Select
    
36.         
    
37.     Next
    
38.    
    
39.     '添加扩展记录到对象词典
    
40.     Set objXRecord = objDict.AddXRecord(XRecordName)
    
41.     objXRecord.SetXRecordData XRecordType, XRecordData
    
42.    
    
43.     '返回扩展记录对象
    
44.     Set SetXrecord = objXRecord
    
45. 
    
46. End Function
    

<br /> Public Function SetXrecord(objDict As AcadDictionary, _<br />     XRecordName As String, XRecordData As Variant) As AcadXRecord<br /> <br />     Dim objXRecord As AcadXRecord<br />     Dim XRecordType As Variant<br />     Dim i As Long<br />      <br />     '检察对象词典是否有该名扩展记录,如果已经存在则删除<br />     On Error Resume Next<br />     Set objXRecord = objDict.GetObject(XRecordName)<br />     If objXRecord Is Nothing Then<br />         Err.Clear<br />     Else<br />         objDict.Remove XRecordName<br />     End If<br />     On Error GoTo 0<br />     <br />     '建立扩展记录数据<br />     ReDim XRecordType(0 To UBound(XRecordData)) As Integer<br />     For i = 0 To UBound(XRecordData)<br />         <br />         Select Case VarType(XRecordData(i))<br />         <br />             Case vbInteger, vbLong<br />                 XRecordType(i) = 90 '整数组码=90<br />             <br />             Case vbSingle, vbDouble<br />                 XRecordType(i) = 40 '实数组码=40<br />             <br />             Case vbString<br />                 XRecordType(i) = 2 '字符组码=2<br />         <br />         End Select<br />         <br />     Next<br />     <br />     '添加扩展记录到对象词典<br />     Set objXRecord = objDict.AddXRecord(XRecordName)<br />     objXRecord.SetXRecordData XRecordType, XRecordData<br />     <br />     '返回扩展记录对象<br />     Set SetXrecord = objXRecord<br /> <br /> End Function<br />

ccchjqccc

最好vlisp