如何在vba中实现象autocad界面上的点选生成阴影呢
各位，我有一个问题请教，如和在vba中实现如同autocad界面中的那样点选一个区域从而在该区域生成阴影，譬如一个圆，过圆心有两条相互垂直的线，现在我希望在1，3象限生成阴影，该如何呢 这个行不行？Sub test()
Dim entry As AcadEntity
Dim pickedp As Variant
Dim cirentry As AcadCircle
Dim center(0 To 2) As Double
Dim radius As Double
Dim startAngle As Double
Dim endAngle As Double
Dim outerLoop(0 To 3) As AcadEntity
On Error Resume Next
ThisDrawing.Utility.GetEntity entry, pickedp, "选择一个圆:"
If Err Then
Err.Clear
End
End If
'MsgBox entry.ObjectName
If entry.ObjectName = "AcDbCircle" Then
Set cirentry = entry
pickedp = cirentry.center
center(0) = pickedp(0): center(1) = pickedp(1): center(2) = pickedp(2)
radius = cirentry.radius
startAngle = 0
endAngle = 3.141592 / 2
Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle)
startAngle = 3.141592
endAngle = 3.141592 * 1.5
Set outerLoop(1) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle)
Set outerLoop(2) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).StartPoint, outerLoop(1).StartPoint)
Set outerLoop(3) = ThisDrawing.ModelSpace.AddLine(outerLoop(1).EndPoint, outerLoop(0).EndPoint)
Dim hatchObj As AcadHatch
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean
' Define the hatch
patternName = "ANSI31"
PatternType = 0
bAssociativity = True
' Create the associative Hatch object
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
hatchObj.AppendOuterLoop (outerLoop)
hatchObj.PatternScale = 0.1
hatchObj.Evaluate
outerLoop(0).Delete
outerLoop(1).Delete
outerLoop(2).Delete
outerLoop(3).Delete
End If
End Sub
完善一下，可以批量处理：Const PI = 3.1415926
Sub addhatch_1_3forcircles() '批量处理
Dim ss As AcadSelectionSet
Dim cirentry As AcadCircle
Dim patternName As String '填充图案名
Dim PatternScale As Double '填充图案比例
patternName = "ANSI31"
PatternScale = 0.02
On Error Resume Next
Set ss = ThisDrawing.SelectionSets("sscircle")
If Err Then
Err.Clear
Set ss = ThisDrawing.SelectionSets.Add("sscircle")
End If
ss.Clear
Dim filtype(0) As Integer
Dim fildata(0) As Variant
filtype(0) = 0
fildata(0) = "Circle"
ss.SelectOnScreen filtype, fildata
If ss.Count <> 0 Then
Dim i As Integer
For i = 0 To ss.Count - 1 Step 1
If ss.Item(i).ObjectName = "AcDbCircle" Then
Set cirentry = ss.Item(i)
addhatch_1_3_of_circle cirentry, patternName, PatternScale
End If
Next
End If
End Sub
Function addhatch_1_3_of_circle(cirentry As AcadCircle, patternName As String, PatternScale As Double) '单个处理
Dim pickedp As Variant
Dim center(0 To 2) As Double
Dim radius As Double
Dim startAngle As Double
Dim endAngle As Double
Dim outerLoop(0 To 3) As AcadEntity
On Error Resume Next
pickedp = cirentry.center
center(0) = pickedp(0): center(1) = pickedp(1): center(2) = pickedp(2)
radius = cirentry.radius
startAngle = 0
endAngle = PI / 2
Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle) '添加1象限弧
startAngle = PI
endAngle = PI * 1.5
Set outerLoop(1) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle) '添加3象限弧
Set outerLoop(2) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).StartPoint, outerLoop(1).StartPoint) '添加直线
Set outerLoop(3) = ThisDrawing.ModelSpace.AddLine(outerLoop(1).EndPoint, outerLoop(0).EndPoint) '添加直线
Dim hatchObj As AcadHatch
Dim PatternType As Long
Dim bAssociativity As Boolean
' 定义填充
PatternType = 0
bAssociativity = True
' 创建填充
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
hatchObj.AppendOuterLoop (outerLoop)
hatchObj.PatternScale = PatternScale
hatchObj.Color = 3
hatchObj.Evaluate
'outerLoop(0).Delete '删除1象限弧
'outerLoop(1).Delete '删除3象限弧
'outerLoop(2).Delete '删除直线
'outerLoop(3).Delete '删除直线
End Function
疑问？为什么填充图案名patternName = "SOLID"的时候结果显示会不同的呢？！请高手解答 显示什么结果？贴张图看一下。 看看图像：
谢谢二位大侠，很好。
我还有一个问题，就是在vba中加入扩展数据的问题，似乎有setxdata和dictionary两中方法，但是我发现，在autocad vba中，所有的对象均有setxdata方法，那么我想问一下，dictionary对象的setxdata方法有和作用。此外，dictionaries集合一开始就有5个预定义的词典，而且用lisp可以看到，但是在使用item方法时，这几个预定义的词典对象竟然不支持name属性，why？
页:
[1]