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
