在命令行中粘贴文本
你好我从a复制文本。txt文件。
在AutoCad中，我用鼠标右键单击命令行，然后
单击insert（Einfügen），将在图形中创建所有矩形。
是否有方法仅在excel中复制文本，并将其带到AutoCad中
SendCommand命令？
谢谢你的帮助。
https://ibb.co/zXn36Y8 这将首先检查AutoCAD是否打开，更改为模型空间，并将选定的每个单元格的文本发送到命令行。
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
您可以编写一个用于excel的矩形sub，只需传递4个角值x1 y1 x2 y2等。查看“pline”的结尾。我不是使用这种方法的专家，只是为了看看我能做些什么。
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
嗨，mhupp，嗨，bigal，
谢谢你的回答，慢慢来。
@我现在正在和医生一起做。send命令，将它们逐个单元格带到AutoCad。
在复制和粘贴到命令行的步骤中，在我看来，它比逐个单元格读取要快。
（手工制作）
我以为命令行中有一个insert命令可以从剪贴板粘贴
@比加尔
谢谢你的计划，有很多对我有用的方法。
选择范围Ctrl+C，单击Autocad命令行Ctrl+V不知道有多简单，啊，但我现在记得，如果某个任务不起作用，则会出现问题。选择列excel，单击编辑、特殊粘贴、脚本文本。
页:
[1]