Convert Series of Lines and Arcs to Plines

[andrewk15]

I have a series of lines and arcs that are intersecting. I need to be able to convert these to a Pline and set a width to this pline using vba. The width needs to reference a cell in excel.

Pseudo Code:

Select All Lines and Arcs

Convert Selected Lines and Arcs to one Pline

PEDIT --> Width --> Sheet1.Cells.(Width)

I'm fairly new at using VBA with AutoCAD. I feel like this shouldn't be that difficult to do but I cannot find anything so far. Any help would be greatly appreciated.

[fixo]

Methink you need to learn a bit more about VBA language,

say try from there http://www.afralisp.net/visual-basic-for-applications/

For this particular task try this one from my oldies

Option Explicit

''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''

' borrowed from Desmond Oshiwambo
' http://desmondoshiwambo.wordpress.com/2013/06/17/template-function-to-connect-to-excel-from-access-u...

''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Public Function GetExcelCellValue(xlFileName As String, xlCellAddress As String) As Variant
Dim cellValue As Variant
On Error GoTo ErrorHandler
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim xlRange As Object
Set xlApp = CreateObject("Excel.Application")
'Set xlWB = xlApp.Workbooks.Add
Set xlWB = xlApp.Workbooks.Open(xlFileName, False)
Set xlWS = xlWB.Worksheets(1) ' first sheet (or use "Sheet1" instead)
With xlWS
Set xlRange = .Range(xlCellAddress)
cellValue = xlRange.Value
End With
'Show Excel
xlApp.Visible = True
GetExcelCellValue = cellValue
GoTo CleanExit
ErrorHandler:
Debug.Print Err.Description
GetExcelCellValue = Nothing
CleanExit:
'Close Excel - do not save
If Not (xlWB Is Nothing) Then
xlWB.Close False
'Close workbook (don't save)
If Not (xlApp Is Nothing) Then
xlApp.Quit      'Quit
End If
End If
'Destroy objects

Set xlRange = Nothing
Set xlWS = Nothing
Set xlWB = Nothing
Set xlApp = Nothing

End Function
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Sub JoinLines()

Dim oSsets As AcadSelectionSets
Dim oSset As AcadSelectionSet
Dim fType(0) As Integer
Dim fData(0) As Variant
Dim varPt As Variant
Dim oLine As AcadEntity
Dim oEnt As AcadEntity
Dim commStr As String
Dim intPt As Variant


On Error GoTo Error_Trapp

Dim pwid As Variant

pwid = GetExcelCellValue(ThisDrawing.GetVariable("dwgprefix") & "Test.xls", "a20") '<~~ change full path to Excel file and cell address

Dim strWidth As String

strWidth = Replace(CStr(pwid), ",", ".", 1, -1, vbTextCompare)

MsgBox "Select lines and arcs on screen"

Set oSsets = ThisDrawing.SelectionSets

fType(0) = 0: fData(0) = "LINE,ARC"

For Each oSset In oSsets

If oSset.Name = "LineSet" Then

oSset.Delete

End If

Next

Set oSset = oSsets.Add("LineSset")

oSset.SelectOnScreen fType, fData

ThisDrawing.SetVariable "PEDITACCEPT", 1

commStr = "_PEDIT _M"
 
For Each oLine In oSset

commStr = commStr & " (handent " & Chr(34) & oLine.Handle & Chr(34) & ")"

Next oLine

commStr = commStr & vbCr & " _Join 0.0000 "

commStr = commStr & "_Width " & strWidth & vbCr & vbCr

ThisDrawing.SendCommand commStr

'SendKeys "{ESC}"

oSset.Delete

Set oSset = Nothing

Error_Trapp:

If Err.Number <> 0 Then

MsgBox Err.Number & Err.Description

End If

End Sub
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''