How can I get each Polygon in a region?

[markc0826]

Dear all..

Like as the image, there are dividing lines(yellow) in a region (red). How can I get each type of polygon with VBA?

Thanks for helping..

[Ed__Jobe]

Are they actual lwpolygon entities or just areas formed by intersecting lines?

[markc0826]

just areas formed by intersecting lines !!

[arcticad]

a lot of math and using intersectwith. There isn't a built in function to do this.

[markc0826]

Could you give me some suggestions or ideas to do that...

[Hallex]

Start from this one , but keep in mind

you'll get many duplicates

Option Explicit
'make sure under "Tools|Options|General" you select "Break on Unhandled Errors" button
Public Sub CreateAllPolygons()

Dim oCirc As AcadCircle
Dim oSset As AcadSelectionSet
Dim gap As Double
Dim zp1 As Variant
Dim zp2 As Variant
For Each oSset In ThisDrawing.SelectionSets
If oSset.Name = "$Lines$" Then
ThisDrawing.SelectionSets("$Lines$").Delete
Exit For
End If
Next
ThisDrawing.SelectionSets.Add ("$Lines$")
Set oSset = ThisDrawing.SelectionSets("$Lines$")
Dim ftype(0) As Integer
Dim fdata(0) As Variant
ftype(0) = 0: fdata(0) = "line"

gap = ThisDrawing.Utility.GetDistance(, vbLf & "Pick distance of smallest dimension of the cell:")

zp1 = ThisDrawing.Utility.GetPoint(, vbLf & "Lower left point of selection area:")

zp2 = ThisDrawing.Utility.GetCorner(zp1, vbLf & "Upper right point of selection area:")

ZoomWindow zp1, zp2

ThisDrawing.Utility.Prompt vbLf & vbTab & "Select all lines:"

oSset.SelectOnScreen ftype, fdata

Dim n As Integer
Dim points() As Double
n = -1
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim pts() As Double

For i = 0 To oSset.Count - 2
For j = 0 To oSset.Count - 1
pts = oSset(i).IntersectWith(oSset(j), acExtendNone)
If LBound(pts) <> -1 Then
For k = 0 To UBound(pts)
n = n + 1
If n = 0 Then
ReDim points(0)
Else
ReDim Preserve points(n)
End If
points(n) = CDbl(pts(k))
Next
End If
Next
Next
ThisDrawing.StartUndoMark
ThisDrawing.SetVariable "celweight", 50
ThisDrawing.SetVariable "cecolor", "4"
gap = gap / 2
For i = 0 To UBound(points) - 2 Step 3
Dim p(2) As Double
p(0) = points(i)
p(1) = points(i + 1)
p(2) = points(i + 2)
Dim inspt As Variant
inspt = ThisDrawing.Utility.TranslateCoordinates(p, acWorld, acUCS, False)


Dim pstr As String

On Error Resume Next

pstr = Replace(CStr(inspt(0) + gap), ",", ".") & "," & Replace(CStr(inspt(1) + gap), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary " & pstr & vbCr & vbCr

pstr = Replace(CStr(inspt(0) - gap), ",", ".") & "," & Replace(CStr(inspt(1) + gap), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary " & pstr & vbCr & vbCr

pstr = Replace(CStr(inspt(0) - gap), ",", ".") & "," & Replace(CStr(inspt(1) - gap), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary " & pstr & vbCr & vbCr

pstr = Replace(CStr(inspt(0) + gap), ",", ".") & "," & Replace(CStr(inspt(1) - gap), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary " & pstr & vbCr & vbCr

Next

ThisDrawing.EndUndoMark
End Sub

~'J'~

[Hallex · Accepted solution]

Here is released code without duplicate contours

Option Explicit
'make sure under "Tools|Options|General" you select "Break on Unhandled Errors" button
Public Sub CreateAllPolygons()

Dim oCirc As AcadCircle
Dim oSset As AcadSelectionSet
Dim gap As Double
Dim zp1 As Variant
Dim zp2 As Variant
For Each oSset In ThisDrawing.SelectionSets
If oSset.Name = "$Lines$" Then
ThisDrawing.SelectionSets("$Lines$").Delete
Exit For
End If
Next
ThisDrawing.SelectionSets.Add ("$Lines$")
Set oSset = ThisDrawing.SelectionSets("$Lines$")
Dim ftype(0) As Integer
Dim fdata(0) As Variant
ftype(0) = 0: fdata(0) = "line"

gap = ThisDrawing.Utility.GetDistance(, vbLf & "Pick distance of smallest dimension of the cell:")

zp1 = ThisDrawing.Utility.GetPoint(, vbLf & "Lower left point of selection area:")

zp2 = ThisDrawing.Utility.GetCorner(zp1, vbLf & "Upper right point of selection area:")

ZoomWindow zp1, zp2

ThisDrawing.Utility.Prompt vbLf & vbTab & "Select all lines:"

oSset.SelectOnScreen ftype, fdata

Dim n As Integer
Dim points() As Double
n = -1
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim pts() As Double

For i = 0 To oSset.Count - 2
For j = 0 To oSset.Count - 1
pts = oSset(i).IntersectWith(oSset(j), acExtendNone)
If LBound(pts) <> -1 Then
For k = 0 To UBound(pts)
n = n + 1
If n = 0 Then
ReDim points(0)
Else
ReDim Preserve points(n)
End If
points(n) = CDbl(pts(k))
Next
End If
Next
Next
ThisDrawing.StartUndoMark
ThisDrawing.SetVariable "celweight", 50
ThisDrawing.SetVariable "cecolor", "4"
gap = gap / 2
For i = 0 To UBound(points) - 2 Step 3
Dim p(2) As Double
p(0) = points(i)
p(1) = points(i + 1)
p(2) = points(i + 2)
Dim inspt As Variant
inspt = ThisDrawing.Utility.TranslateCoordinates(p, acWorld, acUCS, False)


Dim pstr As String

On Error Resume Next

pstr = Replace(CStr(inspt(0) + gap), ",", ".") & "," & Replace(CStr(inspt(1) + gap), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary " & pstr & vbCr & vbCr

pstr = Replace(CStr(inspt(0) - gap), ",", ".") & "," & Replace(CStr(inspt(1) + gap), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary " & pstr & vbCr & vbCr

pstr = Replace(CStr(inspt(0) - gap), ",", ".") & "," & Replace(CStr(inspt(1) - gap), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary " & pstr & vbCr & vbCr

pstr = Replace(CStr(inspt(0) + gap), ",", ".") & "," & Replace(CStr(inspt(1) - gap), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary " & pstr & vbCr & vbCr

Next
' Important:
' After the overkill window occurs uncheck all of the checkboxes inside
ThisDrawing.SendCommand Chr(3) & Chr(3) & "_overkill " & "pause" & vbCr
ThisDrawing.EndUndoMark
End Sub

 Make sure you've select the same area after

all polygons were created to run OVERKILL command

~'J'~

[markc0826]

What a wonderful solution...It's worked
I think I'll spend lot of time to study it.
Thank you very very very much for helping..

[Hallex]

This is a crap code, but I could not find an another way

You're welcome, though

Spoiler

~'J'~