efan2000 发表于 2002-11-26 19:27:25

[VBA程序]：Excel表格到CAD的示例程序



   
Sub Test()
    Dim xlApp As Excel.Application
    Set xlApp = GetObject(, "Excel.Application")
    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 xlRange As Range
    For Each xlRange In xlSheet.UsedRange
      AddLine BlockObj, xlRange
      AddText BlockObj, xlRange
    Next
    Set xlRange = Nothing
    Set xlSheet = Nothing
    Set xlApp = Nothing
End Sub

'边框处理
Sub AddLine(ByRef BlockObj As AcadBlock, ByVal xlRange As Range)
    Dim rl As Double
    Dim rt As Double
    Dim rw As Double
    Dim rh As Double
    rl = xlRange.Left / 2.835
    rt = xlRange.top / 2.835
    rw = xlRange.Width / 2.835
    rh = xlRange.Height / 2.835
    Dim pPt(0 To 3) As Double
    Dim pLineObj As AcadLWPolyline
    If xlRange.Borders(xlEdgeLeft).LineStyle <> xlNone And xlRange.Column = 1 Then
      pPt(0) = rl: pPt(1) = -rt
      pPt(2) = rl: pPt(3) = -(rl + rh)
      Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
      With xlRange.Borders(xlEdgeLeft)
            If .ColorIndex <> xlAutomatic Then
                If .ColorIndex = 3 Then
                  pLineObj.Color = acRed
                ElseIf .ColorIndex = 4 Then
                  pLineObj.Color = acGreen
                ElseIf .ColorIndex = 5 Then
                  pLineObj.Color = acBlue
                ElseIf .ColorIndex = 6 Then
                  pLineObj.Color = acYellow
                ElseIf .ColorIndex = 8 Then
                  pLineObj.Color = acCyan
                ElseIf .ColorIndex = 9 Then
                  pLineObj.Color = acMagenta
                End If
            End If
            If .Weight = xlThin Then
                pLineObj.ConstantWidth = 0
            ElseIf .Weight = xlMedium Then
                pLineObj.ConstantWidth = 0.35
            ElseIf .Weight = xlThick Then
                pLineObj.ConstantWidth = 0.7
            End If
      End With
    End If
    If xlRange.Borders(xlEdgeBottom).LineStyle <> xlNone And (xlRange.Row = xlRange.MergeArea.Row + xlRange.MergeArea.Rows.Count - 1) Then
      pPt(0) = rl: pPt(1) = -(rt + rh)
      pPt(2) = rl + rw: pPt(3) = -(rt + rh)
      Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
      With xlRange.Borders(xlEdgeBottom)
            If .ColorIndex <> xlAutomatic Then
                If .ColorIndex = 3 Then
                  pLineObj.Color = acRed
                ElseIf .ColorIndex = 4 Then
                  pLineObj.Color = acGreen
                ElseIf .ColorIndex = 5 Then
                  pLineObj.Color = acBlue
                ElseIf .ColorIndex = 6 Then
                  pLineObj.Color = acYellow
                ElseIf .ColorIndex = 8 Then
                  pLineObj.Color = acCyan
                ElseIf .ColorIndex = 9 Then
                  pLineObj.Color = acMagenta
                End If
            End If
            If .Weight = xlThin Then
                pLineObj.ConstantWidth = 0
            ElseIf .Weight = xlMedium Then
                pLineObj.ConstantWidth = 0.35
            ElseIf .Weight = xlThick Then
                pLineObj.ConstantWidth = 0.7
            End If
      End With
    End If
    If xlRange.Borders(xlEdgeRight).LineStyle <> xlNone And (xlRange.Column >= xlRange.MergeArea.Column + xlRange.MergeArea.Columns.Count - 1) Then
      pPt(0) = rl + rw: pPt(1) = -(rt + rh)
      pPt(2) = rl + rw: pPt(3) = -rt
      Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
      With xlRange.Borders(xlEdgeRight)
            If .ColorIndex <> xlAutomatic Then
                If .ColorIndex = 3 Then
                  pLineObj.Color = acRed
                ElseIf .ColorIndex = 4 Then
                  pLineObj.Color = acGreen
                ElseIf .ColorIndex = 5 Then
                  pLineObj.Color = acBlue
                ElseIf .ColorIndex = 6 Then
                  pLineObj.Color = acYellow
                ElseIf .ColorIndex = 8 Then
                  pLineObj.Color = acCyan
                ElseIf .ColorIndex = 9 Then
                  pLineObj.Color = acMagenta
                End If
            End If
            If .Weight = xlThin Then
                pLineObj.ConstantWidth = 0
            ElseIf .Weight = xlMedium Then
                pLineObj.ConstantWidth = 0.35
            ElseIf .Weight = xlThick Then
                pLineObj.ConstantWidth = 0.7
            End If
      End With
    End If
    If xlRange.Borders(xlEdgeTop).LineStyle <> xlNone And xlRange.top = 1 Then
      pPt(0) = rl + rw: pPt(1) = -rt
      pPt(2) = rl: pPt(3) = -rt
      Set pLineObj = BlockObj.AddLightWeightPolyline(pPt)
      With xlRange.Borders(xlEdgeTop)
            If .ColorIndex <> xlAutomatic Then
                If .ColorIndex = 3 Then
                  pLineObj.Color = acRed
                ElseIf .ColorIndex = 4 Then
                  pLineObj.Color = acGreen
                ElseIf .ColorIndex = 5 Then
                  pLineObj.Color = acBlue
                ElseIf .ColorIndex = 6 Then
                  pLineObj.Color = acYellow
                ElseIf .ColorIndex = 8 Then
                  pLineObj.Color = acCyan
                ElseIf .ColorIndex = 9 Then
                  pLineObj.Color = acMagenta
                End If
            End If
            If .Weight = xlThin Then
                pLineObj.ConstantWidth = 0
            ElseIf .Weight = xlMedium Then
                pLineObj.ConstantWidth = 0.35
            ElseIf .Weight = xlThick Then
                pLineObj.ConstantWidth = 0.7
            End If
      End With
    End If
    Set pLineObj = Nothing
End Sub

'文字处理
Sub AddText(ByRef BlockObj As AcadBlock, 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 = xlRange.Left / 2.835
    rt = xlRange.top / 2.835
    rw = xlRange.MergeArea.Width / 2.835
    rh = xlRange.MergeArea.Height / 2.835
    Dim iPt(0 To 2) As Double
    iPt(0) = rl: iPt(1) = -rt: iPt(2) = 0
    Dim mTextObj As AcadMText
    Set mTextObj = BlockObj.AddMText(iPt, rw, xlRange.Text)
    Dim tPt As Variant
    If xlRange.VerticalAlignment = xlTop And (xlRange.HorizontalAlignment = xlLeft Or xlRange.HorizontalAlignment = xlGeneral) Then
      mTextObj.AttachmentPoint = acAttachmentPointTopLeft
      mTextObj.InsertionPoint = 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

efan2000 发表于 2002-11-26 19:31:55

附上源代码，过一段时间等整个程序处理完后再上传。

efan2000 发表于 2002-11-27 14:22:12

附上两个从Excel中的磅单位到毫米单位换算的函数（1 毫米 = 2.835 磅）。

'磅换算成毫米
Function PointsToMillimeters(ByVal Points As Double) As Double
    PointsToMillimeters = Points * 0.3527778
End Function

''毫米换算成磅
Function MillimetersToPoints(ByVal Millimeters As Double) As Double
    MillimetersToPoints = Millimeters * 2.8346457
End Function

adian2000 发表于 2002-12-6 16:57:52

"If xlRange.Borders(xlEdgeTop).LineStyle <> xlNone And xlRange.top = 1 Then"
其中的应该为xlRange.top=0，或者xlRange.row=1

“    If xlRange.VerticalAlignment = xlTop And (xlRange.HorizontalAlignment = xlLeft Or xlRange.HorizontalAlignment = xlGeneral) Then
      mTextObj.AttachmentPoint = acAttachmentPointTopLeft
      mTextObj.InsertionPoint = iPt“
应该把mTextObj.InsertionPoint = iPt改成tpt＝ipt

“    If xlRange.Borders(xlEdgeLeft).LineStyle <> xlNone And xlRange.Column = 1 Then
      pPt(0) = rl: pPt(1) = -rt
      pPt(2) = rl: pPt(3) = -(rl + rh)”
改成ppt(3)=-(rt+rh)

不当之处，请谅解。

efan2000 发表于 2002-12-10 19:41:20

感谢adian2000和eachy提出的建议，希望更多的人能够对程序的进一步完善提供一些建议。
修改后的程序如下：


Sub Test()
    On Error Resume Next
    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

eachy 发表于 2002-12-10 20:15:24

Excel中自动换行的格转进CAD后没有换行。

efan2000 发表于 2002-12-10 20:42:08

可能是EXCEL的版本问题吧，先看看你安装的EXCEL中的换行符是不是ASC码为10的符号，如果不是，把Asc(Mid(xlRange.Text, i, 1)) = 10这句后的10更改掉。

lijiao 发表于 2002-12-11 09:19:45

CAD里的图形能和EXCEL关联吗？即EXCEL的内容改变后，CAD里的图形能自动更新吗？

efan2000 发表于 2002-12-11 09:49:39

这个你可以通过事件来触发，达到动态更新，如文档激活或者执行命令时，这些主要是自己怎么控制了。

game8888 发表于 2002-12-11 11:22:51

我想要一个可以向excel中自动填写数据的程序。

efan2000 发表于 2002-12-11 12:49:17

向EXCEL中传输数据，要知道怎么提取CAD的数据，如文本。在EXCEL中怎么处理，如从哪个单元格开始放置。给个具体的说明吧。

wowoaicad 发表于 2002-12-12 11:37:37

斑竹，能做个动画演示吗？谢谢！

tiansong 发表于 2003-1-15 22:41:45

能再加一些注释吗

efan2000 发表于 2003-1-16 19:15:18

大家可以先看看帮助文件，有什么不明白的地方再提出来。
有兴趣的朋友可以接着往下探索，让Excel和AutoCAD最大限度的发挥各自的长处，有益于自己的工作和学习。

entrophy 发表于 2003-2-2 18:16:25

我有一套龙震的关于excel和cad通信程序
下次放上来
页: [1] 2 3 4 5 6 7 8 9
查看完整版本: [VBA程序]：Excel表格到CAD的示例程序