如何求填充边界,请教大侠

zgyxn

请问用哪个函数可以来求填充边界,并用多义块画出来?

zgyxn

是多义线,不是多义块,打错字了


我查了不少书,填充边界就是很难找到,哪位能帮一下吗

zgyxn

有人给点提示也好呀!!!!!

mccad

以下程序只对于那些边界还关联着的填充图案有效。如果删除边界后还需要取得边界，则需要使用LISP的方法。

2. Sub HatchBound()
3.        Dim Ent As AcadEntity
4.        Dim Pnt As Variant
5.        Dim Hat As AcadHatch
6.        Dim LoopNum As Integer
7.        Dim i As Integer
8.        Dim LoopObjs As Variant
9.        Dim j As Integer
10.        'On Error Resume Next
11.        Do
12.                ThisDrawing.Utility.GetEntity Ent, Pnt, vbCr & "选择填充图案："
13.                If Err.Number <> 0 Then Exit Sub
14.                If Ent.ObjectName = "AcDbHatch" Then Exit Do
15.        Loop
16.        Set Hat = Ent
17.        LoopNum = Hat.NumberOfLoops
18.        For i = 0 To LoopNum - 1
19.                Debug.Print "第" & i & "个环的对象："
20.                Hat.GetLoopAt i, LoopObjs
21.                For j = 0 To UBound(LoopObjs)
22.                        Debug.Print LoopObjs(j).ObjectName
23.                Next j
24.        Next i
25. End Sub

Sub HatchBound()        Dim Ent As AcadEntity        Dim Pnt As Variant        Dim Hat As AcadHatch        Dim LoopNum As Integer        Dim i As Integer        Dim LoopObjs As Variant        Dim j As Integer        'On Error Resume Next        Do                ThisDrawing.Utility.GetEntity Ent, Pnt, vbCr & "选择填充图案："                If Err.Number <> 0 Then Exit Sub                If Ent.ObjectName = "AcDbHatch" Then Exit Do        Loop        Set Hat = Ent        LoopNum = Hat.NumberOfLoops        For i = 0 To LoopNum - 1                Debug.Print "第" & i & "个环的对象："                Hat.GetLoopAt i, LoopObjs                For j = 0 To UBound(LoopObjs)                        Debug.Print LoopObjs(j).ObjectName                Next j        Next i End Sub

zfwu

给你个函数参考 '外轮廓
Public Function OutBoundary(Point1 As Variant, Point2 As Variant) As AcadLWPolyline
On Error Resume Next
Dim PointToString As String
PointToString = Trim(Str(Point1(0))) & "," & Trim(Str(Point1(1))) '转换点为字符
Dim PrevTotal As Long
PrevTotal = MoSpace.Count
'辅助边界
Dim AssistantBoundary As AcadLWPolyline
Dim PntList(0 To 9) As Double
PntList(0) = Point2(0): PntList(1) = Point2(1)
PntList(2) = Point2(0): PntList(3) = Point2(3)
PntList(4) = Point2(2): PntList(5) = Point2(3)
PntList(6) = Point2(2): PntList(7) = Point2(0)
PntList(8) = Point2(0): PntList(9) = Point2(1)
Set AssistantBoundary = MoSpace.AddLightWeightPolyline(PntList)
'AcadDoc.SetVariable "NOMUTT", 1 '禁止不确定的消息反馈
AcadDoc.SendCommand "-boundary" & vbCr & PointToString & vbCr & vbCr '调用BOUNDARY命令获取一点的边界
'AcadDoc.SetVariable "NOMUTT", 0 '恢复普通模式的消息反馈
'Sleep (1000)
If MoSpace.Count > PrevTotal Then
Set OutBoundary = MoSpace.Item(MoSpace.Count - 2)
End If
MoSpace.Item(MoSpace.Count - 1).Delete '删除辅助边界
AssistantBoundary.Delete
End Function