我对VB熟悉，但对AUTOCAD VBA还是一知半解。。。求图内查找物料程序

yiyaozjk

我在图内画了若干个房间，房间用双层矩形表示，

            每一个矩形内写一个文字（物料名称）    矩形代表一种物料大类
            每一个圆形内写一个文字（物料名称）    圆形代表另一种物料大类
            每一个自画形状写一个文字（物料名称）  自画形状代表另一种物料大类

想写一个查找程序，这个图内查找物料摆放在哪里。。。

我写了一段初始窗口的。。求助高手帮忙解答。。。

1、如何获取每个形状内的文字。。。
2、如何获取每种不同的形状，并且包括有自画的形状
3、AutoCAD VBA中是如何查找的，这几个问题解决了，我估计就可以自已解决的问题了。。。 谢谢！

poople

你就不能将那些圆、方框什么的做成属性块啊，如果是那样的话遍历起来岂不是容易多了。

yiyaozjk

可以呀，定义成块后，只要能找到就可以。。。
楼上的高手能否出手？给一点代码

poople

yiyaozjk 发表于 2014-4-28 20:43
可以呀，定义成块后，只要能找到就可以。。。
楼上的高手能否出手？给一点代码

我算不上是高手，也是初学一二，最近明经论坛的大神似乎都不在家。
下面是我写的一个供你参考，并附上你的图纸：

1. '我在你的图上创建了3种属性快，名称分别为：
   
2. '“福瓶”——方框，“花瓶”——圆，“青花缸”——圆锥
   
3. '现在以“福瓶”为例子
   
4. 
   
5. Private Sub Demo()
   
6.    
   
7.     '先创建选择集，为了可以多次创建选择集应该删掉原来存在的选择集
   
8.     Dim i As Integer
   
9.     Dim SSet As AcadSelectionSet
   
10.     For i = 0 To ThisDrawing.SelectionSets.Count - 1
    
11.         If StrComp("X_SSET", ThisDrawing.SelectionSets.Item(i).Name, vbTextCompare) = 0 Then
    
12.             ThisDrawing.SelectionSets.Item(i).Delete
    
13.             Exit For
    
14.         End If
    
15.     Next
    
16.     Set SSet = ThisDrawing.SelectionSets.Add("X_SSET")
    
17.      '定义过滤表，做到精确选取
    
18.     Dim fType(2) As Integer
    
19.     Dim fDate(2) As Variant
    
20.     fType(0) = 0: fDate(0) = "INSERT"
    
21.     fType(1) = 2: fDate(1) = "福瓶"
    
22.     fType(2) = 66: fDate(2) = 1
    
23.     '到图纸中选择
    
24.     SSet.SelectOnScreen fType, fDate
    
25.    
    
26.     '遍历内容
    
27.     Dim Ent As AcadBlockReference
    
28.     Dim AttArry As Variant
    
29.     For i = 0 To SSet.Count - 1
    
30.         Set Ent = SSet.Item(i)
    
31.         AttArry = Ent.GetAttributes
    
32.         '应为我只定义一个属性，所以AttArry下标为0即可
    
33.         ThisDrawing.Utility.Prompt vbCrLf & "第 " & i + 1 & " 个属性块的值为：" & AttArry(0).TextString
    
34.     Next
    
35.    
    
36. End Sub
    

'我在你的图上创建了3种属性快，名称分别为：<br /> '“福瓶”——方框，“花瓶”——圆，“青花缸”——圆锥<br /> '现在以“福瓶”为例子<br /> <br /> Private Sub Demo()<br />     <br />     '先创建选择集，为了可以多次创建选择集应该删掉原来存在的选择集<br />     Dim i As Integer<br />     Dim SSet As AcadSelectionSet<br />     For i = 0 To ThisDrawing.SelectionSets.Count - 1<br />         If StrComp("X_SSET", ThisDrawing.SelectionSets.Item(i).Name, vbTextCompare) = 0 Then<br />             ThisDrawing.SelectionSets.Item(i).Delete<br />             Exit For<br />         End If<br />     Next<br />     Set SSet = ThisDrawing.SelectionSets.Add("X_SSET")<br />      '定义过滤表，做到精确选取<br />     Dim fType(2) As Integer<br />     Dim fDate(2) As Variant<br />     fType(0) = 0: fDate(0) = "INSERT"<br />     fType(1) = 2: fDate(1) = "福瓶"<br />     fType(2) = 66: fDate(2) = 1<br />     '到图纸中选择<br />     SSet.SelectOnScreen fType, fDate<br />     <br />     '遍历内容<br />     Dim Ent As AcadBlockReference<br />     Dim AttArry As Variant<br />     For i = 0 To SSet.Count - 1<br />         Set Ent = SSet.Item(i)<br />         AttArry = Ent.GetAttributes<br />         '应为我只定义一个属性，所以AttArry下标为0即可<br />         ThisDrawing.Utility.Prompt vbCrLf & "第 " & i + 1 & " 个属性块的值为：" & AttArry(0).TextString<br />     Next<br />     <br /> End Sub<br />

elepeipei

谢谢楼主分享，学习了