how to do multiple Lines to Polyline with help of VBA

[Anonymous]

Is there any easy way to conver multiple line to polylines with help of Lisp files as well i want those polyline to join each other if possible?

1st method

To convert LINE to Polyline, you need to use the PEDIT command, which makes it more complicated than doing the opposite operation. Here is how to do it: Type PEDIT and Press ENTER. Type M and Press Enter

[joselggalan]

Try this

Step 1. Load the lisp file "LinToPol.lsp" from VBA:

It may be like this example:

Public Function InicializaDWG() As Boolean
 Dim FileName As String
 
 Set ActD = ActiveDocument
 
 '---------------------------------------------------------
 Dim loaded As String
 FileName = GetPathThisProjectVBA(True) & "LinToPol.lsp"
 'Cargamos la funcion de VisualLisp "LinToPol"
 ActD.SetVariable "users5", ""
 ActiveDocument.SendCommand "(Load " & """" & FileName & """" & ")" & vbCr
 If ActD.GetVariable("users5") = "LinToPol-Loaded" Then
  InicializaDWG = True
  ActD.SetVariable "users5", ""
  Else: Exit Function
 End If
 '---------------------------------------------------------
 
 ZoomExtents
  
End Function

You will have to change "GetPathThisProjectVBA (True)" by your path where you save "LinToPol.lsp"

Example use function in VBA:

If Not InicializaDWG() Then
   MsgBox "Could not load resource file   " & vbCr & vbCr & _
         """LinToPol.lsp""", vbOKOnly + vbExclamation, "AppsAc2xxx"
   Exit Sub
 End If

Lisp file "LinToPol.lsp":

(vl-load-com) ;;abrir Activex
(setvar "users5" "LinToPol-Loaded")
;;----------------------------------------------------------
;;Convertir Lineas en Polilineas para ejecutarlo despues via SendCommand de VBA
(defun LinToPol2 (NameSSset aprox / acadObject acadDocument sstmp ObjEnt Lines filter)
 (setq TmpLayer "$TmpLayerJoinPol$")
 (setvar "CMDECHO" 0)
 (if (null aprox) (setq Aprox 0.01))
 (setq acadObject (vlax-get-acad-object))
 (setq acadDocument (vla-get-ActiveDocument acadObject))
 (cond
  ((and (setq sstmp (vl-catch-all-apply (function vla-item)(list (vla-get-selectionsets acadDocument) NameSSset)))
	(not (vl-catch-all-error-p sstmp)))
   ;;Capa Temporal para crear las polilineas
   (setq ObjLay (vla-add (vla-get-layers acadDocument) TmpLayer))
   (vla-put-lock ObjLay :vlax-false)
   (vla-put-color ObjLay 50)
   (vla-put-description ObjLay "Capa Temporal de Polilineas")
   ;;Selecction set creado desde VBA:
   (vlax-for ObjEnt sstmp
    (vla-put-layer ObjEnt TmpLayer)
   );c.vlax-for
   (if (setq SelTmpLayer (ssget "X" (list (cons 8 TmpLayer))))
    (if (= (getvar "PEDITACCEPT") 0)
     (command "_.PEDIT" "_M" SelTmpLayer "" "_Y" "_J" "_J" "_E" Aprox "")
     (command "_.PEDIT" "_M" SelTmpLayer "" "_J" "_J" "_E" Aprox "")
    );c.if
   );c.if
  )
 );c.cond
 (princ)
);c.defun
(princ)

 Step 2: Procedure in VBA "Function LinToPoly" :

Public Function LinToPoly(ByVal LayerLines As String) As Boolean
 Dim Code() As Variant
 Dim Gcode() As Integer
 Dim Lineas As AcadSelectionSet
 Dim NameSSset As String
 
 Set ActD = ActiveDocument
 Set MsP = ActD.ModelSpace
 NameSSset = "LinesOnLayer"
 Set Lineas = CreateSelectionSet(NameSSset)
 
 ReDim Code(0 To 1): ReDim Gcode(0 To 1)
 Gcode(0) = 0: Code(0) = "LINE"
 Gcode(1) = 8: Code(1) = LayerLines
 Call Lineas.Select(acSelectionSetAll, , , Gcode, Code)
 
 If Lineas.Count > 0 Then
  Dim LispSTR As String
  Dim Ajuste As Double
 
  Ajuste = 0.1
  '_____________________________________________
  'Comienza Proceso de Conversión
  LispSTR = "(LinToPol2 " & """" & NameSSset & """" & " " & DoubleToStr(Ajuste, 2) & ")" & vbCr
  'Llamamos a la funcion de VisualLisp "LinToPol"
  ActiveDocument.SendCommand LispSTR
  '_____________________________________________
  'Comprobamos si se convirtiron objetos en polilineas
  Dim PLineas As AcadSelectionSet
  Dim PlineTmp As AcadLWPolyline
  
  Set PLineas = CreateSelectionSet("PlinesJoin")
  ReDim Code(0 To 1): ReDim Gcode(0 To 1)
  Gcode(0) = 0: Code(0) = "LWPOLYLINE"
  Gcode(1) = 8: Code(1) = "$TmpLayerJoinPol$"
  PLineas.Select acSelectionSetAll, , , Gcode, Code
  
  If PLineas.Count > 0 Then
   For Each PlineTmp In PLineas
    PlineTmp.Layer = LayerLines
   Next PlineTmp
   ActD.Layers("$TmpLayerJoinPol$").Delete
   LinToPoly = True
   'ActD.Utility.Prompt vbCr & "Nº de polilineas generadas: [" & PLineas.Count & "]." & vbCr
   Else
   ActD.Utility.Prompt vbCr & "No se generaron Polilineas en la capa: [" & LayerLines & "]." & vbCr
  End If
  
  Else 'Lineas.Count > 0
   ActD.Utility.Prompt vbCr & "No se encontraron Lineas en la capa: [" & LayerLines & "]." & vbCr
 End If

Step 3: Use the "LinToPoly" function in VBA:

LinToPoly "MyLayerLines"
or
Call LinToPoly ("MyLayerLines")

To consider:

ActD and MsP variables are declared as global in my code, in a startup module:

Option Explicit
Public ActD As AcadDocument
Public MsP As AcadModelSpace

You can modify the code for your needs.

regards

[Anonymous]

i want to try your code but iam biginner to VBA in AutoCAD.

I am Kindly Requesting you if possible give me Drawing file and Lisp file or else make a small video which i can understand how to use your code.

Thanks IN Advance 🙂

[Kent1Cooper]

Another AutoLisp approach is PolylineJoin.lsp with its PJ command, available here.  See the comments there [and earlier in that thread] and in the file.  A Search will find other similar threads.

[joselggalan]

santosh.loka, Kent1Cooper,

I thought the idea was to convert polylines from VBA, sorry for my mistake ..

[Kent1Cooper · Accepted solution]

---

@joselggalan wrote:

.... 

I thought the idea was to convert polylines from VBA, sorry for my mistake ..

---

Not a mistake, given the Subject line, but the first sentence in Post 1 talks about Lisp, so apparently they're open to either [or mis-stated what they want in one place or the other].

[Anonymous]

Great Lisp Provided By @Kent1Cooper