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

afei21501

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

afei21501

等待高手回应~~~

nhy12345678

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

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

新鲜1688

nhy12345678 发表于 2008-5-15 10:56
给你一个我编写的源代码，你可以从中得到想要的。Sub clb() '画材料表On Error GoTo errDim textObj As Aca ...

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

blackfire

新鲜1688 发表于 2015-12-21 10:09
看你的代码打开的是excel2003的文件要是excel2007的文件怎么写呢

把2007另存为2003

blackfire

楼主能否提供一下附件啊

elepeipei

nhy12345678 发表于 2008-5-15 10:56
给你一个我编写的源代码，你可以从中得到想要的。Sub clb() '画材料表On Error GoTo errDim textObj As Aca ...

谢谢楼主的分享，谢谢！