Add this code to .xlsm file,
see my poor explanation within the code
Option Explicit
' require references to:
'Windows Script Host Object model
'AutoCAD 20XX Type Library
'AutoCAD Focus Control for VBA Type Library (omit this if you do not show the result on the screen)
'in VBA editor -> Tools -> Options -> General -> Error Trapping box -> check "Break on Unhandled Errors"
Function acadVerNum() As String
Dim verNum As String
verNum = "HKEY_CLASSES_ROOT\AutoCAD.Drawing\CurVer\"
Dim wsh As Object
On Error GoTo ErrorHandler
'access Windows scripting
Set wsh = CreateObject("WScript.Shell")
'read key from registry
Dim resKey As String
resKey = wsh.RegRead(verNum)
acadVerNum = Right(resKey, 2)
Exit Function
ErrorHandler:
'key was not found
acadVerNum = ""
End Function
Public Sub testOpenAutoCAD()
Dim xlsheet As Worksheet
Dim xlRange As Range
Set xlsheet = ThisWorkbook.Worksheets.Item(2)
' define Excel range by address
Set xlRange = xlsheet.Range("A1:B10")
' you can use instead the previous selected Excel range this way:
'Set xlRange = Selection
Dim pts As Variant
pts = xlRange.Value
' you can use instead this expression too:
' pts = xlRange.Value2
Dim n As Integer, i As Integer, j As Integer
n = UBound(pts) * 2 - 1
ReDim coords(0 To n) As Double
For i = 1 To UBound(pts)
coords(j) = CDbl(pts(i, 1))
j = j + 1
coords(j) = CDbl(pts(i, 2))
j = j + 1
Next i
Dim acad As AutoCAD.AcadApplication
Dim appNum As String
On Error GoTo ErrorHandler
appNum = acadVerNum
If appNum = "" Then
MsgBox "Could not read registry."
Exit Sub
End If
On Error Resume Next
Set acad = GetObject(, "Autocad.Application." & appNum)
If Err.Number = 429 Then
Err.Clear
On Error GoTo 0
Set acad = CreateObject("Autocad.Application." & appNum)
If Err Then
Exit Sub
End If
End If
acad.WindowState = acMax
Dim adoc As AutoCAD.AcadDocument
Set adoc = acad.ActiveDocument
Dim aspace As AutoCAD.AcadBlock
Set aspace = adoc.ModelSpace
Dim lw As Double
lw = acLnWt030
Dim oPline As AcadLWPolyline
' add pline to Modelspace
Set oPline = aspace.AddLightWeightPolyline(coords)
' do some changes here, e.g.:
oPline.Lineweight = lw
oPline.Color = acGreen
adoc.SetVariable "lwdisplay", 1
ZoomExtents
Set aspace = Nothing
Set adoc = Nothing
Set acad = Nothing
ErrorHandler:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
_____________________________________
C6309D9E0751D165D0934D0621DFF27919
