字段和LISP的结合使用实例

highflybird 周一, 01/18/2021 - 01:16

以下是字段和LISP结合使用的实例： 

 
;;;*********************************************************************
;;; 字段的操作示例程序。                                                
;;;*********************************************************************
;|**********************************************************************
软件作者: Highflybird                                                   
软件用途: 对字段的操作程序                                              
创建日期: 2021.01.05 深圳                                               
程序语言: AutoLISP,Visual LISP                                          
程序版本: Ver.1.0.21.0105                                               
========================================================================
 
========================================================================
本软件为开源软件: 以下是开源申明:                                       
------------------------------------------------------------------------
本页面的软件遵照 GPL协议开放源代码，您可以自由传播和修改，在遵照下面的约
束条件的前提下:                                                         
一. 只要你在本开源软件的每一副本上明显和恰当地出版版权声明，保持此许可证
    的声明和没有担保的声明完整无损，并和程序一起给每个其他的程序接受者一
    份许可证的副本，你就可用任何媒体复制和发布你收到的原始程序的源代码。
    你也可以为转让副本的实际行动收取一定费用，但必须事先得到的同意。    
二. 你可以修改本开源软件的一个或几个副本或程序的任何部分，以此形成基于程
    序的作品。只要你同时满足下面的所有条件，你就可以按前面第一款的要求复
    制和发布这一经过修改的程序或作品。                                  
  1.你必须在修改的文件中附有明确说明：你修改了这一文件及具体的修改日期。
  2.你必须使你发布或出版的作品（它包含程序的全部或一部分，或包含由程序的
    全部或部分衍生的作品）允许第三方作为整体按许可证条款免费使用。      
  3.如果修改的程序在运行时以交互方式读取命令，你必须使它在开始进入常规的
    交互使用方式时打印或显示声明: 包括适当的版权声明和没有担保的声明（或
    者你提供担保的声明）；用户可以按此许可证条款重新发布程序的说明；并告
    诉用户如何看到这一许可证的副本。（例外的情况: 如果原始程序以交互方式
    工作，它并不打印这样的声明，你的基于程序的作品也就不用打印声明。    
三. 只要你遵循一、二条款规定，您就可以自由使用并传播本源代码，但必须原封
    不动地保留原作者信息。                                              
========================================================================
**********************************************************************|;
 
;;;-------------------------------------------------------------------;;
;;; 创建字段(本示例中为创建防火分区，获得防火防区的面积）               
;;;-------------------------------------------------------------------;;
;;; 一些备用代码:                                                       
;;;(setq sel (ssget '((8 . "A-车库-防火分区") (0 . "LWPOLYLINE"))))     
;;;(setq style (getvar "TEXTSTYLE"))                                    
;;;(setq style (getvar "TEXTJUSTIFY"))                                  
;;;(vla-put-StyleName txt "宋体")                                       
;;;(vla-put-layer txt "A-Text-NUMB")                                    
;;;(setq txt (vla-addmtext (LM:Space) (vlax-3D-point ins) 0.0 str))     
(defun c:zd (/ str1 str2 AAA sel pMin pMax ins str txt ent obj height)
  (setq str1 "%<\\AcObjProp.16.2 Object(%<\\_ObjId ")
  (setq str2 ">%).Area \\f \"%lu2%pr2%ps[,m\\\u+00b2]%ct8[1e-006]\">%")
  (setq height (getvar "TEXTSIZE"))
  (if (setq sel (ssget '((0 . "*LINE,CIRCLE,ELLIPSE,ARC,REGION"))))
    (progn
      (LM:startundo (LM:acDoc))
      (setq AAA "%<\\AcExpr (")
      (repeat (sslength sel)
        (setq ent (ssname sel 0))
        (setq obj (vlax-ename->vla-object ent))
        (vla-GetBoundingBox obj 'pMin 'pMax)
        (setq pmin (vlax-safearray->list pmin))
        (setq pmax (vlax-safearray->list pmax))
        (setq ins (mapcar '* '(0.5 0.5 0.5) (mapcar '+ pmin pmax)))
	(setq ins (vlax-3d-point ins))
        (setq str (strcat str1 (LM:ObjectID obj) str2))
        (setq txt (vla-addtext (LM:Space) str ins height))
	(setq AAA (strcat AAA str "+"))
        (vla-put-Alignment txt 10)
	(vla-put-TextAlignmentPoint txt ins)
        (ssdel ent sel)
      )
      (setq AAA (substr AAA 1 (1- (strlen AAA))))
      (setq AAA (strcat AAA ") \\f \"%lu2%pr2%ps[,m\\\u+00b2]%ct8[1e-006]\">%"))
      (initget 8)
      (if (setq ins (getpoint "\n输入总和插入点<退出>: ")) 
	(progn
	  (setq ins (vlax-3d-point (trans ins 1 0)))
	  (setq txt (vla-addtext (LM:Space) AAA ins height))
	  (vla-put-Alignment txt 10)
	  (vla-put-TextAlignmentPoint txt ins)
	)
      )
      (LM:Endundo (LM:acDoc))
    )
  )
  (princ)
)
 
;;;-------------------------------------------------------------------;;
;;; 修改文字类（含属性）为字段(本示例中为创建一个字段赋予文本或属性）   
;;;-------------------------------------------------------------------;;
(defun c:zzd (/ att cur obj str1 str2 str)
  (if
    (and
      (setq att (car (nentsel "\n点取属性: ")))
      (setq cur (car (entsel "\n拾取面积线: ")))
      (setq obj (vlax-ename->vla-object att))
      (vlax-property-available-p obj 'textstring)
    )
    (progn
      (setq str1 "面积：%<\\AcObjProp.16.2 Object(%<\\_ObjId ")
      (setq str2 ">%).Area \\f \"%lu2%pr2%ps[,m\\\u+00b2]%ct8[1e-006]\">%")
      (setq str (strcat str1 (LM:ename->objectid cur) str2))
      (LM:outputtext:puttextstring obj str)
      (LM:outputtext:updatefield att)
    )
  )
)
 
;;;-------------------------------------------------------------------;;
;;; 修改字段(本示例中为修改已知字段的格式，譬如精确位数）               
;;;-------------------------------------------------------------------;;
(defun c:XGZD (/ str sel old ent obj)
  ;;(setq str1 "%<\\AcObjProp.16.2 Object(%<\\_ObjId ")
  ;;(setq str2 ">%).Area \\f \"%lu2%pr2%ps[,m\\\u+00b2]%ct8[1e-006]\">%")
  (if (setq sel (ssget '((0 . "*TEXT"))))
    (progn
      (LM:startundo (LM:acDoc))
      (repeat (sslength sel)
        (setq ent (ssname sel 0))
        (setq obj (vlax-ename->vla-object ent))
        (setq old (LM:fieldcode ent))
        (setq str (vl-string-subst "%lu2%pr2" "%lu2" old))
        (vla-put-textstring obj "")
        (vla-put-textstring obj str)
        (ssdel ent sel)
      )
      (LM:Endundo (LM:acDoc))
    )
  )
  (princ)
)
 
(defun c:plxg (/ sel ent obj tag str)
  (if (setq sel (ssget '((0 . "INSERT")(2 . "防火分区表"))))
    (progn
      (LM:Startundo (LM:acDoc))
      (repeat (sslength sel)
	(setq ent (ssname sel 0))
	(setq obj (vlax-ename->vla-object ent))
	(foreach Att (vlax-invoke Obj 'GetAttributes)
          (setq tag (vla-get-tagstring att))
	  (if (= tag "面积：")
	    (progn
	      (setq str (LM:fieldCode (vlax-vla-object->ename att)))
	      (setq str (vl-string-subst "%ps[,m\\\u+00b2]%ct8[1e-006]\">%" "%ct8[1e-006]\">%m\U+00B2" str))
	      (LM:outputtext:puttextstring Att str)
	      (LM:outputtext:updatefield ent)
	    )
	  )
	)
	(ssdel ent sel)
      )
      (LM:Endundo (LM:acDoc))
    )
  )
)
 
;;;-------------------------------------------------------------------;;
;;; Field Code  -  Lee Mac                                              
;;; Returns the field expression associated with an entity name         
;;;-------------------------------------------------------------------;;
(defun LM:fieldcode ( ent / replacefield replaceobject fieldstring enx )
 
    (defun replacefield ( str enx / ent fld pos )
        (if (setq pos (vl-string-search "\\_FldIdx" (setq str (replaceobject str enx))))
            (progn
                (setq ent (assoc 360 enx)
                      fld (entget (cdr ent))
                )
                (strcat
                    (substr str 1 pos)
                    (replacefield (fieldstring fld) fld)
                    (replacefield (substr str (1+ (vl-string-search ">%" str pos))) (cdr (member ent enx)))
                )
            )
            str
        )
    )
 
    (defun replaceobject ( str enx / ent pos )
        (if (setq pos (vl-string-search "ObjIdx" str))
            (strcat
                (substr str 1 (+ pos 5)) " "
                (LM:ObjectID (vlax-ename->vla-object (cdr (setq ent (assoc 331 enx)))))
                (replaceobject (substr str (1+ (vl-string-search ">%" str pos))) (cdr (member ent enx)))
            )
            str
        )
    )
 
    (defun fieldstring ( enx / itm )
        (if (setq itm (assoc 3 enx))
            (strcat (cdr itm) (fieldstring (cdr (member itm enx))))
            (cond ((cdr (assoc 2 enx))) (""))
        )
    )
 
    (if (and (wcmatch  (cdr (assoc 0 (setq enx (entget ent)))) "TEXT,MTEXT,ATTRIB,MULTILEADER,*DIMENSION")
             (setq enx (cdr (assoc 360 enx)))
             (setq enx (dictsearch enx "ACAD_FIELD"))
             (setq enx (dictsearch (cdr (assoc -1 enx)) "TEXT"))
        )
        (replacefield (fieldstring enx) enx)
    )
)
 
;;;-------------------------------------------------------------------;;
;;; ObjectID  -  Lee Mac                                        	
;;; Returns a string containing the ObjectID of a supplied VLA-Object   
;;; Compatible with 32-bit & 64-bit systems                     	
;;;-------------------------------------------------------------------;;
(defun LM:ObjectID ( obj )
    (eval
        (list 'defun 'LM:ObjectID '( obj )
            (if
                (and
                    (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
                    (vlax-method-applicable-p (LM:Uti) 'getobjectidstring)
                )
                (list 'vla-getobjectidstring (LM:Uti) 'obj ':vlax-false)
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (LM:ObjectID obj)
)
 
;;;-------------------------------------------------------------------;;
;;; Entity Name to ObjectID  -  Lee Mac                                 
;;; Returns the 32-bit or 64-bit ObjectID for a supplied entity name    
;;;-------------------------------------------------------------------;;
(defun LM:ename->objectid ( ent )
    (LM:ObjectID (vlax-ename->vla-object ent))
)
 
;;;-------------------------------------------------------------------;;
;;; Object ID (integer)  -  Lee Mac                             	
;;; Returns an integer representing the ObjectID of a VLA-Object        
;;; Compatible with 32-bit & 64-bit systems                     	
;;;-------------------------------------------------------------------;;
(defun LM:intobjectid ( obj )
    (if (vlax-property-available-p obj 'objectid32)
        (defun LM:intobjectid ( obj ) (vla-get-objectid32 obj))
        (defun LM:intobjectid ( obj ) (vla-get-objectid   obj))
    )
    (LM:intobjectid obj)
)
 
;;;-------------------------------------------------------------------;;
;;; Number to String  -  Lee Mac                                        
;;; Converts a supplied numerical argument to a string                  
;;;-------------------------------------------------------------------;;
(defun LM:num->str ( num / dim rtn )
    (if (equal num (atoi (rtos num 2 0)) 1e-8)
        (rtos num 2 0)
        (progn
            (setq dim (getvar 'dimzin))
            (setvar 'dimzin 8)
            (setq rtn (rtos num 2 8))
            (setvar 'dimzin dim)
            rtn
        )
    )
)
 
;;;-------------------------------------------------------------------;;
;;; Numerical Field  -  Lee Mac                                         
;;; Returns the numerical content described by a field expression       
;;;-------------------------------------------------------------------;;
(defun LM:numericalfield ( fld / obj rtn )
    (vl-catch-all-apply
       '(lambda nil
            (setq obj (vla-addmtext (vla-get-modelspace (LM:acdoc)) (vlax-3D-point 0 0) 0.0 fld)
                  rtn (distof (vla-get-textstring obj) 2)
            )
        )
    )
    (if (= 'vla-object (type obj)) (vla-delete obj))
    rtn
)
 
;;;-------------------------------------------------------------------;;
;; Remove Field Formatting  -  Lee Mac                                  
;; Removes all formatting codes from a field expression                 
;;;-------------------------------------------------------------------;;
(defun LM:removefieldformatting ( fld / ps1 ps2 )
    (if
        (and
            (setq ps1 (vl-string-search " \\f \"" fld))
            (setq ps2 (vl-string-search "\">%" (substr fld (+ 6 ps1))))
        )
        (strcat (substr fld 1 ps1) ">%" (LM:removefieldformatting (substr fld (+ 9 ps1 ps2))))
        fld
    )
)
 
;;;-------------------------------------------------------------------;;
;;; Start Undo  -  Lee Mac                                              
;;; Opens an Undo Group.                                                
;;;-------------------------------------------------------------------;;
(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)
 
;;;-------------------------------------------------------------------;;
;;; End Undo  -  Lee Mac                                                
;;; Closes an Undo Group.                                               
;;;-------------------------------------------------------------------;;
(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)
 
;;;-------------------------------------------------------------------;;
;;; modify the string of a text or a mtext                              
;;;-------------------------------------------------------------------;;
(defun LM:outputtext:puttextstring ( obj str )
    (vla-put-textstring obj "") 					; To clear any existing field
    (vla-put-textstring obj str)
    t
)
 
;;;-------------------------------------------------------------------;;
;;; update a field for a supplied entity name                           
;;;-------------------------------------------------------------------;;
(defun LM:outputtext:updatefield ( ent / cmd rtn )
    (setq cmd (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (setq rtn (vl-cmdf "_.updatefield" ent ""))
    (setvar 'cmdecho cmd)
    rtn
)
 
;;;-------------------------------------------------------------------;;
;;; Active Document  -  Lee Mac                                         
;;; Returns the VLA Active Document Object                              
;;;-------------------------------------------------------------------;;
(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)
 
;;;-------------------------------------------------------------------;;
;;; Current Space  -  Lee Mac                                           
;;; Returns the VLA Current Space Object                                
;;;-------------------------------------------------------------------;;
(defun LM:Space nil
  (if (zerop (getvar "tilemode"))
    (vla-get-paperSpace (LM:acdoc))
    (vla-get-ModelSpace (LM:acdoc))
  )
)
 
;;;-------------------------------------------------------------------;;
;;; Get utilities from Active Document  -  Lee Mac                      
;;; Returns the VLA utilities  Object                                   
;;;-------------------------------------------------------------------;;
(defun LM:Uti nil
    (eval (list 'defun 'LM:Uti 'nil (vla-get-utility (LM:acdoc))))
    (LM:Uti)
)
 
;;;-------------------------------------------------------------------;;
;;; Get utilities from Active Document  -  Lee Mac                      
;;; Returns the VLA utilities  Object                                   
;;;-------------------------------------------------------------------;;
(defun LM:Uti nil
    (eval (list 'defun 'LM:Uti 'nil (vla-get-utility (LM:acdoc))))
    (LM:Uti)
)
 
;;----------------------------------------------------------------------;;
;;; 功能: 创建文字                                                        
;;; 输入: str--文字内容（字符串）,Ins--插入点 ,height -- 文字高度         
;;; 输出: 创建成功则生成图元名，否则返回nil                               
;;----------------------------------------------------------------------;;
(defun ENT:MAKE_TEXT (str ins height)
  (ENTMAKEX
    (list
      '(0 . "TEXT")
      (cons 10 ins)
      (cons 1 str)
      (cons 40 height)
    )
  )
)
 
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
    (strcat
        "\n:: 字段复制和修改.lsp | Version 1.0 | \\U+00A9 Highflybird "
        ((lambda ( y ) (if (= y (menucmd "m=$(edtime,0,yyyy)")) y (strcat y "-" (menucmd "m=$(edtime,0,yyyy)")))) "2021")
        " www.highflybird.com ::"
        "\n:: Type \"ZD\" to Invoke ::"
    )
)
(princ)
 
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;
编程