[VBA函数]：cad 中实体通过句柄连到数据库中的属性

savasava

我想做个查询系统用一个符号表示阀门（block） 从数据库通过坐标 把阀门展到cad中了，并把每个实体的handle传回数据库中， 但我在实现从cad到数据库的时候 做得不理想 ，我想做到 图和数据库的互动 用鼠标随便在Cad中点某个阀门就通过handle看到其在数据库中的属性。
我用的是GetEntity不太方便做不到互动效果。
在下谢了

efan2000

首先用GetEntity获取实体，然后判断实体（块）的名称如果是阀门的话，那么就根据它的句柄从数据库中查询它的信息，弹出一个窗体，在上面显示查询到的信息。也可以借助于时间控件，延迟一定时间后自动关闭窗体。

liubz

使用句柄请注意，句柄本身不稳定，当一个文件插入到另外一个文件中时，这个文件中的句柄将发生变化。我个人认为通过使用附加扩展信息比较可靠，只是检索起来比较麻烦。

savasava

斑竹
这种想法好象没什么新意，我看了一个高手做的东东，只要在用右键cad 中随编 点击 一条线 ，一个点，一个块......（鼠标的形状还是默认的形状，并没有变成用getEntity时的拾取框）就可以把图形的句柄传到数据库中，从而读出属性。我想他可能是用了鼠标右键单击的事件。
咳 技不如人，被人牵着鼻子走，人家要多少钱就的给人多少，遭老罪了。他日 ，我若实现此功能,定公开代码。
大家多交流。为不被人牵着鼻子走,而努力学习cad

lijiao

最初由 savasava 发布
[B]斑竹
这种想法好象没什么新意，我看了一个高手做的东东，只要在用右键cad 中随编 点击 一条线 ，一个点，一个块......（鼠标的形状还是默认的形状，并没有变成用getEntity时的拾取框）就可以把图形的句柄传到数据... [/B]

说得好！
但有一点，我觉得，我们缺少的不是技术，而是新奇的想法。

Laoyao

你希望的是否是这个效果
ＳＴＡＲＴＣ运行，ＥＮＤＣ停止

2. 
   
3.   [FONT=courier new]
   
4. Dim myC As Class1
   
5. 
   
6. Sub startC()
   
7.     Set myC = New Class1
   
8. End Sub
   
9. 
   
10. Sub endC()
    
11.     Set myC = Nothing
    
12.    
    
13. End Sub
    
14. 
    
15.   [/FONT]
    

<br />   [FONT=courier new]<br /> Dim myC As Class1<br /> <br /> Sub startC()<br />     Set myC = New Class1<br /> End Sub<br /> <br /> Sub endC()<br />     Set myC = Nothing<br />     <br /> End Sub<br /> <br />   [/FONT]<br />

新建一个CLASS　ＭＯＤＵＬＥ，在类模块中加入以下程序

2. 
   
3.   [FONT=courier new]
   
4. Public WithEvents Doc As AcadDocument
   
5. 
   
6. 
   
7. 
   
8. 
   
9. Private Sub Class_Initialize()
   
10.     Set Doc = Application.ActiveDocument
    
11. End Sub
    
12. 
    
13. Private Sub Doc_BeginDoubleClick(ByVal PickPoint As Variant)
    
14. End Sub
    
15. 
    
16. 
    
17. Private Sub Doc_BeginRightClick(ByVal PickPoint As Variant)
    
18.     On Error Resume Next
    
19.     Dim SSs As AcadSelectionSets
    
20.     Set SSs = Doc.SelectionSets
    
21.    
    
22.     Dim TempS As AcadSelectionSet
    
23.     If IsNull(Doc.SelectionSets("asdf_aos")) Then
    
24.         Set TempS = SSs.Add("asdf_aos")
    
25.     Else
    
26.         Set TempS = SSs("asdf_aos")
    
27.         TempS.Clear
    
28.     End If
    
29.    
    
30.     TempS.SelectAtPoint PickPoint
    
31.    
    
32.    
    
33.     '.GetEntity returnObj, PickPoint
    
34.     If TempS.Count <> 0 Then
    
35.         MsgBox "The object type is: " & TempS.Item(0).ObjectName', , "GetEntity Example"
    
36.     End If
    
37.     TempS.Delete
    
38. End Sub
    
39. 
    
40.   [/FONT]
    

<br />   [FONT=courier new]<br /> Public WithEvents Doc As AcadDocument<br /> <br /> <br /> <br /> <br /> Private Sub Class_Initialize()<br />     Set Doc = Application.ActiveDocument<br /> End Sub<br /> <br /> Private Sub Doc_BeginDoubleClick(ByVal PickPoint As Variant)<br /> End Sub<br /> <br /> <br /> Private Sub Doc_BeginRightClick(ByVal PickPoint As Variant)<br />     On Error Resume Next<br />     Dim SSs As AcadSelectionSets<br />     Set SSs = Doc.SelectionSets<br />     <br />     Dim TempS As AcadSelectionSet<br />     If IsNull(Doc.SelectionSets("asdf_aos")) Then<br />         Set TempS = SSs.Add("asdf_aos")<br />     Else<br />         Set TempS = SSs("asdf_aos")<br />         TempS.Clear<br />     End If<br />     <br />     TempS.SelectAtPoint PickPoint<br />     <br />     <br />     '.GetEntity returnObj, PickPoint<br />     If TempS.Count <> 0 Then<br />         MsgBox "The object type is: " & TempS.Item(0).ObjectName', , "GetEntity Example"<br />     End If<br />     TempS.Delete<br /> End Sub<br /> <br />   [/FONT]<br />

savasava

多谢Laoyao 兄