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

jackseel 发表于 2022-7-6 22:20:26

嗨seant

我试着用vba编码，但显示所有的多段线。。。

我需要。。。“在excel工作表中显示选定多段线（按图层）的属性。。

我从这里得到了一个用于多段线测量的lisp文件（名称：-“zone”）。。它给出了选定多段线的总面积/长度（逐层）。。

你能根据lisp编码PLSSS进行vba编码吗？

在这里，我添加了lisp编码，我在这里得到的形式。。。。。。。。。。。

; 按层测量多段线的面积和长度
; 适用于轻型（优化）多段线和旧格式多段线
; PLINETYPE系统变量不受影响
;
; David Watson 1995，2003年更新
;
（定义c：区域（/ssl aret pert）
（princ“\n点击所需层上的任何对象”）
（setq ssl（ssget））
（if（=ssl nil）（princ“\n***未选择任何内容！***\n\n”）
（程序
（setq lay（cdr（assoc 8（entget（ssname ssl 0 1070;）Ю））））
（setq ssl（ssget“X”（列表（cons 8层）））
（princ（strcat“LAYER”lay“selected”））
（initget“长度区域”）
（setq res（getkword“\n您想测量长度/：”）
（if（=res“长度”）（mlen）（meas））
);结束程序
);如果结束
（普林斯）
);结束区域
（defun meas（）
（setq len（sslength ssl））
（setq alen（sslength ssl））
（setq aret 0）
（setq计数0）
（setq nop 0）
（setq ope 0）
（while（/=长度计数）
（setq pnt（ssname ssl计数））
（setq ple（cdr（assoc 0（entget pnt）））
（if（and（/=ple“LWPOLYLINE”）（/=ple“POLYLINE”））
（程序
（setq nop（+1 nop））
（setq alen（-alen 1））
（princ“\n非多段线过滤”）
);结束程序
（程序
（setq plc（cdr（assoc 70（entget pnt）））
（如果（=plc 0）
（程序
（setq ope（+1 ope））
（普林斯“\n警告！***多段线未闭合”）
);结束程序
);如果结束
（命令“area”“e”pnt）
（setq是（getvar“area”））
（setq aret（+aret））
);结束程序
);如果结束
（setq计数（+计数1））
);结束时
（if（=nop 0）（princ“\n所有选择的对象都是多段线”）（princ（strcat“\n”（itoa nop）“过滤了非多段线对象”））
（如果（=ope 0）（princ“所有多段线均已闭合”）（princ（strcat“n”（itoa ope）“多段线未闭合”））
（princ（strcat”\n层“lay”的总面积=“（rtos aret 2 0）”m2或“（rtos（/aret 10000）2 2）”Ha in“（itoa alen）”区域）
（普林斯）
);结束测量
（defun mlen（）
（setq len（sslength ssl））
（setq alen（sslength ssl））
（setq pert 0）
（setq计数0）
（setq nop 0）
（while（/=长度计数）
（setq pnt（ssname ssl计数））
（setq ple（cdr（assoc 0（entget pnt）））
（if（and（/=ple“LWPOLYLINE”）（/=ple“POLYLINE”））
（程序
（setq nop（+1 nop））
（setq alen（-alen 1））
（princ“\n非多段线过滤”）
);结束程序
（程序
（命令“area”“e”pnt）
（setq per（getvar“周长”））
（setq pert（+每pert））
);结束程序
);如果结束
（setq计数（+计数1））
);结束时
（if（=nop 0）（princ“\n所有选择的对象都是多段线”）（princ（strcat“\n”（itoa nop）“过滤了非多段线对象”））
（princ（strcat“\n层“lay”的总长度=“（rtos pert 2 1）”m或“（rtos（/pert 0.3048）2 0）”英尺英寸“（itoa alen）”长度）
（普林斯）
);结束MLEN

SEANT 发表于 2022-7-6 22:25:00

下面是一个更新的例程，用于添加类似Lisp代码的功能。我希望这会有帮助。

应观察该网站及其所有成员的“帮助性”。很明显，我们都喜欢在力所能及的地方提供帮助。然而，这是一个基于教学的网站，因此最终目标是帮助他人学习AutoCAD的各个方面。

关于Lisp或VBA，帮助性和响应性太高可能会帮助一个人学习编程。

伴随此消息的例程可能不适合VBA教程（或者可能是），但它应该允许特定的编码问题。如果您需要对代码进行进一步修改，我将尽我所能回答这些问题。

Option Explicit

Sub PutPLProps2XL()
Dim strLayName As String
strLayName = GetObjectLayer()
If strLayName <> "" Then
If ClosedPLSS(strLayName) 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
Set objExcel = Nothing
End If
End If
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(strLayName As String) As Boolean
Dim intCode(21) As Integer
Dim varData(21) 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) = 8: varData(11) = strLayName
intCode(12) = -4: varData(12) = "And>"

intCode(13) = -4: varData(13) = "<And"
   intCode(14) = 0: varData(14) = "LWPOLYLINE" 'or closed LWP's
   intCode(15) = -4: varData(15) = "&="
   intCode(16) = 70: varData(16) = 1
   intCode(17) = -4: varData(17) = "&"
   intCode(18) = 70: varData(18) = 129
   intCode(19) = 8: varData(19) = strLayName
intCode(20) = -4: varData(20) = "And>"
intCode(21) = -4: varData(21) = "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

Function GetObjectLayer() As String
Dim ent As AcadEntity
Dim varPickPT As Variant
On Error GoTo errHandler
ThisDrawing.Utility.GetEntity ent, varPickPT, "Select an entity on a layer with which to focus: "
GetObjectLayer = ent.Layer
Exit Function
errHandler:
GetObjectLayer = ""
End Function

jackseel 发表于 2022-7-6 22:28:48

谢谢你。。。

gio 发表于 2022-7-6 22:31:59

肖恩，

我试着用VB版本使用你的代码。6.3、Excell 2003，出现以下消息：

“未定义用户定义的类型”位于第Dim objExcel行的Excel。应用

正如你所见，我是用VB的begginer。我能做什么？
非常感谢。

dbroada 发表于 2022-7-6 22:35:31

这就是为什么我试着为人们指出正确的方向，而不是为他们编写代码。事实上，我很少真正完成我的代码。

SEANT 发表于 2022-7-6 22:37:10

见本帖第6篇。这可能与您描述的问题有关。

你说你在用VB 6.3；您是指Autocad VBA 6.3还是VB6。如果是后者，您可能会在上述代码中遇到更多问题，因为所有Autocad对象都需要修改。

SEANT 发表于 2022-7-6 22:41:06

我想你的意思是“公众消费的防弹密码”

我很想在定制中发布一个民意调查，以确定程序员在多大程度上使他们的代码不易破坏。我写过的任何东西的大多数用户都可以直接访问我，所以我往往很松懈。最近，我加强了错误处理，但这个过程可以将开发时间加倍，以获得真正牢不可破的代码。

xxfaxx 发表于 2022-7-6 22:42:46

我有个问题
当我尝试使用它时，我得到一个错误“编译错误：变量未定义”
这部分代码用黄色突出显示
函数FilteredSS（可选grpCode为Variant，可选dataVal为Variant）为Integer

我已经照你在帖子里说的做了

SEANT 发表于 2022-7-6 22:45:16

我已经有很长时间没有启动ol'VBAIDE了。我复制并粘贴了代码，并设置了适当的引用（Microsoft Excel 16.0对象库），代码似乎运行良好。

是否有可能在转移例程时，部分代码没有被复制？

xxfaxx 发表于 2022-7-6 22:49:39

不，我查了两次
我使用autocad 2017和excel 2010。也许有问题。
这个帖子是从2007年开始的。

页: 1 [2]

乐筑天下's Archiver