从Excel中复制单元格中的文本，将其粘贴到Autocad中
您好我想从excel复制一个值/文本到单元格中，并将其粘贴到现有的特定mtxt中。DWG档案。
我已经通过复制和粘贴完成了，但是由于要粘贴的单元格太多，所以效果不佳。
有人知道vba(宏)脚本可以帮助我解决问题吗？
PS:
我的一个单元格条目应该被复制到D5中，而mtxt在autocad中的坐标是(17，46 15，03 0，000)
这两个文件位于同一文件夹中
谢谢
**** Hidden Message ***** 试试这个代码，不要我的，虽然
看到这个例程中的注释
Option Explicit
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Public mtextStr As String
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Public Sub testCopyCell()
ExcelTemplateFunction ThisDrawing.GetVariable("dwgprefix") & "MyFile.xlsx" '<~~ change excel file path
Dim pt(2) As Double
pt(0) = 100#: pt(1) = 100#: pt(2) = 0#: '<~~ change point coordinates
Dim oMtext As AcadMText
Set oMtext = ThisDrawing.ModelSpace.AddMText(pt, 0#, mtextStr)
ThisDrawing.SendCommand ("_copybase (list 100.0 100.0 0.0) _L ") & vbCr
ThisDrawing.SendCommand ("(command)")
oMtext.Delete
End Sub
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
' borrowed from Desmond Oshiwambo
' http://desmondoshiwambo.wordpress.com/2013/06/17/template-function-to-connect-to-excel-from-access-using-vba-automation/
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Public Function ExcelTemplateFunction(xlFileName As String)
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)
With xlWS
Set xlRange = .Range("D5") '<~~ change cell address
mtextStr = CStr(xlRange.Value)
End With
'Show Excel
xlApp.Visible = True
ExcelTemplateFunction = True
GoTo CleanExit
ErrorHandler:
Debug.Print Err.Description
ExcelTemplateFunction = False
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
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
页:
[1]