此贴内容原作者为“明经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