Рисование в Акаде через Excel

Private Sub CommandButton1_Click()
End Sub

Private Sub CommandButton1_Click()
Dim vbeObj As Object, check As Boolean
Dim varRefs As Object, itmRef As Object
check = False
Set vbeObj = ThisWorkbook.VBProject.VBE
Set varRefs = vbeObj.ActiveVBProject.References
For Each itmRef In varRefs
If itmRef.Description Like "AutoCAD 200*" Then
check = True
Exit For
End If
Next
If check = False Then
MsgBox "Must be set reference to" & vbCr & _
       Chr(34) & "AutoCAD 200x Type Library" & Chr(34) & " before" & vbCr & _
       "Go to VBEditor-Tools->References" & vbCr & _
       "Set reference to this library", vbExclamation
       Exit Sub
       Else
       frmTest.Show
       End If
End Sub

Option Explicit
Dim ptColl As New Collection
Dim itm As Variant
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Private Sub CommandButton1_Click()
     On Error GoTo Err_Control
     Err.Clear
     Dim rng As Range
     Set rng = Sheets("Sheet1").Range("A2:B1201")
     rng.Select
     Dim lngRow As Long, _
         lngCol As Long, _
         dblPt(1) As Double, _
         varPt(1) As Double
     For lngRow = 1 To rng.Rows.Count
          dblPt(0) = CDbl(Replace(rng.Cells(lngRow, 1), ".", ","))
          dblPt(1) = CDbl(Replace(rng.Cells(lngRow, 2), ".", ","))
          ptColl.Add dblPt
     Next lngRow
     ' ____________________________________
     Dim oldFileName As String
     Dim acApp As AcadApplication
     Dim aDoc As AcadDocument
     Dim i As Long
     Dim ExcCap As String
     ExcCap = Application.Caption
     oldFileName = Application _
                   .GetOpenFilename("AutoCAD Drawings (*.dwg), *.dwg", 1, , , False)
     If oldFileName = "" Then Exit Sub
     ' ____________________________________
     Set acApp = CreateObject("Autocad.Application")
     acApp.Visible = True
     acApp.WindowState = acMax
     Set aDoc = acApp.Documents.Open(oldFileName, False)
     Dim newFileName As String
     newFileName = ThisWorkbook.Path & "\Test_Copy.dwg"
     aDoc.Application.ZoomExtents
     aDoc.Activate
     SetFocus aDoc.hwnd
     ' ____________________________________
     Dim cpt(2) As Double
     With aDoc.ModelSpace
          For Each itm In ptColl
               cpt(0) = CDbl(itm(0))
               cpt(1) = CDbl(itm(1))
               cpt(2) = 0#
               .AddCircle cpt, 0.25
          Next
     End With
     ' ____________________________________
     aDoc.Regen acActiveViewport
     aDoc.SaveAs newFileName, ac2004_dwg
     acApp.Quit
     Set aDoc = Nothing
     Set acApp = Nothing
     AppActivate ExcCap, True
     SetFocus Application.hwnd
     ' ____________________________________
     newFileName = Left(newFileName, (Len(newFileName) - 4))
     ActiveSheet.Cells(ActiveCell.Row, 3).Value = newFileName
     ActiveSheet.Cells(ActiveCell.Row, 3).Select
     CommandButton2.SetFocus
     CommandButton2.ForeColor = vbRed
     ' ____________________________________
Err_Control:
     If Err Then
          MsgBox "Error " & Err.Number
          acApp.Quit
          Set aDoc = Nothing
          Set acApp = Nothing
     Else
          MsgBox "Drawing " & newFileName & " was saved" & vbCr & _
                 "in the current folder", vbInformation, "Action Info"
     End If
End Sub
Private Sub CommandButton2_Click()
     Unload Me
End Sub