明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 5400|回复: 6

利用VBA编程,将EXCEL数据直接导入CAD绘图

[复制链接]
发表于 2008-5-15 09:51 | 显示全部楼层 |阅读模式
如题,编制VBA程序,可实现将EXCEL表格中的数据(坐标值)导入CAD中直接绘图生成平面或者立体的单线图(轴线图),主要是实现直线(Line)的功能。
 楼主| 发表于 2008-5-15 10:04 | 显示全部楼层
等待高手回应~~~
发表于 2008-5-15 10:56 | 显示全部楼层

给你一个我编写的源代码,你可以从中得到想要的。

Sub clb() '画材料表
On Error GoTo err
Dim textObj As AcadText
Dim myselect(0 To 13) As AcadEntity
Dim mytxt As AcadTextStyle '定义mytxt变量为文本样式
Dim d As Long
Dim p(0 To 2) As Double '插入点
Dim excelapp As Excel.Application '定义excle应用程序变量
Dim excelsheet As Worksheet '定义工作表变量
Dim p1 As Variant '申明端点坐标
Dim p2 As Variant '申明端点坐标
Dim i As Long
Dim x As Long
Dim y As Long
Dim a1(0 To 2) As Double
Dim a2(0 To 2) As Double
Dim pp(0 To 9) As Double '定义点坐标
Dim txt
Dim corow As Long
Dim attrtxt0 As String
Dim attrtxt00 As String
Dim attrtxt1 As String
Dim attrtxt2 As String
Dim attrtxt3 As String
Dim attrtxt4 As String
Dim attrtxt5 As String
Dim attrtxt6 As String
Dim attrtxt7 As String
Set excelapp = CreateObject("excel.application")  '激活excel程序
excelapp.Workbooks.Open (ThisDrawing.path & "/物料表.xls") '打开工作薄
Set excelsheet = excelapp.ActiveWorkbook.Sheets("sheet1") '当前工作表为sheet1
corow = excelsheet.UsedRange.Rows.Count '计算工作表的总行数

p1 = ThisDrawing.Utility.GetPoint(, "物料表图框左上角点:") '获取点坐标
p2 = ThisDrawing.Utility.GetPoint(, "物料表图框右上角点:") '获取点坐标
p1(0) = Int(p1(0))
p1(1) = Int(p1(1))
p2(0) = Int(p2(0))
p2(1) = Int(p2(1))
Call addlay("物料表", 3)
d = Sqr((p2(0) - p1(0)) ^ 2 + (p2(1) - p1(1)) ^ 2)
If d > 590 Then 'A2图框
pp(0) = p1(0) + 20: pp(1) = p1(1) - 39
pp(2) = p1(0) + 507: pp(3) = p1(1) - 39
pp(4) = p1(0) + 507: pp(5) = p1(1) - 379
pp(6) = p1(0) + 20: pp(7) = p1(1) - 379
pp(8) = p1(0) + 20: pp(9) = p1(1) - 39
Set myselect(1) = ThisDrawing.ModelSpace.AddLightWeightPolyline(pp)
myselect(1).color = 4
End If
   a1(0) = p1(0) + 20: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 507: a2(1) = p1(1) - 76: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
   a1(0) = p1(0) + 40: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 40: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
   a1(0) = p1(0) + 62: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 62: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
      a1(0) = p1(0) + 97: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 97: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
      a1(0) = p1(0) + 117: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 117: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
      a1(0) = p1(0) + 147: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 147: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
         a1(0) = p1(0) + 184: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 184: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
         a1(0) = p1(0) + 219: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 219: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
   a1(0) = p1(0) + 258: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 258: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
  
   a1(0) = p1(0) + 269: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 269: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
   a1(0) = p1(0) + 289: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 289: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
   a1(0) = p1(0) + 311: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 311: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
   a1(0) = p1(0) + 346: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 346: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
   a1(0) = p1(0) + 366: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 366: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
   a1(0) = p1(0) + 396: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 396: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
   a1(0) = p1(0) + 433: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 433: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
   a1(0) = p1(0) + 463: a1(1) = p1(1) - 76: a1(2) = 0
   a2(0) = p1(0) + 463: a2(1) = p1(1) - 379: a2(2) = 0
   ThisDrawing.ModelSpace.AddLine a1, a2
x = p1(0) + 32: y = p1(1) - 93

   a1(0) = x - 12: a1(1) = y: a1(2) = 0
   a2(0) = x + 226: a2(1) = y: a2(2) = 0
Set myselect(1) = ThisDrawing.ModelSpace.AddLine(a1, a2)
   a1(0) = x + 237: a1(1) = y: a1(2) = 0
   a2(0) = x + 475: a2(1) = y: a2(2) = 0
Set myselect(1) = ThisDrawing.ModelSpace.AddLine(a1, a2)

For i = 1 To 25
   a1(0) = x - 12: a1(1) = y - i * 11: a1(2) = 0
   a2(0) = x + 226: a2(1) = y - i * 11: a2(2) = 0
Set myselect(1) = ThisDrawing.ModelSpace.AddLine(a1, a2)
myselect(1).color = 251
   a1(0) = x + 237: a1(1) = y - i * 11: a1(2) = 0
   a2(0) = x + 475: a2(1) = y - i * 11: a2(2) = 0
Set myselect(1) = ThisDrawing.ModelSpace.AddLine(a1, a2)
myselect(1).color = 251
Next i
Call addlay("文字标注", 3)
'-------------------------------------------------------
Set mytxt = ThisDrawing.TextStyles.Add("说明") '添加说明样式
mytxt.fontFile = "c:\windows\fonts\SIMHEI.TTF" '设置字体文件为仿宋体
mytxt.Height = 100 '字高
mytxt.Width = 0.8 '宽高比
ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt
   a1(0) = x + 9: a1(1) = y + 29: a1(2) = 0
 attrtxt00 = excelsheet.Cells(2, 9).Value  '序号
 If corow > 52 Then
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt00 & "物 料 表 (一) ", a1, 10)
     txt.Alignment = acAlignmentLeft
 Else
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt00 & "物 料 表 ", a1, 10)
     txt.Alignment = acAlignmentLeft
 End If
   a1(0) = x - 2: a1(1) = y + 8.5: a1(2) = 0
 Set txt = ThisDrawing.ModelSpace.AddText("类别", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
    a1(0) = x + 19: a1(1) = y + 8.5: a1(2) = 0
 Set txt = ThisDrawing.ModelSpace.AddText("代号", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
     a1(0) = x + 47: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("材料名称", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
    
     a1(0) = x + 75: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("品牌", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
    
     a1(0) = x + 100: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("规格型号", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
     a1(0) = x + 133: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("电话", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
     a1(0) = x + 169: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("部位", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
     a1(0) = x + 206: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("工艺要求", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
    
   a1(0) = x + 247: a1(1) = y + 8.5: a1(2) = 0
 Set txt = ThisDrawing.ModelSpace.AddText("类别", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
    a1(0) = x + 268: a1(1) = y + 8.5: a1(2) = 0
 Set txt = ThisDrawing.ModelSpace.AddText("代号", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
     a1(0) = x + 296.5: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("材料名称", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
    
     a1(0) = x + 324: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("品牌", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
    
     a1(0) = x + 349: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("规格型号", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
     a1(0) = x + 382: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("电话", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
     a1(0) = x + 416: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("部位", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
     a1(0) = x + 452: a1(1) = y + 8.5: a1(2) = 0
Set txt = ThisDrawing.ModelSpace.AddText("工艺要求", a1, 5)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
 '--------------------------------------------------------

For i = 1 To 26

  attrtxt0 = excelsheet.Cells(i + 1, 1).Value '类别
  attrtxt1 = excelsheet.Cells(i + 1, 2).Value '代号
  attrtxt2 = excelsheet.Cells(i + 1, 3).Value '材料名称
  attrtxt3 = excelsheet.Cells(i + 1, 4).Value '品牌
  attrtxt4 = excelsheet.Cells(i + 1, 5).Value '型号
  attrtxt5 = excelsheet.Cells(i + 1, 6).Value '电话
  attrtxt6 = excelsheet.Cells(i + 1, 7).Value '部位
  attrtxt7 = excelsheet.Cells(i + 1, 8).Value '工艺要求
  a1(0) = x - 2
  a1(1) = y - 5.5 - (i - 1) * 11
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt0, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 19
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt1, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 47
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt2, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 75
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt3, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 100
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt4, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 133
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt5, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
      a1(0) = x + 169
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt6, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 206
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt7, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
Next i
'-------------------------------------------------------'
If corow > 26 Then
  For i = 27 To 52

  attrtxt0 = excelsheet.Cells(i + 1, 1).Value '类别
  attrtxt1 = excelsheet.Cells(i + 1, 2).Value '代号
  attrtxt2 = excelsheet.Cells(i + 1, 3).Value '材料名称
  attrtxt3 = excelsheet.Cells(i + 1, 4).Value '品牌
  attrtxt4 = excelsheet.Cells(i + 1, 5).Value '型号
  attrtxt5 = excelsheet.Cells(i + 1, 6).Value '电话
  attrtxt6 = excelsheet.Cells(i + 1, 7).Value '部位
  attrtxt7 = excelsheet.Cells(i + 1, 8).Value '工艺要求
  a1(0) = x + 247
  a1(1) = y - 5.5 - (i - 27) * 11
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt0, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 268
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt1, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 296.5
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt2, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 324
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt3, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 349
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt4, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 382
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt5, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
      a1(0) = x + 416
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt6, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
  a1(0) = x + 452
 Set txt = ThisDrawing.ModelSpace.AddText(attrtxt7, a1, 4)
     txt.Alignment = acAlignmentMiddleCenter
     txt.TextAlignmentPoint = a1
     Next i
End If

err:
excelapp.Quit '退出excel程序
Set excelapp = Nothing '释放变量
Set excelsheet = Nothing
End Sub

发表于 2015-12-21 10:09 | 显示全部楼层
nhy12345678 发表于 2008-5-15 10:56
给你一个我编写的源代码,你可以从中得到想要的。Sub clb() '画材料表On Error GoTo errDim textObj As Aca ...

看你的代码打开的是excel2003的文件要是excel2007的文件怎么写呢

点评

何以见得?不分版本。  发表于 2015-12-21 16:52
发表于 2016-2-14 11:09 | 显示全部楼层
新鲜1688 发表于 2015-12-21 10:09
看你的代码打开的是excel2003的文件要是excel2007的文件怎么写呢

把2007另存为2003
发表于 2016-2-14 11:12 | 显示全部楼层
楼主能否提供一下附件啊
发表于 2017-10-14 14:38 | 显示全部楼层
nhy12345678 发表于 2008-5-15 10:56
给你一个我编写的源代码,你可以从中得到想要的。Sub clb() '画材料表On Error GoTo errDim textObj As Aca ...

谢谢楼主的分享,谢谢!
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 13:11 , Processed in 0.218744 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表