Excel报表到CAD的示例程序(来自明经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 = NothingEnd 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 SelectEnd 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 SelectEnd 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 = NothingEnd 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 = NothingEnd Sub' 磅换算成毫米 ' 注：意义不大，转换的尺寸有偏差，最好自己设定一个转换规则。Function PToM(ByVal Points As Double) As Double    PToM = Points * 0.3527778End Function