Offset VBA

[AstroNout]

Hi guys

 

I've got a bit of a problem with the offset-method in autoCAD VBA. It works a charm with LWpoly's but 2Dpolylines or other polylines with X,Y and Z-coords don't seem to go through the method, creating the variant array varObjArr. Any help is appreciated!

 

Dim varObjArr As Variant
Dim aEnt As AcadEntity
Dim aLine2 As AcadPolyline
Dim Coords2 As Variant

[... part that works with acadlwpolylines...]

ElseIf TypeOf aEnt Is AcadPolyline Then
           Set aLine2 = aEnt
           varObjArr = aLine2.Offset(-0.001)
           Set aLine2 = varObjArr(0)
           Coords2 = aLine2.Coordinates
           aLine2.Delete
End If

[Tyke]

Other than a LWPolyline there are only 2D-Polylines and 3D-Polylines.

 

Your ElseIf statement needs changing to pick up the 2D-Polyline. I usually get the object name with objEnt.ObjectName and for 2D-Polylines check for a value of "AcDb2dPolyline", whereas for a LWPolylines check for AcDbPolyline" and "AcDb3dPolyline" for 3D-Polylines.

 

If you are offsetting other objects too you might consider using a select case method such as :

 

Select Case objEnt.ObjectName
    
   Case "AcDbPolyline"
           ... (LWPolyline)

   Case "AcDb2dPolyline"
           ... (2D-Polyline)

   Case "AcDb3dPolyline"
           ... (3D-Polyline)

   Case "AcDbLine"
           ... (Line)
   .
   .
   .
   Case Else
           ... (Catches non handled objects)

End Select

[AstroNout]

Yeah, I guess you can choose how to pick them up. With the TypeOf or with the .name property.

 

I do seem to get them through the program now, bit weird, because I didn't change a thing...

 

Thanks

AstroNout

[Tyke]

As long as you have it working, then all is good.

[AstroNout]

Hi Guys

 

The offset works like a charm, but what I want to do afterwards doesn't seem to be going like planned.

 

I'm looking for closed polylines that overlap other polylines within a specific couple of layers. Sometimes the program marks lines that don't overlap with anything, but I really can't see anything wrong with my programming. I've been trying to correct the error the whole morning, without any results.

 

I think a variable should be erased somewhere, because if there aren't any polygons that overlap, everything works. Could it be the selectionsets?

 

Thanks for having a look!

 

Option Compare Text
Option Explicit

Sub Overlap()

Dim aEnt As AcadEntity
Dim varObjArr As Variant
Dim aEnt2 As AcadEntity
Dim sSet As AcadSelectionSet
Dim sSet2 As AcadSelectionSet
Dim aLine As AcadLWPolyline
Dim aCopy As AcadLWPolyline
Dim aCheck As AcadLWPolyline
Dim aLine2 As AcadPolyline
Dim aCopy2 As AcadPolyline
Dim aCheck2 As AcadPolyline
Dim Coords As Variant
Dim Coords2 As Variant
Dim Coords3 As Variant
Dim FT(0) As Integer
Dim FD(0) As Variant
Dim FT2(1) As Integer
Dim FD2(1) As Variant
Dim oLay As AcadLayer
Dim j As Integer
Dim i As Integer
Dim Overlap_Count As Integer

FT(0) = 0
FD(0) = "*polyline"
FT2(0) = 0
FD2(0) = "*polyline"
FT2(1) = 8
FD2(1) = "N_GRA*"

Set oLay = ThisDrawing.Layers.Add("_CHECK_OVERLAP")
oLay.Lineweight = acLnWt030
oLay.Color = acCyan
Overlap_Count = 0

On Error GoTo Delete
Set sSet = ThisDrawing.SelectionSets.Add("sset")
sSet.Select acSelectionSetAll, , , FT, FD

On Error GoTo ErrorControle
       
For Each aEnt In sSet
   If aEnt.Layer Like "N_GRA1A" Or aEnt.Layer Like "N_GRA1GBA" Then
       GoTo FollowingEntity
   ElseIf aEnt.Layer Like "*gano*" Or aEnt.Layer Like "N_GRA*" Or aEnt.Layer Like "ANO_GVCO*" Then
       If TypeOf aEnt Is AcadLWPolyline Then
           Set aCheck = aEnt
           varObjArr = aCheck.Offset(0.001)
           Set aLine = varObjArr(0)
           If aLine.Area > aCheck.Area Then
               Erase varObjArr
               aLine.Delete
               varObjArr = aCheck.Offset(-0.001)
               Set aLine = varObjArr(0)
           End If
           
           ReDim Coords(0 To UBound(aLine.Coordinates))
           Coords = aLine.Coordinates
           aLine.Delete
       
           ReDim Coords2(0 To ((UBound(Coords) + 1) / 2 * 3) - 1) As Double
           j = 0
       
           For i = 0 To UBound(Coords) Step 2
               Coords2(j) = Coords(i)
               Coords2(j + 1) = Coords(i + 1)
               Coords2(j + 2) = 0
               j = j + 3
           Next i
           
       ElseIf TypeOf aEnt Is AcadPolyline Then
           Set aCheck2 = aEnt
           varObjArr = aCheck2.Offset(0.001)
           Set aLine2 = varObjArr(0)
           If aLine2.Area > aCheck2.Area Then
               Erase varObjArr
               aLine2.Delete
               varObjArr = aCheck2.Offset(-0.001)
               Set aLine2 = varObjArr(0)
           End If
           
           ReDim Coords2(0 To UBound(aLine2.Coordinates)) As Double
           Coords2 = aLine2.Coordinates
           aLine2.Delete
       End If
       
       Erase varObjArr
       
       On Error GoTo Delete2
       Set sSet2 = ThisDrawing.SelectionSets.Add("sset2")
       sSet2.SelectByPolygon acSelectionSetCrossingPolygon, Coords2, FT2, FD2
       
       On Error GoTo ErrorControle
       For Each aEnt2 In sSet2
           If TypeOf aEnt2 Is AcadLWPolyline Then
               Set aCopy = aEnt2.Copy
               aCopy.Layer = "_CHECK_OVERLAP"
               Overlap_Count = Overlap_Count + 1
               'following code is the make the offsetlines visible for control
               'ThisDrawing.ModelSpace.AddPolyline (Coords2)
           ElseIf TypeOf aEnt2 Is AcadPolyline Then
               Set aCopy2 = aEnt2.Copy
               aCopy2.Layer = "_CHECK_OVERLAP"
               Overlap_Count = Overlap_Count + 1
               'following code is the make the offsetlines visible for control
               'ThisDrawing.ModelSpace.AddPolyline (Coords2)
           End If
       Next aEnt2
       
       ThisDrawing.SelectionSets.Item("sset2").Delete
       
   End If

FollowingEntity:
Next aEnt

ThisDrawing.SelectionSets.Item("sset").Delete

MsgBox Overlap_Count & " nieuwe GRA's hebben een ontoelaatbare overlap.", vbInformation, "Resultaten check"
If Overlap_Count = 0 Then
   oLay.Delete
End If

Exit Sub

Delete:
   ThisDrawing.SelectionSets.Item("sset").Delete
   Resume
Delete2:
   ThisDrawing.SelectionSets.Item("sset2").Delete
   Resume

ErrorControle:
   If Err Then MsgBox Err.Description
End Sub

[RICVBA]

Hi Guys

 

The offset works like a charm, but what I want to do afterwards doesn't seem to be going like planned.

 

I'm looking for closed polylines that overlap other polylines within a specific couple of layers. Sometimes the program marks lines that don't overlap with anything, but I really can't see anything wrong with my programming. I've been trying to correct the error the whole morning, without any results.

 

I think a variable should be erased somewhere, because if there aren't any polygons that overlap, everything works. Could it be the selectionsets?

 

Thanks for having a look!

 

Option Compare Text
Option Explicit

Sub Overlap()

Dim aEnt As AcadEntity
Dim varObjArr As Variant
Dim aEnt2 As AcadEntity
Dim sSet As AcadSelectionSet
Dim sSet2 As AcadSelectionSet
Dim aLine As AcadLWPolyline
Dim aCopy As AcadLWPolyline
Dim aCheck As AcadLWPolyline
Dim aLine2 As AcadPolyline
Dim aCopy2 As AcadPolyline
Dim aCheck2 As AcadPolyline
Dim Coords As Variant
Dim Coords2 As Variant
Dim Coords3 As Variant
Dim FT(0) As Integer
Dim FD(0) As Variant
Dim FT2(1) As Integer
Dim FD2(1) As Variant
Dim oLay As AcadLayer
Dim j As Integer
Dim i As Integer
Dim Overlap_Count As Integer

FT(0) = 0
FD(0) = "*polyline"
FT2(0) = 0
FD2(0) = "*polyline"
FT2(1) = 8
FD2(1) = "N_GRA*"

Set oLay = ThisDrawing.Layers.Add("_CHECK_OVERLAP")
oLay.Lineweight = acLnWt030
oLay.Color = acCyan
Overlap_Count = 0

On Error GoTo Delete
Set sSet = ThisDrawing.SelectionSets.Add("sset")
sSet.Select acSelectionSetAll, , , FT, FD

On Error GoTo ErrorControle

For Each aEnt In sSet
   If aEnt.Layer Like "N_GRA1A" Or aEnt.Layer Like "N_GRA1GBA" Then
       GoTo FollowingEntity
   ElseIf aEnt.Layer Like "*gano*" Or aEnt.Layer Like "N_GRA*" Or aEnt.Layer Like "ANO_GVCO*" Then
       If TypeOf aEnt Is AcadLWPolyline Then
           Set aCheck = aEnt
           varObjArr = aCheck.Offset(0.001)
           Set aLine = varObjArr(0)
           If aLine.Area > aCheck.Area Then
               Erase varObjArr
               aLine.Delete
               varObjArr = aCheck.Offset(-0.001)
               Set aLine = varObjArr(0)
           End If

           ReDim Coords(0 To UBound(aLine.Coordinates))
           Coords = aLine.Coordinates
           aLine.Delete

           ReDim Coords2(0 To ((UBound(Coords) + 1) / 2 * 3) - 1) As Double
           j = 0

           For i = 0 To UBound(Coords) Step 2
               Coords2(j) = Coords(i)
               Coords2(j + 1) = Coords(i + 1)
               Coords2(j + 2) = 0
               j = j + 3
           Next i

       ElseIf TypeOf aEnt Is AcadPolyline Then
           Set aCheck2 = aEnt
           varObjArr = aCheck2.Offset(0.001)
           Set aLine2 = varObjArr(0)
           If aLine2.Area > aCheck2.Area Then
               Erase varObjArr
               aLine2.Delete
               varObjArr = aCheck2.Offset(-0.001)
               Set aLine2 = varObjArr(0)
           End If

           ReDim Coords2(0 To UBound(aLine2.Coordinates)) As Double
           Coords2 = aLine2.Coordinates
           aLine2.Delete
       End If

       Erase varObjArr

       On Error GoTo Delete2
       Set sSet2 = ThisDrawing.SelectionSets.Add("sset2")
       sSet2.SelectByPolygon acSelectionSetCrossingPolygon, Coords2, FT2, FD2

       On Error GoTo ErrorControle
       For Each aEnt2 In sSet2
           If TypeOf aEnt2 Is AcadLWPolyline Then
               Set aCopy = aEnt2.Copy
               aCopy.Layer = "_CHECK_OVERLAP"
               Overlap_Count = Overlap_Count + 1
               'following code is the make the offsetlines visible for control
               'ThisDrawing.ModelSpace.AddPolyline (Coords2)
           ElseIf TypeOf aEnt2 Is AcadPolyline Then
               Set aCopy2 = aEnt2.Copy
               aCopy2.Layer = "_CHECK_OVERLAP"
               Overlap_Count = Overlap_Count + 1
               'following code is the make the offsetlines visible for control
               'ThisDrawing.ModelSpace.AddPolyline (Coords2)
           End If
       Next aEnt2

       ThisDrawing.SelectionSets.Item("sset2").Delete

   End If

FollowingEntity:
Next aEnt

ThisDrawing.SelectionSets.Item("sset").Delete

MsgBox Overlap_Count & " nieuwe GRA's hebben een ontoelaatbare overlap.", vbInformation, "Resultaten check"
If Overlap_Count = 0 Then
   oLay.Delete
End If

Exit Sub

Delete:
   ThisDrawing.SelectionSets.Item("sset").Delete
   Resume
Delete2:
   ThisDrawing.SelectionSets.Item("sset2").Delete
   Resume

ErrorControle:
   If Err Then MsgBox Err.Description
End Sub

 

 

 

may be it's up to the "appropriate zooming" issue we discussed some time ago.http://www.cadtutor.net/forum/showthread.php?82294-Selection-Set-Crossing-Issue i.e. selectionset command will only get objects in the displayed window.

 

in that post I also showed how I acted to gather elements that thoroughly had to lie within a certain fence. which seems much like your case.

 

furthermore I can only give that as warning (since I'm not totally sure about it): running "(entget (car (entsel)))" command and then selecting a lightweightpolyline, it gives back "LWPOLYLINE" as entitytype. so maybe you'd better use uppercase

FD(0) = "*POLYLINE"

for your selection criteria

 

finally I'm trying to read through your code to see if I could help, but I'm stuck with the following snippet

 

           Set aCheck = aEnt
           varObjArr = aCheck.Offset(0.001)
           Set aLine = varObjArr(0)
           If aLine.Area > aCheck.Area Then
               Erase varObjArr
               aLine.Delete
               varObjArr = aCheck.Offset(-0.001)
               Set aLine = varObjArr(0)
           End If

 

it seems to me that "aLine.Area > aCheck.Area" checking would always give FALSE as a result, since aLine and aCheck both come out of aEnt with only an offset as a difference.

 

as for now I didn't get further...

[AstroNout]

Hi RICVBA

 

I did notice the zoomingproblem on different forums, so I've put a zoom to extents in the program.

 

Since I use Option Compare Text, the way polyline is written shouldn't give a problem. It picks up all the polylines.

 

I did have some trouble with the offset command. This command makes sure that polylines that have the same boundary as the polyline that is surveyed are excluded from the selectionset. The small deviation of 0,001m makes it possible to still do the check to accepted standards. Whilst programming and error-handling I got the idea that the offset wasn't done properly everytime. If the polyline is drawn from left to right or from right to left, the offset is done differently. That's why I've put in the code.

 

I get the feeling that the crossing polygon option isn't working as it should. I've put the working program (in AC2011-Map) onto a AC2004, but when it gets to the crossing polygon: mayhem... The polygon is drawn around the 0,0-point, preserving the number of nodes and the area, and the original polygon is deleted. I'm scratching not only my head now... GRMBL

 

I'm troubleshooting now...

 

Grtz

AstroNout

[RICVBA]

Hi RICVBA

 

I did notice the zoomingproblem on different forums, so I've put a zoom to extents in the program.

 

Since I use Option Compare Text, the way polyline is written shouldn't give a problem. It picks up all the polylines.

 

I did have some trouble with the offset command. This command makes sure that polylines that have the same boundary as the polyline that is surveyed are excluded from the selectionset. The small deviation of 0,001m makes it possible to still do the check to accepted standards. Whilst programming and error-handling I got the idea that the offset wasn't done properly everytime. If the polyline is drawn from left to right or from right to left, the offset is done differently. That's why I've put in the code.

 

I get the feeling that the crossing polygon option isn't working as it should. I've put the working program (in AC2011-Map) onto a AC2004, but when it gets to the crossing polygon: mayhem... The polygon is drawn around the 0,0-point, preserving the number of nodes and the area, and the original polygon is deleted. I'm scratching not only my head now... GRMBL

 

I'm troubleshooting now...

 

Grtz

AstroNout

 

 

Hi AstroNout

you may post your dwg file if you want. so that I could better understand what's on and possibly give some useful aid

bye

[AstroNout]

On the left it's the situation that has to be drawn. On the right the original situation. This is drawn in 2011.

 

The situation in 2004 will be posted here ASAP.

 

Grtz

AstroNout

Test_Overlap.dwg

[RICVBA]

On the left it's the situation that has to be drawn. On the right the original situation. This is drawn in 2011.

 

The situation in 2004 will be posted here ASAP.

 

Grtz

AstroNout

 

Hi AstroNout

I simply run your routine in a drawing containing the objects "on the right" only and obtained what you expected "on the left".

what probems did you encounter actually?

 

PS: my previuos doubt about "aLine.Area > aCheck.Area" check was due to my ignorance about "offset" method which I presumed was only to shift the newly created objects while I now realized it acts on their area. sorry.

[AstroNout]

Hi RICVBA

 

Here's what I get in AC2004.

Test_Overlap_AC2004.dwg

[RICVBA]

Hi RICVBA

 

 

Here's what I get in AC2004.

 

 

 

I'll have a deeper look at this issue these days.

If you have a more complex drawing to test, please attach it.

[RICVBA]

I'll have a deeper look at this issue these days.

If you have a more complex drawing to test, please attach it.

 

Hi AstroNout

 

 

after deeply studying your dwg file and code, I confirm you that in my system it all works fine, i.e. your sub correctly gathers overlapping elements in proper layers.

 

 

may be you get problems with more complex dwgs with geometric cases that are not present in the one you posted.

I'll gladly test the very dwgs you have problems with if you want to attach them too.

 

 

In the meanwhile I hope I can help you with the attached "Test_Overlap - studying.dwg" file where you'll find your original "Overlap" sub and the following subs:

- OverlapStudy sub

where I added coloring and zooming commands in order to better follow what the sub is doing with entities.

- OverlapNew sub

where I made some minor modification to your code for optimization (or at least what I think them to be) purposes only. I extended the selectionset ftype and fdata arrays to avoid subsequent if-then-else checking. and added a handle check to avoid processing aEnt2 should it ever be aEnt itself (in case acSelectionSetCrossingPolygon failed in excluding aEnt)

- OverlapNew2 sub

where a tried overlapping detection through "intersectwith" method. but it fails when two polylines partially share some boundary sides, detecting them as overlapping (and this is not what you want, is it?)

- adds Module where I placed zooming and copy&moving subs, called by main subs

 

 

furthermore, I also added a few elements in the drawning to test differently clokwise generated polylines as well as elements in layers of no interest

 

 

please let me know

 

 

bye

Test_Overlap - studying.dwg

[AstroNout]

Hi Ric

 

Thanks for the help. It seems that the drawings are to big for AC2004. A small drawing holds easily 15000 elements, the bigger go to 1.000.000 elements. Because of this I've thrown the offset-command overboard and check for points of the polygon inside the polygon that's being checked for polygons completely inside polygons and use the IntersectWith command to get those intersecting polygons. By cycling through the intersecting points, the existing nodes of the checked polygons are discarted, so only the intersections without nodes are highlighted. This method works like a charm. Now I can get busy using this function on the other elements and types in the drawing.

 

I've upgraded the performance significantly using your tips, so, a big up for you!

 

I'll put the code here one of these days.

 

Grtz

AstroNout

[RICVBA]

Hi AstroNout

glad to be of any help to you

 

looking forward to see your code

 

bye