利用Excel的VBA将Excel表格导入CAD

springwillow

2. Sub ExportToACAD()
   
3.     On Error Resume Next
   
4.     Dim objAcad As Object     ''AcadApplication
   
5.     Dim objAcadDoc As Object
   
6. ''AcadDocument
   
7.     Dim objModelSpace As Object       ''AcadModelSpace
   
8.    
   
9. Dim msgResult As Integer
   
10.     Dim a As Range
    
11.     If Selection Is Nothing Then MsgBox "Nothing Selected!": Exit Sub
    
12.     msgResult = MsgBox("您共选择了" & Selection.Rows.Count & "行 " & Selection.Columns.Count & "列，" & Chr(13) & "请注意一些对齐方式可能被忽略！" & Chr(13) & "继续吗 ", vbOKCancel, "选择")
    
13.     If msgResult = vbCancel Then Exit Sub
    
14.     Err.Clear
    
15.     Set objAcad = GetObject(, "AutoCAD.application")
    
16.     If Err.Number = 0 Then GoTo Finish
    
17.     Err.Clear
    
18.     Set objAcad = CreateObject("autocad.application")
    
19. Finish:
    
20.     If Err.Number <> 0 Then
    
21.         MsgBox "You must have AutoCAD installed to run this Macro!", vbCritical, "Export to ACAD"
    
22.         Exit Sub
    
23.     End If
    
24.     On Error GoTo errHandler
    
25.     Set objAcadDoc = objAcad.Documents.Add
    
26.     Set objModelSpace = objAcadDoc.ModelSpace
    
27.     Dim textObj As Object
    
28. ''AcadText
    
29.     Dim lineObj As Object       ''AcadLine
    
30.     Dim insPnt(0 To 2) As Double
    
31.     Dim stPnt(0 To 2) As Double
    
32.     Dim edPnt(0 To 2) As Double
    
33.     Dim txtHeight As Double
    
34.     Const txtClearance As Double = 2
    
35.     Static startY As Double
    
36.     startY = Selection.Rows(Selection.Rows.Count).Top - Selection.Rows(1).Top
    
37.     For Each a In Selection
    
38.         If a.Borders(xlEdgeTop).LineStyle = xlContinuous Then
    
39.             stPnt(0) = a.Left: stPnt(1) = startY - a.Top: stPnt(2) = 0
    
40.             edPnt(0) = a.Left + a.Width: edPnt(1) = stPnt(1): edPnt(2) = 0
    
41.             Set lineObj = objModelSpace.AddLine(stPnt, edPnt)
    
42.         
    
43. End If
    
44.         If a.Borders(xlEdgeLeft).LineStyle = xlContinuous Then
    
45.             stPnt(0) = a.Left: stPnt(1) = startY - a.Top: stPnt(2) = 0
    
46.             edPnt(0) = stPnt(0): edPnt(1) = startY - a.Top - a.Height:
    
47. edPnt(2) = 0
    
48.             Set lineObj = objModelSpace.AddLine(stPnt, edPnt)
    
49.         End If
    
50.         txtHeight = a.Font.Size / 1.5
    
51.         If Trim(a.Text) <> "" Then
    
52.             If a.HorizontalAlignment = xlCenter Then
    
53.                 insPnt(0) = a.Left + a.Width / 2
    
54.                
    
55. insPnt(1) = startY - a.Top - a.Height / 2
    
56.                 insPnt(2) = 0
    
57.                 Set textObj = objModelSpace.AddText(a.Text, insPnt, txtHeight)
    
58.                 textObj.Alignment = 10
    
59. 'acAlignmentMiddleCenter
    
60.                 textObj.TextAlignmentPoint = insPnt
    
61.             ElseIf a.HorizontalAlignment = xlLeft Or (a.HorizontalAlignment = xlGeneral And _
    
62.                 Not IsNumeric(a.Text)) Then
    
63.                 insPnt(0) = a.Left + txtClearance
    
64.                 insPnt(1) = startY - a.Top - a.Height / 2
    
65.                 insPnt(2) = 0
    
66.                 Set textObj = objModelSpace.AddText(a.Text, insPnt, txtHeight)
    
67.                
    
68. textObj.Alignment = 9   'acAlignmentMiddleLeft
    
69.                
    
70. textObj.TextAlignmentPoint = insPnt
    
71.             Else
    
72.                
    
73. insPnt(0) = a.Left + a.Width - txtClearance
    
74.                 insPnt(1) = startY - a.Top - a.Height / 2
    
75.                 insPnt(2) = 0
    
76.                 Set textObj = objModelSpace.AddText(a.Text, insPnt, txtHeight)
    
77.                 textObj.Alignment = 11
    
78. 'acAlignmentMiddleRight
    
79.                 textObj.TextAlignmentPoint = insPnt
    
80.             End If
    
81.         End If
    
82.     Next a
    
83.     For Each a In Selection.Offset(Selection.Rows.Count - 1, 0). _
    
84.         Resize(1, Selection.Columns.Count)
    
85.         If a.Borders(xlEdgeBottom).LineStyle = xlContinuous Then
    
86.             stPnt(0) = a.Left: stPnt(1) = startY - a.Top - a.Height: stPnt(2) = 0
    
87.             edPnt(0) = a.Left + a.Width: edPnt(1) = stPnt(1): edPnt(2) = 0
    
88.             Set lineObj = objModelSpace.AddLine(stPnt, edPnt)
    
89.         End If
    
90.     Next
    
91.     For Each a In Selection.Offset(0, Selection.Columns.Count - 1). _
    
92.         Resize(Selection.Rows.Count, 1)
    
93.         If a.Borders(xlEdgeRight).LineStyle = xlContinuous Then
    
94.             stPnt(0) = a.Left + a.Width: stPnt(1) = startY - a.Top:
    
95. stPnt(2) = 0
    
96.             edPnt(0) = stPnt(0): edPnt(1) = startY - a.Top - a.Height: edPnt(2) = 0
    
97.             Set lineObj = objModelSpace.AddLine(stPnt, edPnt)
    
98.         End If
    
99.     Next
    
100.     Application.WindowState = xlMinimized
     
101.     objAcad.WindowState = 3 'acMax
     
102.     objAcad.Visible = True
     
103.     objAcad.ZoomAll
     
104.     'objAcad.Close
     
105.     Set objAcad = Nothing
     
106.     Set objAcadDoc = Nothing
     
107.     Set objModelSpace = Nothing
     
108.     Exit Sub
     
109. errHandler: MsgBox "在该系统中不能正常运行！ " & Chr(10) & Err.Description, vbCritical, "Export to ACAD"
     
110.     End Sub
     
111. 
     

Sub ExportToACAD()<br />     On Error Resume Next<br />     Dim objAcad As Object     ''AcadApplication<br />     Dim objAcadDoc As Object<br /> ''AcadDocument<br />     Dim objModelSpace As Object       ''AcadModelSpace<br />     <br /> Dim msgResult As Integer<br />     Dim a As Range<br />     If Selection Is Nothing Then MsgBox "Nothing Selected!": Exit Sub<br />     msgResult = MsgBox("您共选择了" & Selection.Rows.Count & "行 " & Selection.Columns.Count & "列，" & Chr(13) & "请注意一些对齐方式可能被忽略！" & Chr(13) & "继续吗 ", vbOKCancel, "选择")<br />     If msgResult = vbCancel Then Exit Sub<br />     Err.Clear<br />     Set objAcad = GetObject(, "<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>.application")<br />     If Err.Number = 0 Then GoTo Finish<br />     Err.Clear<br />     Set objAcad = CreateObject("autocad.application")<br /> Finish:<br />     If Err.Number <> 0 Then<br />         MsgBox "You must have AutoCAD installed to run this Macro!", vbCritical, "Export to ACAD"<br />         Exit Sub<br />     End If<br />     On Error GoTo errHandler<br />     Set objAcadDoc = objAcad.Documents.Add<br />     Set objModelSpace = objAcadDoc.ModelSpace<br />     Dim textObj As Object<br /> ''AcadText<br />     Dim lineObj As Object       ''AcadLine<br />     Dim insPnt(0 To 2) As Double<br />     Dim stPnt(0 To 2) As Double<br />     Dim edPnt(0 To 2) As Double<br />     Dim txtHeight As Double<br />     Const txtClearance As Double = 2<br />     Static startY As Double<br />     startY = Selection.Rows(Selection.Rows.Count).Top - Selection.Rows(1).Top<br />     For Each a In Selection<br />         If a.Borders(xlEdgeTop).LineStyle = xlContinuous Then<br />             stPnt(0) = a.Left: stPnt(1) = startY - a.Top: stPnt(2) = 0<br />             edPnt(0) = a.Left + a.Width: edPnt(1) = stPnt(1): edPnt(2) = 0<br />             Set lineObj = objModelSpace.AddLine(stPnt, edPnt)<br />         <br /> End If<br />         If a.Borders(xlEdgeLeft).LineStyle = xlContinuous Then<br />             stPnt(0) = a.Left: stPnt(1) = startY - a.Top: stPnt(2) = 0<br />             edPnt(0) = stPnt(0): edPnt(1) = startY - a.Top - a.Height:<br /> edPnt(2) = 0<br />             Set lineObj = objModelSpace.AddLine(stPnt, edPnt)<br />         End If<br />         txtHeight = a.Font.Size / 1.5<br />         If Trim(a.Text) <> "" Then<br />             If a.HorizontalAlignment = xlCenter Then<br />                 insPnt(0) = a.Left + a.Width / 2<br />                 <br /> insPnt(1) = startY - a.Top - a.Height / 2<br />                 insPnt(2) = 0<br />                 Set textObj = objModelSpace.AddText(a.Text, insPnt, txtHeight)<br />                 textObj.Alignment = 10<br /> 'acAlignmentMiddleCenter<br />                 textObj.TextAlignmentPoint = insPnt<br />             ElseIf a.HorizontalAlignment = xlLeft Or (a.HorizontalAlignment = xlGeneral And _<br />                 Not IsNumeric(a.Text)) Then<br />                 insPnt(0) = a.Left + txtClearance<br />                 insPnt(1) = startY - a.Top - a.Height / 2<br />                 insPnt(2) = 0<br />                 Set textObj = objModelSpace.AddText(a.Text, insPnt, txtHeight)<br />                 <br /> textObj.Alignment = 9   'acAlignmentMiddleLeft<br />                 <br /> textObj.TextAlignmentPoint = insPnt<br />             Else<br />                 <br /> insPnt(0) = a.Left + a.Width - txtClearance<br />                 insPnt(1) = startY - a.Top - a.Height / 2<br />                 insPnt(2) = 0<br />                 Set textObj = objModelSpace.AddText(a.Text, insPnt, txtHeight)<br />                 textObj.Alignment = 11<br /> 'acAlignmentMiddleRight<br />                 textObj.TextAlignmentPoint = insPnt<br />             End If<br />         End If<br />     Next a<br />     For Each a In Selection.Offset(Selection.Rows.Count - 1, 0). _<br />         Resize(1, Selection.Columns.Count)<br />         If a.Borders(xlEdgeBottom).LineStyle = xlContinuous Then<br />             stPnt(0) = a.Left: stPnt(1) = startY - a.Top - a.Height: stPnt(2) = 0<br />             edPnt(0) = a.Left + a.Width: edPnt(1) = stPnt(1): edPnt(2) = 0<br />             Set lineObj = objModelSpace.AddLine(stPnt, edPnt)<br />         End If<br />     Next<br />     For Each a In Selection.Offset(0, Selection.Columns.Count - 1). _<br />         Resize(Selection.Rows.Count, 1)<br />         If a.Borders(xlEdgeRight).LineStyle = xlContinuous Then<br />             stPnt(0) = a.Left + a.Width: stPnt(1) = startY - a.Top:<br /> stPnt(2) = 0<br />             edPnt(0) = stPnt(0): edPnt(1) = startY - a.Top - a.Height: edPnt(2) = 0<br />             Set lineObj = objModelSpace.AddLine(stPnt, edPnt)<br />         End If<br />     Next<br />     Application.WindowState = xlMinimized<br />     objAcad.WindowState = 3 'acMax<br />     objAcad.Visible = True<br />     objAcad.ZoomAll<br />     'objAcad.Close<br />     Set objAcad = Nothing<br />     Set objAcadDoc = Nothing<br />     Set objModelSpace = Nothing<br />     Exit Sub<br /> errHandler: MsgBox "在该系统中不能正常运行！ " & Chr(10) & Err.Description, vbCritical, "Export to ACAD"<br />     End Sub<br /> <br />

使用方法是打开Excel程序，找到开发工具（如果没有可以在选项-自定义功能区中填加），点击Visual Basic按钮调出VBA编辑器，把代码粘贴到代码窗口。回到Excel，选中要插入CAD的单元格，设置好单元格的边框，执行宏即可。

sunny_8848

要是能把那些每行的横向或者纵向的表格线分别绘制成一条条的就更好了，现在是按单元格绘制的。一般表格都是绘制多少行多少列的样式

creatorzxz

谢楼主分享,已经加入我常用的工具箱中

zhurq9876

代码会出错！好像段落出现问题！

yaokui25

谢谢楼主分享这么好的程序

yangchao2005090

语法有错误呀

kexiya123

语法有错误啊

springwillow

office2010运行没问题啊！

yuxin6618

谢楼主分享

664571221

怎么用啊