社区 › VB › Excel VBA选择多段线并将区域带回Excel

mstg007 发表于 2014-3-6 13:26:22

Excel VBA选择多段线并将区域带回Excel

是否有excel vba，如果我按下一个按钮，它将进入autocad会话，我会选择一条多段线，然后将值报告回我开始的excel电子表格？（面积、z等）？

RICVBA 发表于 2014-3-6 14:02:37

选项显式Sub PickLwPolyAndGetData()
   
    Dim MyCell As Range
    Dim ACAD As AcadApplication
    Dim LWPoly As AcadLWPolyline
    Dim ThisDrawing As AcadDocument
    Dim Pt1 As Variant
    Dim LWArea As Double, LWZ As Double
    ' Autocad Session handling
    On Error Resume Next
    Set ACAD = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    If ACAD Is Nothing Then
      Set ACAD = New AcadApplication
      ACAD.Visible = True
    End If
    Set ThisDrawing = ACAD.ActiveDocument
         
   
    ' select LwPolyline
    On Error Resume Next
    Do
      Err.Clear
      ThisDrawing.Utility.GetEntity LWPoly, Pt1, "Select a Polyline:"
    Loop While Err
    On Error GoTo 0
   
   
    'get LWPoly data
    With LWPoly
      LWArea = .Area
      LWZ = .Elevation
    End With
   
    ' write LWPoly data on worksheet
    Set MyCell = ActiveCell
    With MyCell
      .Offset(0, 0).Value = "Area:"
      .Offset(0, 1).Value = LWArea
      .Offset(1, 0) = "Z:"
      .Offset(1, 0) = LWZ
    End With
   
    Set ThisDrawing = Nothing
    Set ACAD = Nothing
   
End Sub
再见

mstg007 发表于 2014-3-6 14:07:02

太酷了。我可以让用户同时选择一组多段线吗？

RICVBA 发表于 2014-3-6 15:57:26

当然最简单的方法可以用一个；“边做边做”；在“之间循环代码行”'选择“LWPolyline”；到第二个“；以“结束”；。用一个适当的“；而；条件
否则，您可以在屏幕上添加一个选择集，然后循环通过这种方式收集的LW多段线。

mstg007 发表于 2014-3-6 16:00:09

如果你不介意的话，我可以举个例子吗？你所做的是一个巨大的垫脚石
我们有一些多段线，其中有需要放入电子表格的区域

RICVBA 发表于 2014-3-7 02:04:37

试试这个Sub PickLwPolysAndGetData()
   
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As Range
'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double
' Autocad Session handling
    On Error Resume Next
    Set ACAD = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    If ACAD Is Nothing Then
      Set ACAD = New AcadApplication
      ACAD.Visible = True
    End If
    Set ThisDrawing = ACAD.ActiveDocument
      
' selecting LwPolylines on screen by selelection set filtering method
    ' managing potential selection set exsistence
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
    If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
    On Error GoTo 0
    ssetObj.Clear
   
    'setting filtering critera
    gpCode(0) = 0
    dataValue(0) = "LWPOLYLINE"
   
    'selecting LWPolylines
    ssetObj.SelectOnScreen gpCode, dataValue
' processing LWPolylines
    If ssetObj.Count > 0 Then
   
      ' writing sheet headings
      Set MySht = ActiveSheet
      Set MyCell = MySht.Cells(1, 1)
      With MyCell
            .Offset(0, 0).Value = "LWPoly nr"
            .Offset(0, 1).Value = "Area"
            .Offset(0, 2) = "Z"
      End With
      
      'clearing previous written data
      iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
      If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 3).Clear
      
      'retrieving LWPolys data and writing them on worksheet
      iRow = 1
      For Each LWPoly In ssetObj
            'retrieving LWPoly data
            With LWPoly
                LWArea = .Area
                LWZ = .Elevation
            End With
            
            ' writing LWPoly data
            With MyCell
                .Offset(iRow, 0).Value = "LWPoly nr." & iRow
                .Offset(iRow, 1).Value = LWArea
                .Offset(iRow, 2) = LWZ
            End With
            iRow = iRow + 1
      Next LWPoly
      
    End If
' cleaning up before ending
    ssetObj.Delete
    Set ssetObj = Nothing
    Set ThisDrawing = Nothing
    Set ACAD = Nothing
End Sub 再见

mstg007 发表于 2014-3-8 15:01:10

美好的谢谢分享！当它在同一个标高上寻找区域时……它能在将其放入单元格之前自动将这些区域添加到一起吗？

RICVBA 发表于 2014-3-10 03:53:12

it#039；通过一些求和的方式，直接在excel中进行更简单的操作。IF函数，读取C列值（“Z”值）并对相应的B列值（“面积”值）求和

mstg007 发表于 2014-4-16 16:10:44

好我升级到了下一个cad版本！无论如何，现在当我运行我的宏时，我得到了一个错误；13':
类型不匹配调试：For Each LWPoly In ssetObj 任何帮助都会很棒！它在以前的cad版本中确实有效
Sub Import_POLYLINES()
   
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As range
'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double
' Autocad Session handling
    On Error Resume Next
    Set ACAD = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    If ACAD Is Nothing Then
      Set ACAD = New AcadApplication
      ACAD.Visible = True
    End If
    Set ThisDrawing = ACAD.ActiveDocument
      
' selecting LwPolylines on screen by selelection set filtering method
    ' managing potential selection set exsistence
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
    If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
    On Error GoTo 0
    ssetObj.Clear
   
    'setting filtering critera
    gpCode(0) = 0
    dataValue(0) = "LWPOLYLINE"
   
    'selecting LWPolylines
    ssetObj.SelectOnScreen gpCode, dataValue
' processing LWPolylines
    If ssetObj.Count > 0 Then
   
      ' writing sheet headings
      Set MySht = ActiveSheet
      Set MyCell = MySht.Cells(11, 1) 'Where to Start the Excel Cell Input X, Y
      With MyCell
            '.Offset(0, 0).Value = "LWPoly nr"
            '.Offset(0, 1).Value = "Area S.F."
            '.Offset(0, 0) = "Elevation"
      End With
      
      'clearing previous written data
      iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
      If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 2).Clear
      
      'retrieving LWPolys data and writing them on worksheet
      iRow = 1
      For Each LWPoly In ssetObj
      
            'retrieving LWPoly data
            With LWPoly
                LWArea = .area
                LWZ = .Elevation
            End With
            
             ' writing LWPoly data
            With MyCell
                '.Offset(iRow, 0).Value = "LWPoly nr." & iRow
                .Offset(iRow, 1).Value = LWArea
                .Offset(iRow, 0) = LWZ
            End With
            iRow = iRow + 1
       Next LWPoly
      
   End If
' cleaning up before ending
    ssetObj.Delete
    Set ssetObj = Nothing
    Set ThisDrawing = Nothing
    Set ACAD = Nothing
End Sub

mstg007 发表于 2014-4-16 20:36:17

对于ssetObj中的每个LWPOLYNE，使用以下方式代替：
将oEnt作为身份识别。对于ssetObj中的每一个oEnt，如果oEnt的类型是AcadLWpolyline，则设置LWPoly=ent' 一些rest使用多段线end if next类似于这样的东西，只是从内存中

查看完整版本: Excel VBA选择多段线并将区域带回Excel