您当前的位置: 此贴内容原作者为“明经CAD社区”的“efan2000”。原贴链接如下：
http://bbs.mjtd.com/dispbbs.asp?boardid=16&Id=16244
本人觉得较为精典，故在此贴出，供更多网友参考。
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