Excel表格到CAD的示例程序

efan2000

增加了一小部分注释，希望对大家有所帮助。

2. Sub Test()
3.        On Error Resume Next        ' 连接Excel应用程序       Dim xlApp As Excel.Application
4.        Set xlApp = GetObject(, "Excel.Application")
5.        If Err Then
6.                MsgBox " Excel 应用程序没有运行。请启动 Excel 并重新运行程序。"
7.                Exit Sub
8.        End If
9.        Dim xlSheet As Worksheet
10.        Set xlSheet = xlApp.ActiveSheet       ' 当初考虑将表格做成块的方式，可以根据需要取舍。
11.        'Dim iPt(0 To 2) As Double
12.        'iPt(0) = 0: iPt(1) = 0: iPt(2) = 0
13.        Dim BlockObj As AcadBlock
14.        Set BlockObj = ThisDrawing.Blocks("*Model_Space")
15.        Dim iPt As Variant
16.        iPt = ThisDrawing.Utility.GetPoint(, "指定表格的插入点: ")
17.        If IsEmpty(iPt) Then Exit Sub
18.        Dim xlRange As Range
19.        Debug.Print xlSheet.UsedRange.Address
20.        For Each xlRange In xlSheet.UsedRange
21.                AddLine BlockObj, iPt, xlRange
22.                AddText BlockObj, iPt, xlRange
23.        Next
24.        Set xlRange = Nothing
25.        Set xlSheet = Nothing
26.        Set xlApp = Nothing
27. End Sub
29. '边框线条粗细
30. Function LineWidth(ByVal xlBorder As Border) As Double
31.        Select Case xlBorder.Weight
32.                Case xlThin
33.                        LineWidth = 0
34.                Case xlMedium
35.                        LineWidth = 0.35
36.                Case xlThick
37.                        LineWidth = 0.7
38.                Case Else
39.                        LineWidth = 0
40.        End Select
41. End Function
43. '边框线条颜色，处理的颜色不全，请自己添加
44. Function LineColor(ByVal xlBorder As Border) As Integer
45.        Select Case xlBorder.ColorIndex
46.                Case xlAutomatic
47.                        LineColor = acByLayer
48.                Case 3
49.                        LineColor = acRed
50.                Case 4
51.                        LineColor = acGreen
52.                Case 5
53.                        LineColor = acBlue
54.                Case 6
55.                        LineColor = acYellow
56.                  Case 8
57.                        LineColor = acCyan
58.                  Case 9
59.                        LineColor = acMagenta
60.                Case Else
61.                        LineColor = acByLayer
62.        End Select
63. End Function
65. '给制边框
66. Sub AddLine(ByRef BlockObj As AcadBlock, ByVal iPt As Variant, ByVal xlRange As Range)
67.        If xlRange.Borders(xlEdgeLeft).LineStyle = xlNone _
68.                And xlRange.Borders(xlEdgeBottom).LineStyle = xlNone _
69.                And xlRange.Borders(xlEdgeRight).LineStyle = xlNone _
70.                And xlRange.Borders(xlEdgeTop).LineStyle = xlNone Then Exit Sub
71.        Dim rl As Double
72.        Dim rt As Double
73.        Dim rw As Double
74.        Dim rh As Double
75.        rl = PToM(xlRange.Left)
76.        rt = PToM(xlRange.top)
77.        rw = PToM(xlRange.Width)
78.        rh = PToM(xlRange.Height)
79.        Dim pPt(0 To 3) As Double
80.        Dim pLineObj As AcadLWPolyline       ' 左边框的处理，仅第一列才做处理。
81.        If xlRange.Borders(xlEdgeLeft).LineStyle <> xlNone And xlRange.Column = 1 Then
82.                pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - rt
83.                pPt(2) = iPt(0) + rl: pPt(3) = iPt(1) - (rt + rh)
84.                Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
85.                pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeLeft))
86.                pLineObj.Color = LineColor(xlRange.Borders(xlEdgeLeft))
87.        End If       ' 下边框的处理，对于合并单元格，只处理最后一行。
88.        If xlRange.Borders(xlEdgeBottom).LineStyle <> xlNone And (xlRange.Row = xlRange.MergeArea.Row + xlRange.MergeArea.Rows.Count - 1) Then
89.                pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - (rt + rh)
90.                pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - (rt + rh)
91.                Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
92.                pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeBottom))
93.                pLineObj.Color = LineColor(xlRange.Borders(xlEdgeBottom))
94.        End If       ' 右边框的处理，对于合并单元格，只处理最后一列。
95.        If xlRange.Borders(xlEdgeRight).LineStyle <> xlNone And (xlRange.Column >= xlRange.MergeArea.Column + xlRange.MergeArea.Columns.Count - 1) Then
96.                pPt(0) = iPt(0) + rl + rw: pPt(1) = iPt(1) - (rt + rh)
97.                pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - rt
98.                Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
99.                pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeRight))
100.                pLineObj.Color = LineColor(xlRange.Borders(xlEdgeRight))
101.        End If       ' 上边框的处理，仅第一行才做处理。
102.        If xlRange.Borders(xlEdgeTop).LineStyle <> xlNone And xlRange.Row = 1 Then
103.                pPt(0) = iPt(0) + rl + rw: pPt(1) = iPt(1) - rt
104.                pPt(2) = iPt(0) + rl: pPt(3) = iPt(1) - rt
105.                Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
106.                pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeTop))
107.                pLineObj.Color = LineColor(xlRange.Borders(xlEdgeTop))
108.        End If
109.        Set pLineObj = Nothing
110. End Sub
112. '给制文本
113. Sub AddText(ByRef BlockObj As AcadBlock, ByVal InsertionPoint As Variant, ByVal xlRange As Range)
114.        If xlRange.Text = "" Then Exit Sub
115.        Dim rl As Double
116.        Dim rt As Double
117.        Dim rw As Double
118.        Dim rh As Double
119.        rl = PToM(xlRange.Left)
120.        rt = PToM(xlRange.top)
121.        rw = PToM(xlRange.MergeArea.Width)
122.        rh = PToM(xlRange.MergeArea.Height)
123.        Dim i As Integer
124.        Dim s As String
125.        For i = 1 To Len(xlRange.Text) '将EXCEL的换行符替换成\P，注如果是在R2002以上可使用Replace函数。
126.                If Asc(Mid(xlRange.Text, i, 1)) = 10 Then
127.                        s = s & "\P"
128.                Else
129.                        s = s & Mid(xlRange.Text, i, 1)
130.                End If
131.        Next
132.        Dim iPt(0 To 2) As Double
133.        iPt(0) = InsertionPoint(0) + rl: iPt(1) = InsertionPoint(1) - rt: iPt(2) = 0
134.        Dim mTextObj As AcadMText
135.        Set mTextObj = BlockObj.AddMText(iPt, rw, s)   '"{\f" & xlRange.Font.Name & ";" & s & "}")
136.        mTextObj.LineSpacingFactor = 0.75
137.        mTextObj.Height = PToM(xlRange.Font.Size)       ' 处理文字的对齐方式
138.        Dim tPt As Variant
139.        If xlRange.VerticalAlignment = xlTop And (xlRange.HorizontalAlignment = xlLeft Or xlRange.HorizontalAlignment = xlGeneral) Then
140.                mTextObj.AttachmentPoint = acAttachmentPointTopLeft
141.                tPt = iPt
142.        ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlCenter Then
143.                mTextObj.AttachmentPoint = acAttachmentPointTopCenter
144.                tPt = ThisDrawing.Utility.PolarPoint(iPt, 0, rw / 2)
145.        ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlRight Then
146.                mTextObj.AttachmentPoint = acAttachmentPointTopRight
147.                tPt = ThisDrawing.Utility.PolarPoint(iPt, 0, rw)
148.        ElseIf xlRange.VerticalAlignment = xlCenter And (xlRange.HorizontalAlignment = xlLeft _
149.                        Or xlRange.HorizontalAlignment = xlGeneral) Then
150.                mTextObj.AttachmentPoint = acAttachmentPointMiddleLeft
151.                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh / 2)
152.        ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlCenter Then
153.                mTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
154.                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh / 2)
155.                tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw / 2)
156.        ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlRight Then
157.                mTextObj.AttachmentPoint = acAttachmentPointMiddleRight
158.                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh / 2)
159.                tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw / 2)
160.        ElseIf xlRange.VerticalAlignment = xlBottom And (xlRange.HorizontalAlignment = xlLeft _
161.                        Or xlRange.HorizontalAlignment = xlGeneral) Then
162.                mTextObj.AttachmentPoint = acAttachmentPointBottomLeft
163.                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh)
164.        ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlCenter Then
165.                mTextObj.AttachmentPoint = acAttachmentPointBottomCenter
166.                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh)
167.                tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw / 2)
168.        ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlRight Then
169.                mTextObj.AttachmentPoint = acAttachmentPointBottomRight
170.                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh)
171.                tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw)
172.        End If
173.        mTextObj.InsertionPoint = tPt
174.        Set mTextObj = Nothing
175. End Sub
177. ' 磅换算成毫米' 注：意义不大，转换的尺寸有偏差，最好自己设定一个转换规则。
178. Function PToM(ByVal Points As Double) As Double
179.        PToM = Points * 0.3527778
180. End Function

Sub Test()        On Error Resume Next        ' 连接Excel应用程序       Dim xlApp As Excel.Application        Set xlApp = GetObject(, "Excel.Application")        If Err Then                MsgBox " Excel 应用程序没有运行。请启动 Excel 并重新运行程序。"                Exit Sub        End If        Dim xlSheet As Worksheet        Set xlSheet = xlApp.ActiveSheet       ' 当初考虑将表格做成块的方式，可以根据需要取舍。        'Dim iPt(0 To 2) As Double        'iPt(0) = 0: iPt(1) = 0: iPt(2) = 0        Dim BlockObj As AcadBlock        Set BlockObj = ThisDrawing.Blocks("*Model_Space")        Dim iPt As Variant        iPt = ThisDrawing.Utility.GetPoint(, "指定表格的插入点: ")        If IsEmpty(iPt) Then Exit Sub        Dim xlRange As Range        Debug.Print xlSheet.UsedRange.Address        For Each xlRange In xlSheet.UsedRange                AddLine BlockObj, iPt, xlRange                AddText BlockObj, iPt, xlRange        Next        Set xlRange = Nothing        Set xlSheet = Nothing        Set xlApp = Nothing End Sub '边框线条粗细 Function LineWidth(ByVal xlBorder As Border) As Double        Select Case xlBorder.Weight                Case xlThin                        LineWidth = 0                Case xlMedium                        LineWidth = 0.35                Case xlThick                        LineWidth = 0.7                Case Else                        LineWidth = 0        End Select End Function '边框线条颜色，处理的颜色不全，请自己添加 Function LineColor(ByVal xlBorder As Border) As Integer        Select Case xlBorder.ColorIndex                Case xlAutomatic                        LineColor = acByLayer                Case 3                        LineColor = acRed                Case 4                        LineColor = acGreen                Case 5                        LineColor = acBlue                Case 6                        LineColor = acYellow                  Case 8                        LineColor = acCyan                  Case 9                        LineColor = acMagenta                Case Else                        LineColor = acByLayer        End Select End Function '给制边框 Sub AddLine(ByRef BlockObj As AcadBlock, ByVal iPt As Variant, ByVal xlRange As Range)        If xlRange.Borders(xlEdgeLeft).LineStyle = xlNone _                And xlRange.Borders(xlEdgeBottom).LineStyle = xlNone _                And xlRange.Borders(xlEdgeRight).LineStyle = xlNone _                And xlRange.Borders(xlEdgeTop).LineStyle = xlNone Then Exit Sub        Dim rl As Double        Dim rt As Double        Dim rw As Double        Dim rh As Double        rl = PToM(xlRange.Left)        rt = PToM(xlRange.top)        rw = PToM(xlRange.Width)        rh = PToM(xlRange.Height)        Dim pPt(0 To 3) As Double        Dim pLineObj As AcadLWPolyline       ' 左边框的处理，仅第一列才做处理。        If xlRange.Borders(xlEdgeLeft).LineStyle <> xlNone And xlRange.Column = 1 Then                pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - rt                pPt(2) = iPt(0) + rl: pPt(3) = iPt(1) - (rt + rh)                Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)                pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeLeft))                pLineObj.Color = LineColor(xlRange.Borders(xlEdgeLeft))        End If       ' 下边框的处理，对于合并单元格，只处理最后一行。        If xlRange.Borders(xlEdgeBottom).LineStyle <> xlNone And (xlRange.Row = xlRange.MergeArea.Row + xlRange.MergeArea.Rows.Count - 1) Then                pPt(0) = iPt(0) + rl: pPt(1) = iPt(1) - (rt + rh)                pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - (rt + rh)                Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)                pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeBottom))                pLineObj.Color = LineColor(xlRange.Borders(xlEdgeBottom))        End If       ' 右边框的处理，对于合并单元格，只处理最后一列。        If xlRange.Borders(xlEdgeRight).LineStyle <> xlNone And (xlRange.Column >= xlRange.MergeArea.Column + xlRange.MergeArea.Columns.Count - 1) Then                pPt(0) = iPt(0) + rl + rw: pPt(1) = iPt(1) - (rt + rh)                pPt(2) = iPt(0) + rl + rw: pPt(3) = iPt(1) - rt                Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)                pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeRight))                pLineObj.Color = LineColor(xlRange.Borders(xlEdgeRight))        End If       ' 上边框的处理，仅第一行才做处理。        If xlRange.Borders(xlEdgeTop).LineStyle <> xlNone And xlRange.Row = 1 Then                pPt(0) = iPt(0) + rl + rw: pPt(1) = iPt(1) - rt                pPt(2) = iPt(0) + rl: pPt(3) = iPt(1) - rt                Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)                pLineObj.ConstantWidth = LineWidth(xlRange.Borders(xlEdgeTop))                pLineObj.Color = LineColor(xlRange.Borders(xlEdgeTop))        End If        Set pLineObj = Nothing End Sub '给制文本 Sub AddText(ByRef BlockObj As AcadBlock, ByVal InsertionPoint As Variant, ByVal xlRange As Range)        If xlRange.Text = "" Then Exit Sub        Dim rl As Double        Dim rt As Double        Dim rw As Double        Dim rh As Double        rl = PToM(xlRange.Left)        rt = PToM(xlRange.top)        rw = PToM(xlRange.MergeArea.Width)        rh = PToM(xlRange.MergeArea.Height)        Dim i As Integer        Dim s As String        For i = 1 To Len(xlRange.Text) '将EXCEL的换行符替换成\P，注如果是在R2002以上可使用Replace函数。                If Asc(Mid(xlRange.Text, i, 1)) = 10 Then                        s = s & "\P"                Else                        s = s & Mid(xlRange.Text, i, 1)                End If        Next        Dim iPt(0 To 2) As Double        iPt(0) = InsertionPoint(0) + rl: iPt(1) = InsertionPoint(1) - rt: iPt(2) = 0        Dim mTextObj As AcadMText        Set mTextObj = BlockObj.AddMText(iPt, rw, s)   '"{\f" & xlRange.Font.Name & ";" & s & "}")        mTextObj.LineSpacingFactor = 0.75        mTextObj.Height = PToM(xlRange.Font.Size)       ' 处理文字的对齐方式        Dim tPt As Variant        If xlRange.VerticalAlignment = xlTop And (xlRange.HorizontalAlignment = xlLeft Or xlRange.HorizontalAlignment = xlGeneral) Then                mTextObj.AttachmentPoint = acAttachmentPointTopLeft                tPt = iPt        ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlCenter Then                mTextObj.AttachmentPoint = acAttachmentPointTopCenter                tPt = ThisDrawing.Utility.PolarPoint(iPt, 0, rw / 2)        ElseIf xlRange.VerticalAlignment = xlTop And xlRange.HorizontalAlignment = xlRight Then                mTextObj.AttachmentPoint = acAttachmentPointTopRight                tPt = ThisDrawing.Utility.PolarPoint(iPt, 0, rw)        ElseIf xlRange.VerticalAlignment = xlCenter And (xlRange.HorizontalAlignment = xlLeft _                        Or xlRange.HorizontalAlignment = xlGeneral) Then                mTextObj.AttachmentPoint = acAttachmentPointMiddleLeft                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh / 2)        ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlCenter Then                mTextObj.AttachmentPoint = acAttachmentPointMiddleCenter                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh / 2)                tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw / 2)        ElseIf xlRange.VerticalAlignment = xlCenter And xlRange.HorizontalAlignment = xlRight Then                mTextObj.AttachmentPoint = acAttachmentPointMiddleRight                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh / 2)                tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw / 2)        ElseIf xlRange.VerticalAlignment = xlBottom And (xlRange.HorizontalAlignment = xlLeft _                        Or xlRange.HorizontalAlignment = xlGeneral) Then                mTextObj.AttachmentPoint = acAttachmentPointBottomLeft                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh)        ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlCenter Then                mTextObj.AttachmentPoint = acAttachmentPointBottomCenter                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh)                tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw / 2)        ElseIf xlRange.VerticalAlignment = xlBottom And xlRange.HorizontalAlignment = xlRight Then                mTextObj.AttachmentPoint = acAttachmentPointBottomRight                tPt = ThisDrawing.Utility.PolarPoint(iPt, -1.5707963, rh)                tPt = ThisDrawing.Utility.PolarPoint(tPt, 0, rw)        End If        mTextObj.InsertionPoint = tPt        Set mTextObj = Nothing End Sub ' 磅换算成毫米' 注：意义不大，转换的尺寸有偏差，最好自己设定一个转换规则。 Function PToM(ByVal Points As Double) As Double        PToM = Points * 0.3527778 End Function

hzyhzjjzh

谢谢楼主分享!

sdjnrc

坚决支持，虽然看不太懂

efan2000

1. 表格处理模块详细设计作者：efan2000         
2.                                                    
3. 模块设计说明模块概述
4. 产生背景：AutoCAD表格绘制、工程计算的功能十分的薄弱，但实际应用中，这两项功能是不可缺少的，因而，需要一种简便的方法来弥补这种缺陷。Excel是表格处理软件，带有强大的计算功能，而且开发方便，正好可以利用。因此，就可以通过Excel计算、制表，然后转化到AutoCAD来实现AutoCAD表格的生成。
5. 平台环境：Excel、AutoCAD、VBA。
6. 技术介绍：使用VBA，采用OLE方式对Excel、AutoCAD进行二次开发，实现功能的扩充。
7. 功能说明：1、表格的边框处理模块：如边框的线型、颜色、线重等。
8.                    2、表格的文字处理模块：如文字的字体、字号、颜色等。

复制代码

未完成...，欢迎大家来共同完善。

mingyu9608

很好的例子,我用了不知道是什么原因,转换后有很多"?"号


还有能否给给详细点的说明,我真的学这个,有些地方还看不懂,


转换规则应该怎样指定

wyj_007

我熟悉CAD，Excel，Vlisp,可惜唯独不懂VBA。我也急需这种好程序，不知哪位大侠肯告诉我把上面的程序放到哪里，文件名后缀为什么，如何加载，加载后命名为什么。最后请高手指点VBA书籍中高，中，低级最好为哪三本。在下万分感激。 ----------------------------------------------
wyj_007@sina.com 隔行如隔山，此话真不假！但愿有仙人，渡我披新袈。

ttthhh_hb

好！请问VBA如何调用CAD里的color对话框？

mountains

在调用EXCEL时，如果EXCEL没有打开可以通过错误处理程序执行代码，通过公用对话框让用户打开特定的文件，代码如下： On Error Resume Next
Set appexcel = GetObject(, "excel.Application")
If Err Then
Err.Clear
Set appexcel = CreateObject("excel.Application")
Set workbooks = appexcel.workbooks
Set workbook = workbooks.Add
Set worksheet = workbook.ActiveSheet
Else
Set workbook = appexcel.ActiveWorkbook
Set worksheet = workbook.Sheets("sheet1")
End If

yancr0101

我经常使用这两个软件，数据、表格转换是常有的事，以前曾使用过维维软件的“报表转绘王”，但未注册用户一次只能转4行。


现在有了这段代码，真是太好了。

zhang007

谢谢！尽管我不大懂。

lotusfly

"rl = PToM(xlRange.Left)
rt = PToM(xlRange.top)
rw = PToM(xlRange.Width)
rh = PToM(xlRange.Height)"
xlRange.Height得到的数据，有时并不会由行高变化而变化！