社区 › Auto Lisp › 面积/介电常数脚本文件

s8utt 发表于 2022-7-6 06:34:56

面积/介电常数脚本文件

你好
 
我有一个autocad scr文件，它绘制了一条多段线
 
我可以使用以下命令返回多段线的面积
 
地区
o
0,60
 
这给了我面积=177529.36，周长=2510.37
 
有没有办法把这些数字作为文字添加到图纸中？
 
或者我可以使用任何命令来查找多段线的objectid，以便使用
 
%%).区域\f“%lu2”>%

alanjt 发表于 2022-7-6 06:41:18

测试一次。。。
(defun c:PLabel (/ #Obj #Pnt #Id)
(vl-load-com)
(and (setq #Obj (car (entsel "\nSelect LWPolyline: ")))
      (or (eq "LWPOLYLINE" (cdr (assoc 0 (entget #Obj))))
          (alert "Invalid object!")
      ) ;_ or
      (setq #Pnt (getpoint "\nSpecify MText placement point: "))
      (setq #Id (itoa (vla-get-objectid (vlax-ename->vla-object #Obj))))
      (entmakex
      (list '(0 . "MTEXT")
            '(100 . "AcDbEntity")
            '(100 . "AcDbMText")
            '(71 . 5)
            (cons 7 (getvar 'textstyle))
            (cons 10 #Pnt)
            (cons 1
                  (strcat
                      "Area: %<\\AcObjProp Object(%<\\_ObjId " #Id
                      ">%).Area \\f \"%lu2\">%\\PPerimeter: %<\\AcObjProp Object(%<\\_ObjId " #Id
                      " >%).Length \\f \"%lu2\">%"
                     ) ;_ strcat
            ) ;_ cons
      ) ;_ list
      ) ;_ entmakex
) ;_ and
(princ)
) ;_ defun

s8utt 发表于 2022-7-6 06:41:35

呃，谢谢，但我如何在scr文件中使用它？

Lee Mac 发表于 2022-7-6 06:44:45

你好
 
试试这个：
 

(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 lst->str (lst d1 d2)
   (if (cdr lst)
   (strcat d1 (car lst) d2 (lst->str (cdr lst) d1 d2))
   (strcat d1 (car lst))))


(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 (itoa (vla-get-ObjectId 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))

s8utt 发表于 2022-7-6 06:48:23

也谢谢，你能告诉我如何使用上面的代码来获得我想要的结果吗。
 
对AutoCad来说有点陌生。谢谢

Lee Mac 发表于 2022-7-6 06:53:30

也许可以看看这里：
http://www.cadtutor.net/forum/showthread.php?t=1390

stevesfr 发表于 2022-7-6 06:56:09

 
 
嗯，结果适得其反！！！

Lee Mac 发表于 2022-7-6 06:59:35

是的，由于字段对象存储在文本字典中，而文本字典存储在ACAD_字段字典中，字段字典本身存储在文本、多行文字或属性的扩展字典中（无论您创建的是哪一个），因此无法使用entmake轻松创建字段。因此，要使用entmake，您必须在多行文字扩展词典中输入这些词典。
 
李

Lee Mac 发表于 2022-7-6 07:02:23

面积和周长的另一种变体
 

(defun c:GetAP (/ *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 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 + Perimeter...")
(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 (itoa (vla-get-ObjectId 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 "Area: %<\\AcObjProp Object(%<\\_ObjId "
               (car Ids) ">%).Area \\f \"%lu6%qf1\">%"
               "\\PPerimeter: %<\\AcObjProp Object(%<\\_ObjId "
               (car Ids) ">%).Length \\f \"%lu6\">%")
         
         (strcat "Area: %<\\AcExpr"
               (lst->str Ids " %<\\AcObjProp Object(%<\\_ObjId " ">%).Area >% +")
               ">%).Area >% \\f \"%lu6%qf1\">%"
               "\\PPerimeter: %<\\AcExpr"
               (lst->str Ids " %<\\AcObjProp Object(%<\\_ObjId " ">%).Length >% +")
               ">%).Length >% \\f \"%lu6\">%")))                  

   (setq uFlag (vla-EndUndomark doc))))

(princ))

alanjt 发表于 2022-7-6 07:03:33

 
 
是的，我没想过。它放置字段，但您必须编辑文本一次。不知道为什么我一开始就用了entmake。
 
只是为了它能正常工作。。。
(defun c:PLabel (/ #Obj #Pnt #Id)
(vl-load-com)
(and (setq #Obj (car (entsel "\nSelect LWPolyline: ")))
      (or (eq "LWPOLYLINE" (cdr (assoc 0 (entget #Obj))))
          (alert "Invalid object!")
      ) ;_ or
      (setq #Pnt (getpoint "\nSpecify MText placement point: "))
      (setq #Id (itoa (vla-get-objectid (vlax-ename->vla-object #Obj))))
      (AT:MText #Pnt
                (strcat
                  "Area: %<\\AcObjProp Object(%<\\_ObjId " #Id
                  ">%).Area \\f \"%lu2\">%\\PPerimeter: %<\\AcObjProp Object(%<\\_ObjId " #Id
                  " >%).Length \\f \"%lu2\">%"
               ) ;_ strcat
                0
                nil
                5
      ) ;_ AT:MText
) ;_ and
(princ)
) ;_ defun
 
;;; Add MText to drawing
;;; #InsertionPoint - MText insertion point
;;; #String - String to place in created MText object
;;; #Width - Width of MText object (if nil, will be 0 width)
;;; #Layer - Layer to place Mtext object on (nil for current)
;;; #Justification - Justification # for Mtext object
;;;             1 or nil= TopLeft
;;;             2= TopCenter
;;;             3= TopRight
;;;             4= MiddleLeft
;;;             5= MiddleCenter
;;;             6= MiddleRight
;;;             7= BottomLeft
;;;             8= BottomCenter
;;;             9= BottomRight
;;; Alan J. Thompson, 05.23.09
(defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width
                #Space #Insertion #Object
               )
(or #Width (setq #Width 0))
(or *AcadDoc*
   (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
) ;_ or
(setq #Space   (if (or (eq acmodelspace
                              (vla-get-activespace *AcadDoc*)
                        ) ;_ eq
                        (eq :vlax-true (vla-get-mspace *AcadDoc*))
                      ) ;_ or
                  (vla-get-modelspace *AcadDoc*)
                  (vla-get-paperspace *AcadDoc*)
                  ) ;_ if
       #Insertion (cond
                  ((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint))
                  ((eq (type #InsertionPoint) 'variant) #InsertionPoint)
                  (T nil)
                  ) ;_ cond
) ;_ setq
;; create MText object
(setq #Object (vla-addmtext #Space #Insertion #Width #String))
;; change layer, if applicable
(and #Layer
      (tblsearch "layer" #Layer)
      (vla-put-layer #Object #Layer)
) ;_ and
;; change justification & match insertion point with new justification
(cond ((member #Justification (list 1 2 3 4 5 6 7 8 9))
      (vla-put-attachmentpoint #Object #Justification)
      (vla-move #Object
                  (vla-get-InsertionPoint #Object)
                  #Insertion
      ) ;_ vla-move
       )
) ;_ cond
#Object
) ;_ defun

查看完整版本: 面积/介电常数脚本文件