Polyline offset both sides and join and close polylines to one area

[l_dabrowskiUZAN4]

Hello. I'm trying to make an automatic zone designator on both sides of the polyline. The macro is to select an existing polyline, offset it to both sides, draw closing polyline segments, and then combine all 4 polyline segments into one object. I'm stuck, I can't assign an array with polylines to the Selection set and then to the group. And then by PEDIT to join it.  Please help, I don't know why the error occurs...

Sub Example_Offset()
    ' This example offset polyline in bouth sides and close.
  
    
    Dim ssetObj As AcadSelectionSet
    Dim oPolyline As AcadLWPolyline
    Dim oGrupa As AcadGroup
    Dim Dlugosc As String
    Dim Uchwyt As String
    Dim tbWsp As Variant
    Dim tbP(0 To 3) As Double
    Dim Off As Double
    
    Dim oBokGora As AcadLWPolyline
    Dim oBokDol As AcadLWPolyline
    Dim oBokPrawy As AcadLWPolyline
    Dim oBokLewy As AcadLWPolyline
    
    Dim oOff As Variant
    Dim tbStrefa(0 To 3) As Variant
    Dim sGrupaNazwa As String
    Dim sName As String
    
    
    AppActivate ThisDrawing.Application.Caption
    
    ' input offset distance data
    Off = InputBox("Your offset distance", , "5")
       
    
    ' Create the selection set
    sName = "SS1"
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets.Add(sName)
    If Err.Number <> 0 Then
        Set ssetObj = ThisDrawing.SelectionSets.Item(sName)
        AddSelectionSet.Clear
    End If
    On Error GoTo 0
    ' Add objects (polyline) to a selection set by prompting user to select on the screen
    ssetObj.SelectOnScreen
    
    Set oPolyline = ThisDrawing.SelectionSets(sName).Item(0)
    
    Dlugosc = oPolyline.Length
    Uchwyt = oPolyline.Handle
    MsgBox "Length is: " & Dlugosc
    MsgBox "Handle is: " & Uchwyt
    
    oOff = oPolyline.Offset(Off * (-1))
    ' set first polyline to variable
    Set oBokGora = oOff(0)
    oBokGora.Layer = "0"
    tbP(0) = oBokGora.Coordinates(0)
    tbP(1) = oBokGora.Coordinates(1)
    
    
    oOff = oPolyline.Offset(Off * 1)
    ' set second polyline to variable
    Set oBokDol = oOff(0)
    oBokDol.Layer = "0"
    tbP(2) = oBokDol.Coordinates(0)
    tbP(3) = oBokDol.Coordinates(1)
    
    ' set third polyline to variable
    Set oBokLewy = ThisDrawing.ModelSpace.AddLightWeightPolyline(tbP)
    oBokLewy.Layer = "0"
    
    tbWsp = oBokGora.Coordinates
    tbP(0) = oBokGora.Coordinates(UBound(tbWsp) - 1)
    tbP(1) = oBokGora.Coordinates(UBound(tbWsp))
    
    tbWsp = oBokDol.Coordinates
    tbP(2) = oBokDol.Coordinates(UBound(tbWsp) - 1)
    tbP(3) = oBokDol.Coordinates(UBound(tbWsp))
    
    ' set fourth polyline to variable
    Set oBokPrawy = ThisDrawing.ModelSpace.AddLightWeightPolyline(tbP)
    oBokPrawy.Layer = "0"
    
    ThisDrawing.Regen (acAllViewports)
    
    ' set array of polylines
    Set tbStrefa(0) = oBokGora
    Set tbStrefa(1) = oBokDol
    Set tbStrefa(2) = oBokPrawy
    Set tbStrefa(3) = oBokLewy

    ThisDrawing.SelectionSets(sName).Delete
    
    sName = "SS2"
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets.Add(sName)
    If Err.Number <> 0 Then
        Set ssetObj = ThisDrawing.SelectionSets.Item(sName)
        AddSelectionSet.Clear
    End If
    On Error GoTo 0
    ' add items to selection  set from array
    ssetObj.AddItems tbStrefa
        
    sName = "Group1"
    Set oGrupa = ThisDrawing.Groups.Add(sName)
    
    ' add items to group from selection set
    oGrupa.AppendItems ssetObj
    sGrupaNazwa = oGrupa.Name
    
    ' in english acad version "M"-multiple, "J"-join, "G"-group 
    ' run pedit command to join polylines
    ThisDrawing.SendCommand "_PEDIT" & vbCr & "M" & vbCr & "G" & vbCr & sName & vbCr & vbCr & "J" & vbCr & "0.0" & vbCr & vbCr

    ' deleting group and selection set
   oGrupa.Delete
   ssetObj.Delete
   ThisDrawing.Regen (acAllViewports)
    
    
End Sub

[Ed__Jobe · Accepted solution]

What you are trying to create is called a "buffer". If you install Map 3D, it has tools for creating a buffer. I searched and found several lisp's that create a buffer, like this one.

[norman.yuan · Accepted solution]

As @Ed__Jobe suggested, you can find some existing tool/code that does what you want. But if you need to do it in VBA code, you really should use the COM API to construct the closed polyline, rather then using built-in command with SendCommand, because the PE command is meant for user to use interactively.

Using code COM API to construct the wanted polyline is quite simple: you simply combined both of the offset polylines' coordinate together properly. Following the the code to do it (for simplicity, I assume the polyline to be offsetted only has straight segments. If not, you need to retrieve the offset polylines' bulges at each vertex and apply the bulges properly when combine the 2 polylines together):

Option Explicit

Public Sub PolylineOffsetTest()
    
    Dim poly As AcadLWPolyline
    Dim pt As Variant
    Dim ent As AcadEntity
    Dim offset As Double
    Dim wrapPolyline As AcadLWPolyline
    
    On Error Resume Next
    ThisDrawing.Utility.GetEntity ent, pt, vbCr & "Select a polyline:"
    If ent Is Nothing Then Exit Sub
    
    Set poly = ent
    
    
    offset = ThisDrawing.Utility.GetReal(vbCr & "Enter offset value:")
    If Err.Number <> 0 Then Exit Sub
    
    Set wrapPolyline = CreateWrapPolyline(poly, offset)
    If wrapPolyline Is Nothing Then
        MsgBox "Cannot create wrap polyline"
    Else
        wrapPolyline.color = acYellow
        wrapPolyline.Update
    End If
    
End Sub

Private Function CreateWrapPolyline(poly As AcadLWPolyline, offset As Double) As AcadLWPolyline
    
    Dim offsetObjects As Variant
    Dim offsetPoly1 As AcadLWPolyline
    Dim offsetPoly2 As AcadLWPolyline
    
    offsetObjects = poly.offset(offset)
    If UBound(offsetObjects) >= 0 Then
        Set offsetPoly1 = offsetObjects(0)
    End If
    
    offsetObjects = poly.offset(offset * -1)
    If UBound(offsetObjects) >= 0 Then
        Set offsetPoly2 = offsetObjects(0)
    End If
    
    If offsetPoly1 Is Nothing Or offsetPoly2 Is Nothing Then
        Set CreateWrapPolyline = Nothing
        Exit Function
    End If
    
    Dim wrapPolyline As AcadLWPolyline
    Set wrapPolyline = CreateCombinedPolyline(offsetPoly1, offsetPoly2)
    offsetPoly1.Delete
    offsetPoly2.Delete
    
    Set CreateWrapPolyline = wrapPolyline
    
End Function

Private Function CreateCombinedPolyline(poly1 As AcadLWPolyline, poly2 As AcadLWPolyline)

    Dim newPoly As AcadLWPolyline
    Dim coords() As Double
    Dim coordCount As Integer
    Dim i As Integer
    
    coordCount = UBound(poly1.Coordinates) + 2 + UBound(poly2.Coordinates)
    
    ReDim coords(UBound(poly1.Coordinates))
    For i = 0 To UBound(poly1.Coordinates)
        coords(i) = poly1.Coordinates(i)
    Next
    
    Dim index As Integer
    Dim m As Integer
    Dim n As Integer
    Dim vertCount As Integer
    
    vertCount = (UBound(poly2.Coordinates) + 1) / 2
    m = UBound(poly1.Coordinates) + 1
    n = vertCount
    
    ReDim Preserve coords(coordCount - 1)
    For i = vertCount To 1 Step -1
    
        j = n * 2 - 2
        coords(m) = poly2.Coordinates(j)
        m = m + 1
        
        j = n * 2 - 1
        coords(m) = poly2.Coordinates(j)
        m = m + 1
        
        n = n - 1
        
    Next
    
    Set newPoly = ThisDrawing.ModelSpace.AddLightWeightPolyline(coords)
    newPoly.Closed = True
    Set CreateCombinedPolyline = newPoly
    
End Function

See the attached video for the code execution:

[l_dabrowskiUZAN4]

Thank you @Ed__Jobe Ready-made LISPs often solve problems. I only know how to run ready-made LISP in VBA code. I don't know LISP coding. Good idea with Maps 3D. I also work with Xref map attachments. Maybe there are tools out there that would make my job easier.

Thank you @norman.yuan, it works great. I only have straight sections, but it's good to know about the possibility of modifying them for rounding.  This code will also be useful for my further macros.