Jump to content

VBA Create a polyline through overall perimeter of selected objects


Andresig

Recommended Posts

Hi again,

 

As a good rookie, I'm struggling with the VBA...:oops:

 

I have a selection of objects, all snaped, no gaps in between, now I need to make a polyline through the overall perimeter... but how?:?

 

Before I have used the SendCommand "-boundary" but only works for single areas, now I have to make a polyline including several areas together.

 

Any clue will help me lots!!

 

Thank you

Link to comment
Share on other sites

  • 5 weeks later...

this was my plan....

I select the objects(closed lwpolylines) and make regions then I combine the regions to make one single region, I explode the region to make lines, I collect the coordinates of the lines, then I make a polyline with the coordinates retrieved, but happens that the exploded lines are not in order!!! so right now i'm stuck with it...

 

here is what I,ve done... Starting from regions...

Any help to solve this will be awesome!:thumbsup:

Sub PerimeterLine()
   'To create Regions with the objects
   Dim DifRegs() As AcadObject
   Dim ObjtoConv As AcadEntity
   Dim ActRegion As Variant
   Dim FstRegs As AcadSelectionSet
   Dim FstRegCount As Integer
   Dim FstRegT(1) As Integer
   Dim FstRegV(1) As Variant
   FstRegT(0) = 8: FstRegV(0) = "0"
   FstRegT(1) = 0: FstRegV(1) = "Region"
   ' to combine all regions
   On Error Resume Next
   ThisDrawing.SelectionSets("FstRegs_0").Delete
   On Error GoTo 0
   Set FstRegs = ThisDrawing.SelectionSets.Add("FstRegs_0")
   FstRegs.Select acSelectionSetAll, , , FstRegT, FstRegV
   FstRegCount = FstRegs.Count
   ReDim DifRegs(FstRegCount - 1)
   Dim Thefirst As AcadRegion
   Dim Thesecond As AcadRegion
   For FstObjL = 0 To FstRegCount - 1
       Set DifRegs(FstObjL) = FstRegs.Item(FstObjL)
       If FstObjL <> 0 Then
           Set Thefirst = DifRegs(0)
           Set Thesecond = DifRegs(FstObjL)
           Thefirst.Boolean acUnion, Thesecond
       End If
   Next FstObjL
   Thefirst.Update
   ThisDrawing.Regen acAllViewports
   'explode region in to lines
   Dim ExplodedRegion As Variant
   Dim ExplRegCount As Integer

   ExplodedRegion = Thefirst.Explode

   ExplRegCount = UBound(ExplodedRegion)
   'retrieve coords to make perimeter line
   Dim ExRegL As Integer
   Dim ExRegNumCoords As Integer
   ExRegNumCoords = ((ExplRegCount + 1) * 2) + 1
   Dim ExRegCoords() As Double
   Dim RegLine As AcadLine
   ReDim ExRegCoords(ExRegNumCoords)
   For ExRegL = 0 To ExplRegCount
       Set RegLine = ExplodedRegion(ExRegL)
       ExRegCoords(ExRegL * 2) = RegLine.StartPoint(0)
       ExRegCoords(ExRegL * 2 + 1) = RegLine.StartPoint(1)
       If ExRegL = ExplRegCount Then
           ExRegCoords(ExRegL * 2 + 2) = RegLine.EndPoint(0)
           ExRegCoords(ExRegL * 2 + 3) = RegLine.EndPoint(1)
       End If
   Next ExRegL

   'Make the perimeter line
   Dim PerLine As AcadLWPolyline

   Set PerLine = ThisDrawing.ModelSpace.AddLightWeightPolyline(ExRegCoords)
   PerLine.color = acYellow
End Sub

Link to comment
Share on other sites

  • 4 years later...

Hi Andresig,

 

Excellent post. This was well stated and documented, and yet there are no replies. I have been looking for this exact same solution for some time, so I am also trying to solve it. Let me know if you have found a solution, or if anyone else wants to chime in here, I would also appreciate it.

 

Thanks,

Josh

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...