Auto cad-->excel

jackseel · 发表于 2022-7-6 21:48:18

你好
我需要帮助。那么，如何自动获取excel工作表中的多段线长度/面积。。

因为，当我通过多段线测量面积/长度时，我必须从列表中复制并手动粘贴到excel单元格。。因此，这需要花费大量时间来测量更多的多段线。。

请帮助我朋友

提前感谢

rkmcswain · 发表于 2022-7-6 21:52:43

如果您愿意购买少量商品，请查看AutoCELL@http://www.dotsoft.com/autocell.htm

如果您喜欢这样做，或者认识这样的人，也可以用lisp或VBA对您的要求进行编码。

jackseel · 发表于 2022-7-6 21:56:56

谢谢你的回复。。rkmcswain公司

请帮助我，任何人，谁知道lisp或VBA为我的需要。。。

谢谢

SEANT · 发表于 2022-7-6 21:58:07

下面是一些VBA代码，它们是从一个更大的例程中分离出来的（即，可能需要进一步调整），该例程基本上可以满足您的要求。它会自动选择所有闭合多段线-轻量级、二维（拟合或花键连接）-并将信息发送到通用excel文件。

VBAIDE必须为您的Excel版本设置引用集。

copy

Option Explicit
Sub PutPLProps2XL()
  If ClosedPLSS Then
     Dim objSS As AcadSelectionSet
     Dim entEntity As AcadEntity
     Dim objExcel As Excel.Application
     Dim objRange As Excel.Range
     Dim entLWPoly As AcadLWPolyline
     Dim ent2DPoly As AcadPolyline
     Dim intCount As Integer
     On Error GoTo errhandler
     Set objExcel = GetObject(, "Excel.Application")
     On Error GoTo 0
     Set objRange = objExcel.ActiveWorkbook.ActiveSheet.Range("A1")
     objRange.value = "Pline Type"
     objRange.Offset(0, 1).value = "Length"
     objRange.Offset(0, 2).value = "Area"
        Set objSS = ThisDrawing.SelectionSets.Item("TempSSet")
        For intCount = 0 To objSS.count - 1
           Set entEntity = objSS.Item(intCount)
           If entEntity.ObjectName = "AcDbPolyline" Then
              Set entLWPoly = entEntity
              objRange.Offset(intCount + 1, 0).value = "LWPolyline"
              objRange.Offset(intCount + 1, 1).value = entLWPoly.Length
              objRange.Offset(intCount + 1, 2).value = entLWPoly.Area
           Else
              Set ent2DPoly = entEntity
              objRange.Offset(intCount + 1, 0).value = "2DPolyline"
              objRange.Offset(intCount + 1, 1).value = ent2DPoly.Length
              objRange.Offset(intCount + 1, 2).value = ent2DPoly.Area
           End If
        Next
  End If
  Exit Sub
errhandler:
  Set objExcel = CreateObject("Excel.Application")
  Resume Next
End Sub
Function ClosedPLSS() As Boolean
  Dim intCode(19) As Integer
  Dim varData(19) As Variant
  ClosedPLSS = False
  intCode(0) = -4: varData(0) = "<Or"
     intCode(1) = -4: varData(1) = "<And"
        intCode(2) = 0: varData(2) = "POLYLINE" 'or closed PLINES's
        intCode(3) = -4: varData(3) = "&="
        intCode(4) = 70: varData(4) = 1
        intCode(5) = -4: varData(5) = "&"
        intCode(6) = 70: varData(6) = 135
        intCode(7) = -4: varData(7) = "<Not"
           intCode( = -4: varData( = "&="
           intCode(9) = 70: varData(9) = 8
        intCode(10) = -4: varData(10) = "Not>"
     intCode(11) = -4: varData(11) = "And>"
     
     intCode(12) = -4: varData(12) = "<And"
        intCode(13) = 0: varData(13) = "LWPOLYLINE" 'or closed LWP's
        intCode(14) = -4: varData(14) = "&="
        intCode(15) = 70: varData(15) = 1
        intCode(16) = -4: varData(16) = "&"
        intCode(17) = 70: varData(17) = 129
     intCode(18) = -4: varData(18) = "And>"
  intCode(19) = -4: varData(19) = "Or>"
  
  If FilteredSS(intCode, varData) > 0 Then ClosedPLSS = True
End Function
Private Sub SSPrep()
Dim SSS As AcadSelectionSets
  'choose a selection set name for temporary storage and
  'ensure that it does not currently exist
  On Error Resume Next
  Set SSS = ThisDrawing.SelectionSets
     If SSS.count > 0 Then
        SSS.Item("TempSSet").Delete
     End If
End Sub
Function FilteredSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
  Dim TempObjSS As AcadSelectionSet
  SSPrep
  Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'generate selection set
     TempObjSS.Select acSelectionSetAll, , , grpCode, dataVal
  FilteredSS = TempObjSS.count
End Function

jackseel · 发表于 2022-7-6 22:03:21

谢谢你的回复。。。。

我尝试了你的vba，但它显示错误。。。我想，原因是excel版本。。。

我正在使用Excel 2002和auto cad 2004。。所以，请帮助我获取这个版本。。

谢谢和问候

SEANT · 发表于 2022-7-6 22:05:29

可以通过“工具参考”菜单项（如图所示）设置对Excel正确版本的参考。我使用的是Excel 2003，因此您可能会选择“Microsoft Excel 10.0对象库”

如果这不是错误的原因，请发布实际的错误消息，我们将尝试解决它。

jackseel · 发表于 2022-7-6 22:09:14

现在，它是工作的朋友。。。。。谢谢你。。。。

jackseel · 发表于 2022-7-6 22:11:33

亲爱的朋友肖特。。。

请在此提供帮助。。。

你的编码工作得很好。

但是，我需要。。。。。

“在excel工作表中显示选定的多段线属性（如图层名、面积、长度）…”

请帮忙。。。。。。。

谢谢

SEANT · 发表于 2022-7-6 22:14:52

下面的代码还记录了PLINE的图层特性。一些事情被重新安排为新的财产序列。我还修复了errorhandler部分。

注意：这个例程无法描述地记录了所有闭合的pline。“选定”Pline需要修改代码。

鉴于这是一个基于“导师”的网站，也许你应该告诉我如何记录普林斯线型。查看这两个代码示例是如何更改的，以及在Excel中的效果。现在将线型（.linetype）添加到列表中。如果有任何问题，请随时提问。

copy

 Option Explicit
Sub PutPLProps2XL()
  If ClosedPLSS Then
     Dim objSS As AcadSelectionSet
     Dim entEntity As AcadEntity
     Dim objExcel As Excel.Application
     Dim objRange As Excel.Range
     Dim entLWPoly As AcadLWPolyline
     Dim ent2DPoly As AcadPolyline
     Dim intCount As Integer
     On Error GoTo errhandler
     Set objExcel = GetObject(, "Excel.Application")
     On Error GoTo 0
     Set objRange = objExcel.ActiveWorkbook.ActiveSheet.Range("A1")
     objRange.value = "Layer"
     objRange.Offset(0, 1).value = "Pline Type"
     objRange.Offset(0, 2).value = "Length"
     objRange.Offset(0, 3).value = "Area"
        Set objSS = ThisDrawing.SelectionSets.Item("TempSSet")
        For intCount = 0 To objSS.count - 1
           Set entEntity = objSS.Item(intCount)
           If entEntity.ObjectName = "AcDbPolyline" Then
              Set entLWPoly = entEntity
              objRange.Offset(intCount + 1, 0).value = entLWPoly.Layer
              objRange.Offset(intCount + 1, 1).value = "LWPolyline"
              objRange.Offset(intCount + 1, 2).value = entLWPoly.Length
              objRange.Offset(intCount + 1, 3).value = entLWPoly.Area
           Else
              Set ent2DPoly = entEntity
              objRange.Offset(intCount + 1, 0).value = ent2DPoly.Layer
              objRange.Offset(intCount + 1, 1).value = "2DPolyline"
              objRange.Offset(intCount + 1, 2).value = ent2DPoly.Length
              objRange.Offset(intCount + 1, 3).value = ent2DPoly.Area
           End If
        Next
  End If
  Set objExcel = Nothing
  Exit Sub
errhandler:
  Err.Clear
  Set objExcel = CreateObject("Excel.Application")
  With objExcel
     .Workbooks.Add
     .Visible = True
     .WindowState = xlMinimized
  End With
  Resume Next
End Sub
Function ClosedPLSS() As Boolean
  Dim intCode(19) As Integer
  Dim varData(19) As Variant
  ClosedPLSS = False
  intCode(0) = -4: varData(0) = "<Or"
     intCode(1) = -4: varData(1) = "<And"
        intCode(2) = 0: varData(2) = "POLYLINE" 'or closed PLINES's
        intCode(3) = -4: varData(3) = "&="
        intCode(4) = 70: varData(4) = 1
        intCode(5) = -4: varData(5) = "&"
        intCode(6) = 70: varData(6) = 135
        intCode(7) = -4: varData(7) = "<Not"
           intCode( = -4: varData( = "&="
           intCode(9) = 70: varData(9) = 8
        intCode(10) = -4: varData(10) = "Not>"
     intCode(11) = -4: varData(11) = "And>"
     
     intCode(12) = -4: varData(12) = "<And"
        intCode(13) = 0: varData(13) = "LWPOLYLINE" 'or closed LWP's
        intCode(14) = -4: varData(14) = "&="
        intCode(15) = 70: varData(15) = 1
        intCode(16) = -4: varData(16) = "&"
        intCode(17) = 70: varData(17) = 129
     intCode(18) = -4: varData(18) = "And>"
  intCode(19) = -4: varData(19) = "Or>"
  
  If FilteredSS(intCode, varData) > 0 Then ClosedPLSS = True
End Function
Private Sub SSPrep()
Dim SSS As AcadSelectionSets
  'choose a selection set name for temporary storage and
  'ensure that it does not currently exist
  On Error Resume Next
  Set SSS = ThisDrawing.SelectionSets
     If SSS.count > 0 Then
        SSS.Item("TempSSet").Delete
     End If
End Sub
Function FilteredSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
  Dim TempObjSS As AcadSelectionSet
  SSPrep
  Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'generate selection set
     TempObjSS.Select acSelectionSetAll, , , grpCode, dataVal
  FilteredSS = TempObjSS.count
End Function

jackseel · 发表于 2022-7-6 22:17:44

非常感谢你。。。朋友肖特。。

我将使用此编码，并尽快发送反馈和其他需求。。

谢谢Againnn

[编程交流] Auto cad-->excel

发表回复

精选推荐