当您在 vba 中镜像图案填充时,生成的新图案填充似乎不是关联的。
如果将镜像的pline对象设置为镜像舱口的外环并获得奇怪的结果(双倍舱口),
我希望其他人已经弄清楚了这一点。我能做的最好的事情就是创建一个新的舱口,而不是模仿它。
- Sub MirrorHatch()
- Dim Ent As AcadEntity
- Dim Ent2 As AcadEntity
- Dim oHatch As AcadHatch
- Dim MirrHatch As AcadHatch
- Dim oPline As AcadLWPolyline
- Dim MirrPline(0) As AcadEntity
- Dim Id As Long
- Dim ob(0) As AcadObject
- Dim obs As Variant
- Dim SS As AcadSelectionSet
- Dim P1, P2
- Dim i As Integer
- Dim Zero(2) As Double
-
- P1 = Zero
- P2 = P1
- P2(1) = 1
- Set SS = ThisDrawing.SelectionSets.Add("ss")
- SS.SelectOnScreen
-
- For i = SS.Count - 1 To 0 Step -1
- Set Ent = SS(i)
- If TypeOf Ent Is AcadHatch Then
- Set oHatch = Ent
- If oHatch.AssociativeHatch Then
- If oHatch.NumberOfLoops = 1 Then
- oHatch.GetLoopAt 0, obs
- Debug.Print UBound(obs)
- If UBound(obs) = 0 Then
- If TypeOf obs(0) Is AcadLWPolyline Then
- Id = obs(0).ObjectID
- For Each Ent2 In SS
- If Ent2.ObjectID = Id Then
- Set oPline = Ent2
- Set MirrPline(0) = oPline.Mirror(P1, P2)
- Set MirrHatch = ThisDrawing.ModelSpace.AddHatch(oHatch.PatternType, _
- oHatch.PatternName, True)
- MirrHatch.AppendOuterLoop MirrPline
- MirrHatch.Layer = oHatch.Layer
- MirrHatch.PatternScale = oHatch.PatternScale
- MirrHatch.PatternAngle = -oHatch.PatternAngle
- MirrHatch.Evaluate
-
- 'Set MirrHatch = oHatch.Mirror(P1, P2)
- 'MirrHatch.AppendOuterLoop (MirrPline)
-
- SS.RemoveItems obs
- Set ob(0) = Ent
- SS.RemoveItems ob
- Exit For
- End If
- Next
- End If
- End If
- End If
- End If
- End If
- Next i
- For Each Ent In SS
- Ent.Mirror P1, P2
- Next
-
- SS.Delete
- End Sub
这个子工作,但是,
这2行我期望工作
'Set MirrHatch = oHatch.Mirror(P1, P2)
'MirrHatch.AppendOuterLoop (MirrPline)
但是它们的舱口加倍了。
本帖以下内容被隐藏保护;需要你回复后,才能看到! 游客,如果您要查看本帖隐藏内容请 回复 |