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
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
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
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