[编程交流] 在命令行中粘贴文本

Sub CMDSend()
' Keyboard Shortcut: Ctrl+Shift+P
    Dim app As Object, Doc As Object, Cmd As String, rng As Range, i As Long
    On Error Resume Next
    Set App = GetObject(, "AutoCAD.Application")
    If app Is Nothing Then
        MsgBox "AutoCAD isns't Open!", vbCritical, "Input Error"
        Exit Sub
    End If
    Set Doc = app.ActiveDocument
    'Check if the active space is paper space and change it to model space.
    If Doc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
       Doc.ActiveSpace = 1      '1 = acModelSpace in early binding
    End If
    Set rng = Selection  'set a range of cells
    For Each rng In Selection.Cells
      If rng.Value > 0 Then  'if cell isn't blank send command
         Cmd = rng.Value
         Doc.SendCommand Cmd & vbCr
      End If
    Next rng
End Sub

  
Public Sub Opendwg()
 
    Dim acadApp As Object
    Dim acadDoc As Object
 'Check if AutoCAD application is open. If is not opened create a new instance and make it visible.
    On Error Resume Next
    Set acadApp = GetObject(, "AutoCAD.Application")
    If acadApp Is Nothing Then
        Set acadApp = CreateObject("AutoCAD.Application")
        acadApp.Visible = True
    End If
 
    'Check (again) if there is an AutoCAD object.
    If acadApp Is Nothing Then
        MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
        Exit Sub
    End If
    On Error GoTo 0
 
    'If there is no active drawing create a new one.
    On Error Resume Next
    Set acadDoc = acadApp.ActiveDocument
    If acadDoc Is Nothing Then
        Set acadDoc = acadApp.Documents.Add
    End If
    On Error GoTo 0
  
    'Check if the active space is paper space and change it to model space.
    If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
        acadDoc.ActiveSpace = 1     '1 = acModelSpace in early binding
    End If
 End Sub
 
Public Sub addline(x1, y1, z1, x2, y2, z2)
  
 ' Create the line in model space
    'Dim acadApp As Object
    'Dim acadDoc As Object
    Set acadApp = GetObject(, "AutoCAD.Application")
    Set acadDoc = acadApp.ActiveDocument
    Dim startpoint(0 To 2) As Double
    Dim endpoint(0 To 2) As Double
    Dim lineobj As Object
    startpoint(0) = x1: startpoint(1) = y1: startpoint(2) = z1
    endpoint(0) = x2: endpoint(1) = y2: endpoint(2) = z2
    Set lineobj = acadDoc.ModelSpace.addline(startpoint, endpoint)
    acadApp.ZoomExtents
    
    End Sub
    Public Sub addcirc(x1, y1, z1, rad)
  
 ' Create the circle in model space
   ' Dim acadApp As Object
   ' Dim acadDoc As Object
    Set acadApp = GetObject(, "AutoCAD.Application")
    Set acadDoc = acadApp.ActiveDocument
    Dim cenpoint(0 To 2) As Double
   
    Dim circobj As Object
   cenpoint(0) = x1: cenpoint(1) = y1: cenpoint(2) = z1
    Set circobj = acadDoc.ModelSpace.addcircle(cenpoint, rad)
    acadApp.ZoomExtents
    
    End Sub
    
    
    Sub addpoly(cords, col)
    
    ' Dim acadApp As Object
    ' Dim acadDoc As Object
    Set acadApp = GetObject(, "AutoCAD.Application")
    Set acadDoc = acadApp.ActiveDocument
    Dim oPline As Object
    
' add pline to Modelspace
Set oPline = acadDoc.ModelSpace.AddLightWeightPolyline(cords)
oPline.Color = col
End Sub
   
    Sub alan1()
    
   
' This example adds a line in model space
' Define the start and end points for the line
   
    px1 = 1
    px2 = 5
    py1 = 1
    py2 = 5
    pz1 = 0
    pz2 = 0
    
Call addline(px1, py1, pz1, px2, py2, pz2)
End Sub
 Sub alan2()
 
    px1 = 1
    py1 = 1
    pz1 = 0
    Radius = 8.5
 
 Call addcirc(px1, py1, pz1, Radius)
 End Sub
 
 Sub alan3()
 'Dim coords(0 To n) As Double
 Dim coords(0 To 5) As Double
 coords(0) = -6: coords(1) = 1:
 coords(2) = 3: coords(3) = 5:
 coords(4) = 7.55: coords(5) = 6.25:
 
 col = 1
    
 Call addpoly(coords, col)
 End Sub