如何在vba中实现象autocad界面上的点选生成阴影呢

gongxiaosan

各位，我有一个问题请教，如和在vba中实现如同AutoCAD界面中的那样点选一个区域从而在该区域生成阴影，譬如一个圆，过圆心有两条相互垂直的线，现在我希望在1，3象限生成阴影，该如何呢

topirol

这个行不行？

2. Sub test()
   
3. Dim entry As AcadEntity
   
4. Dim pickedp As Variant
   
5. 
   
6. 
   
7. Dim cirentry As AcadCircle
   
8. 
   
9.     Dim center(0 To 2) As Double
   
10.     Dim radius As Double
    
11.     Dim startAngle As Double
    
12.     Dim endAngle As Double
    
13.     Dim outerLoop(0 To 3) As AcadEntity
    
14. 
    
15. On Error Resume Next
    
16. ThisDrawing.Utility.GetEntity entry, pickedp, "选择一个圆:"
    
17. If Err Then
    
18. Err.Clear
    
19. End
    
20. End If
    
21. 'MsgBox entry.ObjectName
    
22. If entry.ObjectName = "AcDbCircle" Then
    
23. 
    
24. Set cirentry = entry
    
25. 
    
26. pickedp = cirentry.center
    
27. 
    
28.     center(0) = pickedp(0): center(1) = pickedp(1): center(2) = pickedp(2)
    
29.     radius = cirentry.radius
    
30.     startAngle = 0
    
31.     endAngle = 3.141592 / 2
    
32.     Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle)
    
33.     startAngle = 3.141592
    
34.     endAngle = 3.141592 * 1.5
    
35.     Set outerLoop(1) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle)
    
36.    
    
37.     Set outerLoop(2) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).StartPoint, outerLoop(1).StartPoint)
    
38.     Set outerLoop(3) = ThisDrawing.ModelSpace.AddLine(outerLoop(1).EndPoint, outerLoop(0).EndPoint)
    
39.    
    
40.    
    
41.      Dim hatchObj As AcadHatch
    
42.     Dim patternName As String
    
43.     Dim PatternType As Long
    
44.     Dim bAssociativity As Boolean
    
45.    
    
46.     ' Define the hatch
    
47.     patternName = "ANSI31"
    
48.     PatternType = 0
    
49.     bAssociativity = True
    
50.    
    
51.     ' Create the associative Hatch object
    
52. 
    
53.     Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
    
54.     hatchObj.AppendOuterLoop (outerLoop)
    
55.     hatchObj.PatternScale = 0.1
    
56.     hatchObj.Evaluate
    
57.    
    
58.    
    
59.     outerLoop(0).Delete
    
60.     outerLoop(1).Delete
    
61.     outerLoop(2).Delete
    
62.     outerLoop(3).Delete
    
63. End If
    
64. End Sub
    

Sub test()<br /> Dim entry As AcadEntity<br /> Dim pickedp As Variant<br /> <br /> <br /> Dim cirentry As AcadCircle<br /> <br />     Dim center(0 To 2) As Double<br />     Dim radius As Double<br />     Dim startAngle As Double<br />     Dim endAngle As Double<br />     Dim outerLoop(0 To 3) As AcadEntity<br /> <br /> On Error Resume Next<br /> ThisDrawing.Utility.GetEntity entry, pickedp, "选择一个圆:"<br /> If Err Then<br /> Err.Clear<br /> End<br /> End If<br /> 'MsgBox entry.ObjectName<br /> If entry.ObjectName = "AcDbCircle" Then<br /> <br /> Set cirentry = entry<br /> <br /> pickedp = cirentry.center<br /> <br />     center(0) = pickedp(0): center(1) = pickedp(1): center(2) = pickedp(2)<br />     radius = cirentry.radius<br />     startAngle = 0<br />     endAngle = 3.141592 / 2<br />     Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle)<br />     startAngle = 3.141592<br />     endAngle = 3.141592 * 1.5<br />     Set outerLoop(1) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle)<br />     <br />     Set outerLoop(2) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).StartPoint, outerLoop(1).StartPoint)<br />     Set outerLoop(3) = ThisDrawing.ModelSpace.AddLine(outerLoop(1).EndPoint, outerLoop(0).EndPoint)<br />     <br />     <br />      Dim hatchObj As AcadHatch<br />     Dim patternName As String<br />     Dim PatternType As Long<br />     Dim bAssociativity As Boolean<br />     <br />     ' Define the hatch<br />     patternName = "ANSI31"<br />     PatternType = 0<br />     bAssociativity = True<br />     <br />     ' Create the associative Hatch object<br /> <br />     Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)<br />     hatchObj.AppendOuterLoop (outerLoop)<br />     hatchObj.PatternScale = 0.1<br />     hatchObj.Evaluate<br />     <br />     <br />     outerLoop(0).Delete<br />     outerLoop(1).Delete<br />     outerLoop(2).Delete<br />     outerLoop(3).Delete<br /> End If<br /> End Sub<br />

topirol

完善一下，可以批量处理：

2. Const PI = 3.1415926
   
3. Sub addhatch_1_3forcircles() '批量处理
   
4. Dim ss As AcadSelectionSet
   
5. Dim cirentry As AcadCircle
   
6. Dim patternName As String '填充图案名
   
7. Dim PatternScale As Double '填充图案比例
   
8. patternName = "ANSI31"
   
9. PatternScale = 0.02
   
10. 
    
11. On Error Resume Next
    
12. Set ss = ThisDrawing.SelectionSets("sscircle")
    
13. If Err Then
    
14. Err.Clear
    
15. Set ss = ThisDrawing.SelectionSets.Add("sscircle")
    
16. End If
    
17. ss.Clear
    
18. 
    
19. Dim filtype(0) As Integer
    
20. Dim fildata(0) As Variant
    
21. filtype(0) = 0
    
22. fildata(0) = "Circle"
    
23. ss.SelectOnScreen filtype, fildata
    
24. 
    
25. 
    
26. If ss.Count <> 0 Then
    
27. Dim i As Integer
    
28. 
    
29. For i = 0 To ss.Count - 1 Step 1
    
30. If ss.Item(i).ObjectName = "AcDbCircle" Then
    
31. Set cirentry = ss.Item(i)
    
32. addhatch_1_3_of_circle cirentry, patternName, PatternScale
    
33. End If
    
34. Next
    
35. 
    
36. End If
    
37. 
    
38. End Sub
    
39. 
    
40. 
    
41. Function addhatch_1_3_of_circle(cirentry As AcadCircle, patternName As String, PatternScale As Double) '单个处理
    
42. 
    
43. 
    
44.     Dim pickedp As Variant
    
45.    
    
46. 
    
47.     Dim center(0 To 2) As Double
    
48.     Dim radius As Double
    
49.     Dim startAngle As Double
    
50.     Dim endAngle As Double
    
51.     Dim outerLoop(0 To 3) As AcadEntity
    
52. 
    
53. On Error Resume Next
    
54. 
    
55.     pickedp = cirentry.center
    
56. 
    
57.     center(0) = pickedp(0): center(1) = pickedp(1): center(2) = pickedp(2)
    
58.     radius = cirentry.radius
    
59.     startAngle = 0
    
60.     endAngle = PI / 2
    
61.     Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle) '添加1象限弧
    
62.     startAngle = PI
    
63.     endAngle = PI * 1.5
    
64.     Set outerLoop(1) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle) '添加3象限弧
    
65.    
    
66.     Set outerLoop(2) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).StartPoint, outerLoop(1).StartPoint) '添加直线
    
67.     Set outerLoop(3) = ThisDrawing.ModelSpace.AddLine(outerLoop(1).EndPoint, outerLoop(0).EndPoint) '添加直线
    
68.    
    
69.    
    
70.      Dim hatchObj As AcadHatch
    
71.    
    
72.     Dim PatternType As Long
    
73.     Dim bAssociativity As Boolean
    
74.    
    
75.     ' 定义填充
    
76.    
    
77.     PatternType = 0
    
78.     bAssociativity = True
    
79.    
    
80.     ' 创建填充
    
81. 
    
82.     Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
    
83.     hatchObj.AppendOuterLoop (outerLoop)
    
84.     hatchObj.PatternScale = PatternScale
    
85.     hatchObj.Color = 3
    
86.     hatchObj.Evaluate
    
87.    
    
88.    
    
89.   '  outerLoop(0).Delete '删除1象限弧
    
90.   '  outerLoop(1).Delete '删除3象限弧
    
91.   '  outerLoop(2).Delete '删除直线
    
92.   '  outerLoop(3).Delete '删除直线
    
93. 
    
94. End Function
    

Const PI = 3.1415926<br /> Sub addhatch_1_3forcircles() '批量处理<br /> Dim ss As AcadSelectionSet<br /> Dim cirentry As AcadCircle<br /> Dim patternName As String '填充图案名<br /> Dim PatternScale As Double '填充图案比例<br /> patternName = "ANSI31"<br /> PatternScale = 0.02<br /> <br /> On Error Resume Next<br /> Set ss = ThisDrawing.SelectionSets("sscircle")<br /> If Err Then<br /> Err.Clear<br /> Set ss = ThisDrawing.SelectionSets.Add("sscircle")<br /> End If<br /> ss.Clear<br /> <br /> Dim filtype(0) As Integer<br /> Dim fildata(0) As Variant<br /> filtype(0) = 0<br /> fildata(0) = "Circle"<br /> ss.SelectOnScreen filtype, fildata<br /> <br /> <br /> If ss.Count <> 0 Then<br /> Dim i As Integer<br /> <br /> For i = 0 To ss.Count - 1 Step 1<br /> If ss.Item(i).ObjectName = "AcDbCircle" Then<br /> Set cirentry = ss.Item(i)<br /> addhatch_1_3_of_circle cirentry, patternName, PatternScale<br /> End If<br /> Next<br /> <br /> End If<br /> <br /> End Sub<br /> <br /> <br /> Function addhatch_1_3_of_circle(cirentry As AcadCircle, patternName As String, PatternScale As Double) '单个处理<br /> <br /> <br />     Dim pickedp As Variant<br />    <br /> <br />     Dim center(0 To 2) As Double<br />     Dim radius As Double<br />     Dim startAngle As Double<br />     Dim endAngle As Double<br />     Dim outerLoop(0 To 3) As AcadEntity<br /> <br /> On Error Resume Next<br /> <br />     pickedp = cirentry.center<br /> <br />     center(0) = pickedp(0): center(1) = pickedp(1): center(2) = pickedp(2)<br />     radius = cirentry.radius<br />     startAngle = 0<br />     endAngle = PI / 2<br />     Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle) '添加1象限弧<br />     startAngle = PI<br />     endAngle = PI * 1.5<br />     Set outerLoop(1) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle) '添加3象限弧<br />     <br />     Set outerLoop(2) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).StartPoint, outerLoop(1).StartPoint) '添加直线<br />     Set outerLoop(3) = ThisDrawing.ModelSpace.AddLine(outerLoop(1).EndPoint, outerLoop(0).EndPoint) '添加直线<br />     <br />     <br />      Dim hatchObj As AcadHatch<br />     <br />     Dim PatternType As Long<br />     Dim bAssociativity As Boolean<br />     <br />     ' 定义填充<br />     <br />     PatternType = 0<br />     bAssociativity = True<br />     <br />     ' 创建填充<br /> <br />     Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)<br />     hatchObj.AppendOuterLoop (outerLoop)<br />     hatchObj.PatternScale = PatternScale<br />     hatchObj.Color = 3<br />     hatchObj.Evaluate<br />     <br />     <br />   '  outerLoop(0).Delete '删除1象限弧<br />   '  outerLoop(1).Delete '删除3象限弧<br />   '  outerLoop(2).Delete '删除直线<br />   '  outerLoop(3).Delete '删除直线<br /> <br /> End Function<br />

topirol

疑问？为什么填充图案名patternName = "SOLID"的时候结果显示会不同的呢？！请高手解答

efan2000

显示什么结果？贴张图看一下。

topirol

看看图像：

gongxiaosan

谢谢二位大侠，很好。
我还有一个问题，就是在vba中加入扩展数据的问题，似乎有setxdata和dictionary两中方法，但是我发现，在autocad vba中，所有的对象均有setxdata方法，那么我想问一下，dictionary对象的setxdata方法有和作用。此外，dictionaries集合一开始就有5个预定义的词典，而且用lisp可以看到，但是在使用item方法时，这几个预定义的词典对象竟然不支持name属性，why？