VB如何将EXCEL中指定的几行表格粘贴至CAD文件中指定的框框内？ - 编程论坛

#2

lianyicq2015-03-12 10:43

帮你开一个头，尽量自己完善

程序代码：

Dim EXAPP As Excel.Application
Dim WB As Excel.Workbook
Dim sht As Excel.Worksheet
Dim AApp As AcadApplication
Dim ADWG As AcadDocument
Private Sub Form_Load()
Set EXAPP = CreateObject("excel.application")
Set WB = EXAPP.Workbooks.Open("c:\test.xlsx")
Set sht = WB.Worksheets("Sheet1")
Set AApp = CreateObject("Autocad.Application")
Set ADWG = AApp.documents.Open("c:\drawing1.dwg")
Range("h7", "m9").Select
Range("h7", "m9").Copy
ADWG.SendCommand "_pasteclip" & vbCr & "0,0" & vbCr
ADWG.Save
Form1.Caption = "OK"
End Sub
Private Sub Form_Unload(Cancel As Integer)
ADWG.Close
Set ADWG = Nothing
Set AApp = Nothing
WB.Close
Set sht = Nothing
Set WB = Nothing
Set EXAPP = Nothing
End Sub

可以实现选择excel文件指定区域并复制到剪贴板，再粘贴到CAD文件指定位置。

#3

xingming0222015-03-12 15:22

回复 2楼 lianyicq

非常感谢~~~~

#4

xingming0222015-03-13 14:42

回复 2楼 lianyicq

你好，我按照您给的思路弄了一下，可以将EXCEL插入到CAD中了，但是该如何对
插入后的EXCEL进行移位和缩放至红色框框内？也就是保证EXCEL边框和红色边框重合。麻烦再给指导下。

#5

lianyicq2015-03-14 14:08

回复 4楼 xingming022

那就再帮你进一步，
在CAD创建的框，肯定要有和其它图形区别特征，才能被代码搜索到。比如颜色、线型、线宽等。假设这个框在CAD中由RECTANGLE命令创建，线宽设为1.06mm。
就以1.06mm为特征找到它，找到它后再获得框左下角坐标，将坐标输入到sendcommand命令中。代码调整后如下：

程序代码：

Dim ADWG As AcadDocument
Dim i As Long
Dim parameter As Variant
Dim CoordString As String

Private Sub Form_Load()
Me.Show
Set EXAPP = CreateObject("excel.application")
Set WB = EXAPP.Workbooks.Open("c:\test.xls")
Set sht = WB.Worksheets("Sheet1")
Set AApp = CreateObject("Autocad.Application")
Set ADWG = AApp.documents.Open("c:\drawing1.dwg")
Range("h7", "m9").Select
Range("h7", "m9").Copy
For i = 0 To AApp.ActiveDocument.ModelSpace.Count - 1
  If AApp.ActiveDocument.ModelSpace(i).Lineweight = 106 Then
     parameter = AApp.ActiveDocument.ModelSpace(i).Coordinates
     Exit For
  End If
Next
CoordString = parameter(0) & "," & parameter(1)
ADWG.SendCommand "_pasteclip" & vbCr & CoordString & vbCr
ADWG.Save
Form1.Caption = "OK"
End Sub
Private Sub Form_Unload(Cancel As Integer)
ADWG.Close
Set ADWG = Nothing
AApp.Quit
Set AApp = Nothing
WB.Close
Set sht = Nothing
Set WB = Nothing
Set EXAPP = Nothing
End Sub

缩放至同样大小进一步深化。方向都明确了,自己也多查资料。

[ 本帖最后由 lianyicq 于 2015-3-14 14:11 编辑 ]

#6

xingming0222015-03-15 09:15

回复 5楼 lianyicq

非常感谢您的耐心指导，又学到好多新的语法，好多语法在MSDN上都没有的，关于移动和缩放我再查查资料。谢谢。

[ 本帖最后由 xingming022 于 2015-3-15 09:21 编辑 ]

#7

xingming0222015-03-25 16:52

回复 4楼 xingming022

lianyicq您好：
    根据您给的思路，我试了好几天也没有搞定，主要问题是：

    (1)ADWG.SendCommand "_pasteclip" & vbCr & CoordString & vbCr  语句将EXCEL粘贴到CAD里面，但是粘贴后的EXCEL坐标与   CoordString   对不上，总是偏一些。

    (2)粘贴完成后我需要移动和缩放EXCLE，移动和缩放的前提是要先选择上 EXCEL也就是OLE，VB如何选择OLE？VB选择直线和圆圈我搞定了，但是实在是选择不上OLE。

    请版主再多多给予指导，谢谢~

#8

lianyicq2015-03-26 08:38

回复 7楼 xingming022

能选上线和圆就接近了。
试试AApp.ActiveDocument.ModelSpace(i).EntityName = "AcDbOle2Frame"
ACAD中查询OLE对象特征，有一个长宽比锁定特性。
在变形之前先执行：AApp.ActiveDocument.ModelSpace(i).LockAspectRatio = False
假设创建的框的长宽已求得，再分别赋值到AApp.ActiveDocument.ModelSpace(i)的width、height属性
最后再AApp.ActiveDocument.ModelSpace(i).Move(AApp.ActiveDocument.ModelSpace(i).InsertionPoint, NewPosition)

#9

xingming0222015-03-26 08:58

回复 8楼 lianyicq

您随便一写就能写出好多我从未见过的代码，非常佩服，有没有这方面的教材推荐下？我最近在网上寻找了好久关于VB和CAD的教程，都未找到合适的。

#10

lianyicq2015-03-26 09:05

回复 9楼 xingming022

邮箱地址?

#11

xingming0222015-03-26 09:07

回复 10楼 lianyicq

非常感谢~
13925919930@

#12

lianyicq2015-03-26 09:15

回复 11楼 xingming022

已发

#13

xingming0222015-03-31 08:33

回复 8楼 lianyicq

版主您好，您提供的提示：AApp.ActiveDocument.ModelSpace(i).EntityName = "AcDbOle2Frame" 还是选择不上EXCLE，也就是OLE啊，还有没有其他的思路了？烦请再多多指导~

#14

lianyicq2015-03-31 08:44

回复 13楼 xingming022

程序代码：

Private Sub Form_Load()
Me.Show
'Set EXAPP = CreateObject("excel.application")
'Set WB = EXAPP.Workbooks.Open("c:\test.xlsx")
'Set sht = WB.Worksheets("Sheet1")
Set AApp = CreateObject("Autocad.Application")
Set ADWG = AApp.Documents.Open("c:\drawing1.dwg")
'Range("h7", "m9").Select
'Range("h7", "m9").Copy
For i = 0 To AApp.ActiveDocument.ModelSpace.Count - 1
  'If AApp.ActiveDocument.ModelSpace(i).Lineweight = 106 Then
  '   parameter = AApp.ActiveDocument.ModelSpace(i).Coordinates
  '   Exit For
  'End If
  If AApp.ActiveDocument.ModelSpace(i).EntityName = "AcDbOle2Frame" Then
     AApp.ActiveDocument.ModelSpace(i).LockAspectRatio = False
     AApp.ActiveDocument.ModelSpace(i).Width = 500
     AApp.ActiveDocument.ModelSpace(i).Height = 300

     NewPosition(0) = 25
     NewPosition(1) = 50
     NewPosition(2) = 0
     Call AApp.ActiveDocument.ModelSpace(i).Move(AApp.ActiveDocument.ModelSpace(i).InsertionPoint, NewPosition) 'insertionpoint is the coordinates of ole'lower-left

     Form1.Print "Finish."
     Exit For
  End If
Next

'CoordString = parameter(0) & "," & parameter(1)
'ADWG.SendCommand "_pasteclip" & vbCr & CoordString & vbCr
'ADWG.Save
Form1.Caption = "OK"
End Sub

我用以上代码测试过，没有问题。我用的是ACAD2013。你可以在遍历的时候，把每次得到的实体名称显示出来，找出OLE对象的名称很容易。我就是这样找才知道OLE对象名称是AcDbOle2Frame.

#15

xingming0222015-03-31 13:38

回复 14楼 lianyicq

非常感谢版主耐心的回复，运行到这里Call AApp.ActiveDocument.ModelSpace(i).Move(AApp.ActiveDocument.ModelSpace(i).InsertionPoint, NewPosition)，提示：“无效的过程调用或参数”。难道是我调用的函数未定义?还是我机子缺少什么库？

#16

lianyicq2015-03-31 13:41

回复 15楼 xingming022

Dim NewPosition(2) As Double

#17

xingming0222015-03-31 14:18

回复 16楼 lianyicq

我是定义的单精度的，Dim NewPosition(2) As Single，非要双精度？好神奇啊。谢谢您啊~

[ 本帖最后由 xingming022 于 2015-3-31 15:26 编辑 ]