Author Topic: Mirror hatch,vba  (Read 1059 times)

0 Members and 1 Guest are viewing this topic.

Bryco

  • Water Moccasin
  • Posts: 1849
Mirror hatch,vba
« on: January 31, 2007, 02:40:28 AM »
It seems that when you mirror a hatch in vba the resulting new hatch isn't associative.
If played with setting the mirrored pline object to be the outerloop of the mirrored hatch and get weird results (Doubled hatch)
I'm hoping someone else has figured this out. The best I could do was create a new hatch not mirror it.
Code: [Select]
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
This sub works but,
these 2 lines I expected to work
'Set MirrHatch = oHatch.Mirror(P1, P2)
 'MirrHatch.AppendOuterLoop (MirrPline)
But they the hatch was doubled.