Excel表格到autoCAD

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

原文轉自：http://www.anti-gravitydesign.com