Hatch IntersectWith

[cadger]

Hello,

I would like to determine if a Hatch intersects a Polyline.. Is this possible?  The help mentions that .intersectwith works for all drawing objects except polygonmesh (and some other misc. object).  I'd rather not convert them to blocks, but it also doesn't work with Blocks?  Is this correct?  Does anyone have any ideas how to determine hatches intersecting polylines?  Thanks!

Sub anotherte vst()
Set sset = ThisDrawing.SelectionSets.Add(Now())
prompt "select poly then hatch"
sset.SelectOnScreen
Dim myblock As AcadBlockReference
Set myblock = sset(1)
Set mypoly = sset(0)
Dim intpoints As Variant
intpoint = mypoly.IntersectWith(myblock, acExtendNone)
Dim I As Integer, j As Integer, k As Integer
Dim str As String
If VarType(intpoints) <> vbEmpty Then
For I = LBound(intpoints) To UBound(intpoints)
str = "Intersection Point[" & k & "] is: " & intpoints(j) & "," & intpoints(j + 1) & "," & intpoints(j + 2)
MsgBox str, , "IntersectWith Example"
str = ""
I = I + 2
j = j + 3
k = k + 1
Next
End If
End Sub

[RICVBA]

you could use the Hatch object's "GetLoopAt" method

like as follows

Sub anotherte_vst_modified()
'slightly modified by RICVBA

Dim sset As AcadSelectionSet '<--- added by RICVBA
Dim mypoly As AcadLWPolyline '<--- added by RICVBA
Dim intpoints As Variant '<--- added by RICVBA

Dim hatchObj As AcadHatch '<--- added by RICVBA

Set sset = ThisDrawing.SelectionSets.Add(Now())
ThisDrawing.Utility.Prompt "select poly then hatch"
sset.SelectOnScreen

Set mypoly = sset(0)
Set hatchObj = sset(1) '<--- modified by RICVBA

'-------------------------
' added/modified by RICVBA
' get the objects that make up the first loop
Dim loopObjs As Variant
hatchObj.GetLoopAt 0, loopObjs

' Find intersection with each of the objects in the first loop
Dim iLoop As Integer
Dim I As Integer, j As Integer, k As Integer
Dim str As String
For iLoop = LBound(loopObjs) To UBound(loopObjs)
    intpoints = mypoly.IntersectWith(loopObjs(iLoop), acExtendNone)
    If VarType(intpoints) <> vbEmpty Then
        For I = LBound(intpoints) To UBound(intpoints)
            str = "Intersection Point[" & k & "] is: " & intpoints(j) & "," & intpoints(j + 1) & "," & intpoints(j + 2)
            MsgBox str, , "IntersectWith Example"
            str = ""
            I = I + 2
            j = j + 3
            k = k + 1
        Next
    End If
Next
'----------------------------

End Sub

 but there's something wrong in  the

For I = LBound(intpoints) To UBound(intpoints)

loop as for i, j and k increments, that rise an out of range error

you just need little modifications to make it work

bye

[cadger]

Thanks for your reply.  It's easier to do something when you know it's possible.

Interesting, but dissapointing it looks like the following code works when the hatch is created programmatically, but doesn't work after you delete the entities that defined the OuterLoops.  Hopefully I'm wrong....

From the help file:

Sub Example_GetLoopAt()
    ' This example creates an associative hatch in model space.
    ' It then finds the objects that make up the first loop of the hatch.
    
    Dim hatchObj As AcadHatch
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
 
    ' Define the hatch
    patternName = "ANSI31"
    PatternType = 0
    bAssociativity = True
    
    ' Create the associative Hatch object
    Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
    
    ' Create the outer loop for the hatch.
    ' An arc and a line are used to create a closed loop.
    Dim outerLoop(0 To 1) As AcadEntity
    Dim center(0 To 2) As Double
    Dim radius As Double
    Dim startAngle As Double
    Dim endAngle As Double
    center(0) = 5: center(1) = 3: center(2) = 0
    radius = 3
    startAngle = 0
    endAngle = 3.141592
    Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle)
    Set outerLoop(1) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).startPoint, outerLoop(0).endPoint)

    ' Append the outer loop to the hatch object
    hatchObj.AppendOuterLoop (outerLoop)

    ' Append the first circle as one inner loop
    Dim innerLoop1(0) As AcadEntity
    center(0) = 5: center(1) = 4.5: center(2) = 0
    radius = 50
    Set innerLoop1(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
    hatchObj.AppendInnerLoop (innerLoop1)

    ' Append the second circle as the other inner loop
    Dim innerLoop2(0) As AcadEntity
    radius = 50
    Set innerLoop2(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
    hatchObj.AppendInnerLoop (innerLoop2)

    ' Evaluate and display the hatch
    hatchObj.Evaluate
 
    ' Find the objects that make up the first loopRegen True
'''''''''
    Dim loopObjs As Variant
    ThisDrawing.Utility.GetEntity hatchObj, varPt, "PICK HATCH"
    hatchObj.GetLoopAt 0, loopObjs
    
    ' Find the types of the objects in the loop
    Dim I As Integer
    Dim objName As String
    objName = ""
    For I = LBound(loopObjs) To UBound(loopObjs)
        objName = objName & loopObjs(I).EntityName & ", "
    Next
    
    MsgBox "The objects in the first loop of the hatch are: " & objName, , "GetLoopAt Example"
       
End Sub

And this works only when the hatch was created programmatically and the hatch boundaries are still intact:

Sub yetanothertest_modified()
'
'TO TEST, DRAW A POLYLINE ON TOP OF A HATCH
'
Dim sset As AcadSelectionSet '<--- added by RICVBA
Dim mypoly As AcadLWPolyline '<--- added by RICVBA
Dim intpoints As Variant '<--- added by RICVBA

Dim hatchObj As AcadHatch '<--- added by RICVBA

Set sset = ThisDrawing.SelectionSets.Add(Now())
ThisDrawing.Utility.prompt "select poly then hatch"
sset.SelectOnScreen

Set mypoly = sset(0)
Set hatchObj = sset(1) '<--- modified by RICVBA

'-------------------------
' added/modified by RICVBA
' get the objects that make up the first loop
Dim loopObjs As Variant
hatchObj.GetLoopAt 0, loopObjs
Dim dblPt(0 To 2) As Double
' Find intersection with each of the objects in the first loop
Dim iLoop As Integer
Dim I As Integer, j As Integer, k As Integer
Dim str As String
For iLoop = LBound(loopObjs) To UBound(loopObjs)
    intpoints = mypoly.IntersectWith(loopObjs(iLoop), acExtendNone)
    If VarType(intpoints) <> vbEmpty Then
        For I = LBound(intpoints) To UBound(intpoints)
            On Error GoTo exitit
            dblPt(0) = intpoints(0): dblPt(1) = intpoints(1): dblPt(2) = intpoints(2)
            ThisDrawing.ModelSpace.AddCircle dblPt, 0.2
'''            str = "Intersection Point[" & k & "] is: " & intpoints(j) & "," & intpoints(j + 1) & "," & intpoints(j + 2)
'''            MsgBox str, , "IntersectWith Example"
'''            str = ""
            I = I + 2: j = j + 3: k = k + 1
        Next I
    End If
Next iLoop
'----------------------------
exitit:
End Sub

 Thanks

[RICVBA]

I'm afraid you must have original loops still on site in order to have them catched by the Hatch object's "GetLoopAt" method

While I don't know whether loops must be created programatically also.

I myself used that help file snippet to create the hatch to test "yetanothertest_modified()" sub with. So I don't know if it'd work with a "manual" hatch loops.

I can only add a "dirty and not-so-accurate" solution using Hatch object's "GetBoundingBox" property to get the upper-right and lower-left of a rectangle boxing the hatch. you could then draw that rectangle programatically and check its intersection with any polyline. of course this could work fine if hatches have rectangular shape. while it leads to a solution as much inaccurate as the actual hatch shapes differs from a rectangular one

Sorry I can't help you more

[cadger]

thanks ricvba - it seems that with civil 3d you can right-click and generate a boundary... which is an AEC Polygon and doing intersects with that works. Not sure yet how to just test for overlaping intersections and not include touching intersections...

[cadger]

also... does anyone know how to access the area of an AEC Polygon? (not a polyline)

[cadger]

ah nevermind, found the right tools references and then the sample..
Sub Example_FromPolyline()


'This example shows the area of the profile of an AecPolygon

Dim obj As Object
Dim pt As Variant
Dim poly As AecPolygon

ThisDrawing.Utility.GetEntity obj, pt, "Select an AEC Polygon"

If TypeOf obj Is AecPolygon Then
Set poly = obj
MsgBox "Profile Area: " & poly.profile.area, vbInformation, "Area Example"
Else
MsgBox "Not a Polygon or no Profile Found", vbInformation, "Area Example"
End If

End Sub