自动填充的，出错了，帮忙看看！！

home · 发表于 2008-4-17 21:54:00

Sub test()
Dim hatchObj As AcadHatch
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean
Dim outerLoop(0 To 0) As AcadEntity
' 定义图案填充
patternName = "ANSI31"
PatternType = 0
bAssociativity = True
' 当前图纸的实体数目
Dim n As Long
n = ThisDrawing.ModelSpace.Count

' 调用BOUNDARY命令获取某一点处的边界
Dim Pt As Variant
Pt = ThisDrawing.Utility.GetPoint(, "指定内部点: ")
ThisDrawing.SendCommand "_-Boundary" & vbCr & Pt(0) & "," & Pt(1) & vbCr & vbCr

' 如果存在边界，则会生成新的实体
Dim lwpLineObj As AcadLWPolyline
If ThisDrawing.ModelSpace.Count > n Then
      Set lwpLineObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
      MsgBox lwpLineObj.Area
'       lwpLineObj.Delete
      lwpLineObj.Closed = True
Else
      MsgBox "未发现有效的边界。"
End If
outerLoop(0) = lwpLineObj
hatchObj.AppendOuterLoop (outerLoop)
hatchObj.Evaluate
ObjDoc.Regen True
End Sub

home · 发表于 2008-5-8 12:37:00

解决了，
需要加Boundary命令前加个zoomall命令

muzi2005888 · 发表于 2008-5-9 18:47:00

我想楼主个问题
在对面域填充时
当面域为不连续或为环状时则不能正常填充（利用快速选择能选中图案填充，就是不能显示）

nhy12345678 · 发表于 2008-5-9 19:14:00

Dim i As Long
Dim hatchObj As AcadHatch
Dim patternName As String
Dim patternType As Long
Dim assocVar As Boolean
Dim outerLoop(0 To 0) As AcadEntity
Dim eNt As AcadEntity
Dim sset As AcadSelectionSet
Dim outerLoop1(0 To 0) As AcadEntity
Dim n As Long
Dim Pt As Variant
patternName = "SOLID"
patternType = acHatchPatternTypePreDefined
assocVar = True
n = ThisDrawing.ModelSpace.Count
Pt = ThisDrawing.Utility.GetPoint(, "指定内部点: ")
ThisDrawing.SendCommand "_-Boundary" & vbCr & Pt(0) & "," & Pt(1) & vbCr & vbCr
If ThisDrawing.ModelSpace.Count > n Then
Set outerLoop1(0) = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
Else
MsgBox "未发现有效的边界。"
End If
Set sset = ThisDrawing.SelectionSets.Add("ss7")
sset.AddItems outerLoop1
For Each eNt In sset
Set outerLoop(0) = eNt
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(patternType, patternName, assocVar)
hatchObj.AppendOuterLoop (outerLoop)
hatchObj.Evaluate
Next
sset.Delete
ThisDrawing.Regen True

自动填充的，出错了，帮忙看看！！

发表回复

精选推荐