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

afei21501 · 发表于 2008-5-15 09:51:00

如题，编制VBA程序，可实现将EXCEL表格中的数据（坐标值）导入CAD中直接绘图生成平面或者立体的单线图（轴线图），主要是实现直线(Line)的功能。

afei21501 · 发表于 2008-5-15 10:04:00

等待高手回应~~~

nhy12345678 · 发表于 2008-5-15 10:56:00

给你一个我编写的源代码，你可以从中得到想要的。
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