Excel表格到CAD的示例程序
增加了一小部分注释，希望对大家有所帮助。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
谢谢楼主分享!{:1_1:} 坚决支持，虽然看不太懂 表格处理模块详细设计作者：efan2000
模块设计说明模块概述
产生背景：AutoCAD表格绘制、工程计算的功能十分的薄弱，但实际应用中，这两项功能是不可缺少的，因而，需要一种简便的方法来弥补这种缺陷。Excel是表格处理软件，带有强大的计算功能，而且开发方便，正好可以利用。因此，就可以通过Excel计算、制表，然后转化到AutoCAD来实现AutoCAD表格的生成。
平台环境：Excel、AutoCAD、VBA。
技术介绍：使用VBA，采用OLE方式对Excel、AutoCAD进行二次开发，实现功能的扩充。
功能说明：1、表格的边框处理模块：如边框的线型、颜色、线重等。
2、表格的文字处理模块：如文字的字体、字号、颜色等。未完成...，欢迎大家来共同完善。 很好的例子,我用了不知道是什么原因,转换后有很多"?"号
还有能否给给详细点的说明,我真的学这个,有些地方还看不懂,
转换规则应该怎样指定 我熟悉CAD，Excel，Vlisp,可惜唯独不懂VBA。我也急需这种好程序，不知哪位大侠肯告诉我把上面的程序放到哪里，文件名后缀为什么，如何加载，加载后命名为什么。最后请高手指点VBA书籍中高，中，低级最好为哪三本。在下万分感激。
----------------------------------------------<BR><A href="mailto:wyj_007@sina.com" target="_blank" >wyj_007@sina.com</A>
隔行如隔山，此话真不假！但愿有仙人，渡我披新袈。 好！请问VBA如何调用CAD里的color对话框？ 在调用EXCEL时，如果EXCEL没有打开可以通过错误处理程序执行代码，通过公用对话框让用户打开特定的文件，代码如下：
On Error Resume Next<BR> Set appexcel = GetObject(, "excel.Application")<BR> If Err Then<BR> Err.Clear<BR> Set appexcel = CreateObject("excel.Application")<BR> Set workbooks = appexcel.workbooks<BR> Set workbook = workbooks.Add<BR> Set worksheet = workbook.ActiveSheet<BR> Else<BR> Set workbook = appexcel.ActiveWorkbook<BR> Set worksheet = workbook.Sheets("sheet1")<BR> End If 我经常使用这两个软件，数据、表格转换是常有的事，以前曾使用过维维软件的“报表转绘王”，但未注册用户一次只能转4行。
现在有了这段代码，真是太好了。 谢谢！尽管我不大懂。 "rl = PToM(xlRange.Left)<BR> rt = PToM(xlRange.top)<BR> rw = PToM(xlRange.Width)<BR> rh = PToM(xlRange.Height)"<BR>
xlRange.Height得到的数据，有时并不会由行高变化而变化！