需要基本LISP帮助

FrankPB · 发表于 2022-7-5 15:16:35

我有一个重复的任务，涉及将房间区域插入属性块。目前，我正在使用标准的“区域”命令，从小数点开始倒数六位，在心里记下结果并将其插入块中，这在很长一段时间内变得很累并且容易出错。我相信一定有一个更简单的方法，但尽管我可能尝试，但我似乎无法掌握创建或修改甚至是一个简单的例程，成功地工作。
我正在运行Autocad 2008（十进制单位，1个单位代表1毫米）

程序要求如下：-
选择多段线（通过手动拾取）
计算面积（平方毫米）
换算为平方米（除以100000）
将结果减少到小数点后两位
复制到剪贴板
手动选择属性块
将平方米值粘贴到属性中
并用下一条多段线等重复

最初，我试图生成一个例程，该例程允许我选择多段线，然后选择块（它位于多段线边界内），并将区域插入属性中，但在编程过程中遇到了困难，选择了上面更简单的替代方案。

有谁能提供一些最简单的建议吗？

当做

jammie · 发表于 2022-7-5 15:20:49

你能发布一个到目前为止你拥有的代码示例吗？

以上所有内容都可以通过lisp实现

FrankPB · 发表于 2022-7-5 15:25:14

杰米
希望我附上了两个文件供您参考
帕雷亚。lsp
平面布置图。图纸

Lee Mac · 发表于 2022-7-5 15:27:22

我不久前为另一个线程写了这个，使用字段：

copy


(defun c:GetAreas (/ *error* lst->str DOC IDS PT SS UFLAG)
 (vl-load-com)
 ;; Lee Mac  ~  18.03.10
 (defun *error* (msg)
   (and uFlag (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))
 (defun GetObjectID (obj)
   (setq util (cond (util) ((vla-get-Utility
                              (vla-get-ActiveDocument (vlax-get-acad-object))))))
   
   (if (vl-string-search "X64" (strcase (getvar 'PLATFORM)))
     (vlax-invoke-method util 'GetObjectIdString obj :vlax-false)
     (itoa (vla-get-Objectid obj))))     
 (defun lst->str (lst d1 d2)
   (if (cdr lst)
     (strcat d1 (car lst) d2 (lst->str (cdr lst) d1 d2))
     (strcat d1 (car lst))))
 (princ "\nSelect Objects to Retrieve Total Area... ")
 (if (and (ssget '((0 . "ARC,CIRCLE,ELLIPE,HATCH,*POLYLINE,REGION")))
          (setq pt (getpoint "\nPick Point for Field: ")))
   (progn
     (setq uFlag (not (vla-StartUndoMark
                        (setq doc (vla-get-ActiveDocument
                                    (vlax-get-acad-object))))))
     
     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
       (setq Ids (cons (GetObjectID obj) Ids)))
     (vla-delete ss)
     (vla-AddMText
       (if (or (eq AcModelSpace (vla-get-ActiveSpace doc))
               (eq :vlax-true   (vla-get-MSpace doc)))
         (vla-get-ModelSpace doc)
         (vla-get-PaperSpace doc))
       (vlax-3D-point pt) 0.
       (if (= 1 (length Ids))
         (strcat "%<\\AcObjProp Object(%<\\_ObjId " (car Ids) ">%).Area \\f "%lu6%qf1">%")
         (strcat "%<\\AcExpr" (lst->str Ids " %<\\AcObjProp Object(%<\\_ObjId " ">%).Area >% +")
                 ">%).Area >% \\f "%lu6%qf1">%")))
     (setq uFlag (vla-EndUndomark doc))))
 (princ))

Lee Mac · 发表于 2022-7-5 15:31:06

或用于放置到现有文本/属性中：

copy


(defun c:GetAreas (/ *error* lst->str GetObjectID DOC ENT IDS SS UFLAG UTIL)
 (vl-load-com)
 ;; Lee Mac  ~  18.03.10
 (defun *error* (msg)
   (and uFlag (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))
 (defun GetObjectID (obj)
   (setq util (cond (util) ((vla-get-Utility
                              (vla-get-ActiveDocument (vlax-get-acad-object))))))
   
   (if (vl-string-search "X64" (strcase (getvar 'PLATFORM)))
     (vlax-invoke-method util 'GetObjectIdString obj :vlax-false)
     (itoa (vla-get-Objectid obj))))     
 (defun lst->str (lst d1 d2)
   (if (cdr lst)
     (strcat d1 (car lst) d2 (lst->str (cdr lst) d1 d2))
     (strcat d1 (car lst))))
 (princ "\nSelect Objects to Retrieve Total Area... ")
 (if (and (ssget '((0 . "ARC,CIRCLE,ELLIPE,HATCH,*POLYLINE,REGION")))
          (setq ent (car (nentsel "\nSelect Text, MText or Attrib to Place: ")))
          (wcmatch (cdr (assoc 0 (entget ent))) "*TEXT,ATTRIB"))                          
   (progn
     (setq uFlag (not (vla-StartUndoMark
                        (setq doc (vla-get-ActiveDocument
                                    (vlax-get-acad-object))))))
     
     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
       (setq Ids (cons (GetObjectID obj) Ids)))
     (vla-delete ss)
     (vla-put-TextString
       (vlax-ename->vla-object ent)
       (if (= 1 (length Ids))
         (strcat "%<\\AcObjProp Object(%<\\_ObjId " (car Ids) ">%).Area \\f "%lu6%qf1">%")
         (strcat "%<\\AcExpr" (lst->str Ids " %<\\AcObjProp Object(%<\\_ObjId " ">%).Area >% +")
                 ">%).Area >% \\f "%lu6%qf1">%")))
     (vla-regen doc acActiveViewport)
     (setq uFlag (vla-EndUndomark doc))))
 (princ))

FrankPB · 发表于 2022-7-5 15:33:24

非常感谢您的及时回复。我在这件事上胡闹了好几年，但都没有成功。您发送的用于将区域加载到属性中的第二个例程完全没有从平方毫米到平方米的转换。

Lee Mac · 发表于 2022-7-5 15:38:01

别担心，弗兰克

copy


(defun c:GetAreas (/ *error* lst->str GetObjectID DOC ENT IDS SS UFLAG UTIL)
 (vl-load-com)
 ;; Lee Mac  ~  18.03.10
 (defun *error* (msg)
   (and uFlag (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))
 (defun GetObjectID (obj)
   (setq util (cond (util) ((vla-get-Utility
                              (vla-get-ActiveDocument (vlax-get-acad-object))))))
   
   (if (vl-string-search "X64" (strcase (getvar 'PLATFORM)))
     (vlax-invoke-method util 'GetObjectIdString obj :vlax-false)
     (itoa (vla-get-Objectid obj))))     
 (defun lst->str (lst d1 d2)
   (if (cdr lst)
     (strcat d1 (car lst) d2 (lst->str (cdr lst) d1 d2))
     (strcat d1 (car lst))))
 (princ "\nSelect Objects to Retrieve Total Area... ")
 (if (and (ssget '((0 . "ARC,CIRCLE,ELLIPE,HATCH,*POLYLINE,REGION")))
          (setq ent (car (nentsel "\nSelect Text, MText or Attrib to Place: ")))
          (wcmatch (cdr (assoc 0 (entget ent))) "*TEXT,ATTRIB"))                          
   (progn
     (setq uFlag (not (vla-StartUndoMark
                        (setq doc (vla-get-ActiveDocument
                                    (vlax-get-acad-object))))))
     
     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
       (setq Ids (cons (GetObjectID obj) Ids)))
     (vla-delete ss)
     (vla-put-TextString
       (vlax-ename->vla-object ent)
       (if (= 1 (length Ids))
         (strcat "%<\\AcObjProp Object(%<\\_ObjId " (car Ids) ">%).Area \\f "%lu6%qf1%ct8[1e-6]">%")
         (strcat "%<\\AcExpr" (lst->str Ids " %<\\AcObjProp Object(%<\\_ObjId " ">%).Area >% +")
                 ">%).Area >% \\f "%lu6%qf1%ct8[1e-6]">%")))
     (vla-regen doc acActiveViewport)
     (setq uFlag (vla-EndUndomark doc))))
 (princ))