反射镜舱口，vba
当您在 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）
但是它们的舱口加倍了。
**** Hidden Message *****
页:
[1]