字段和LISP的结合使用实例
highflybird
- 登录 发表评论
字段在CAD中用得不多，不过还是有些地方需要它。
以下是字段和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:ZDLJ (/ AAA ENT HEIGHT INS OBJ SEL STR TXT)
(setq AAA "")
(setq height (getvar "TEXTSIZE"))
(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 str (LM:fieldcode ent))
(setq AAA (strcat AAA str "+"))
(ssdel ent sel)
)
(initget 9)
(setq ins (getpoint "\n输入总和插入点<退出>: "))
(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:YTMJ (/ str1 str2 pMin pMax ins str txt ent obj height)
(setq height (getvar "TEXTSIZE"))
(LM:startundo (LM:acDoc))
(while
(and
(setq ent (car (entsel "\n拾取面积线: ")))
(setq obj (vlax-ename->vla-object ent))
(vlax-property-available-p obj 'area)
)
(progn
(setq str1 "%<\\AcExpr (%<\\AcObjProp.16.2 Object(%<\\_ObjId ")
(setq str2 ">%).Area \\f \"%lu2%pr2%ps[,m\\u+00b2]%ct8[1e-006]\">%/2) \\f \"%lu2%pr2%ps[,m\\u+00b2]%ct8[1e-006]\">%")
(setq str (strcat str1 (LM:ObjectID obj) str2))
(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 txt (vla-addtext (LM:Space) str ins height))
(vla-put-Alignment txt 10)
(vla-put-TextAlignmentPoint txt ins)
)
)
(LM:Endundo (LM:acDoc))
(princ)
)
;;;-------------------------------------------------------------------;;
;;; 字段求和
;;;-------------------------------------------------------------------;;
(defun c:QH (/ AAA ENT HEIGHT INS OBJ SEL STR TXT)
(if (setq sel (ssget '((0 . "*TEXT"))))
(progn
(LM:startundo (LM:acDoc))
(setq height (getvar "TEXTSIZE"))
(setq AAA "%<\\AcExpr (")
(repeat (sslength sel)
(setq ent (ssname sel 0))
(setq obj (vlax-ename->vla-object ent))
(setq str (LM:fieldcode ent))
(setq AAA (strcat AAA str "+"))
(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 9)
(setq ins (getpoint "\n输入总和插入点: "))
(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)
(while
(and
(setq att (car (nentsel "\n点取文本类（不含天正文本）: ")))
(setq cur (car (entsel "\n拾取面积线: ")))
(setq obj (vlax-ename->vla-object att))
(vlax-property-available-p (vlax-ename->vla-object CUR) 'AREA)
(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)
)
)
(princ)
)
;;;-------------------------------------------------------------------;;
;;; 修改字段(本示例中为修改已知字段的格式，譬如精确位数）
;;;-------------------------------------------------------------------;;
(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:: 输入\"ZD\" 用来标注面积, \"ZZD\" 用来文本（包含属性）转字段，\"QH\"为字段求和命令，\"YTMJ\"为计算一半面积。"
)
)
(princ)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;