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.
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 ''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''