专注收集记录技术开发学习笔记、技术难点、解决方案
网站信息搜索 >> 请输入关键词:
您当前的位置: 首页 > AutoCAD

Excel报表到CAD的示例程序(来自明经CAD社区)

发布时间:2011-06-27 19:20:55 文章来源:www.iduyao.cn 采编人员:星星草
Excel表格到CAD的示例程序(来自明经CAD社区)
此贴内容原作者为“明经CAD社区”的“efan2000”。原贴链接如下:
http://bbs.mjtd.com/dispbbs.asp?boardid=16&Id=16244
本人觉得较为精典,故在此贴出,供更多网友参考。
VB code

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

友情提示:
信息收集于互联网,如果您发现错误或造成侵权,请及时通知本站更正或删除,具体联系方式见页面底部联系我们,谢谢。

其他相似内容:

热门推荐: