Auto cad->excel 乐筑天下 - Powered by Discuz! Archiver

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

Auto cad-->excel

你好
我需要帮助。那么，如何自动获取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版本设置引用集。

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）添加到列表中。如果有任何问题，请随时提问。

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

页: [1] 2

乐筑天下's Archiver

Auto cad-->excel