向lis添加增量编号
你以前帮过我一个Lisp程序，我正试图对另一个Lisp程序做同样的事情，但没有成功。我原来的帖子
http://www.cadtutor.net/forum/showthread.php?104566-修改lisp将增量编号添加到区域文本
我的目标和我的第一篇帖子一样，在文本中的“L”字母旁边添加增量数字
我要更改的lisp：
;;-------------------------=={ Length Field }==-------------------------;;
;; ;;
;;This program allows a user to generate a field expression ;;
;;referencing the length/perimeter/circumference of one or more ;;
;;selected objects. In the case of selecting multiple objects, the ;;
;;field expression will reference the sum of the lengths of all ;;
;;objects in the selection. ;;
;; ;;
;;The user may opt to specify a point at which to create a new ;;
;;multiline text object housing the field expression, pick a table ;;
;;cell in which the field should be inserted, or select an existing ;;
;;single-line text, multiline text, multileader, or attribute to ;;
;;be populated with the field expression. ;;
;; ;;
;;Upon issuing the command syntax 'LF' (Length Field) at the AutoCAD;;
;;command-line, the program first prompts the user to make a ;;
;;selection of objects for which to return the length summation. ;;
;; ;;
;;At this prompt, the user may select any number of Arcs, Circles, ;;
;;Lines, 2D Polylines (light or heavy), or 3D Polylines. ;;
;; ;;
;;The user is then prompted to specify a point or table cell to ;;
;;insert a field expression referencing the summation of the lengths;;
;;of the selected objects. ;;
;; ;;
;;At this prompt, the user may also choose the 'Object' option in ;;
;;order to populate the content of an existing annotation object ;;
;;with the field expression. ;;
;; ;;
;;Upon choosing this option, the user may select any single-line ;;
;;text (DText), multiline text (MText), single-line or multiline ;;
;;attribute, attributed block, or multileader (MLeader) with either ;;
;;multiline text or attributed block content. ;;
;; ;;
;;If the user selects an attributed block or attributed multileader ;;
;;with more than one attribute, the user is presented with a dialog ;;
;;interface listing the available attributes, and is prompted to ;;
;;select a destination for the field expression. ;;
;; ;;
;;The user may optionally predefine the target block/multileader ;;
;;attribute by specifying the attribute tag where noted at the top ;;
;;of the program source code. ;;
;; ;;
;;The resulting field expression will display the sum of the lengths;;
;;of the selected objects, formatted using the field formatting code;;
;;specified at the top of the program. ;;
;; ;;
;;----------------------------------------------------------------------;;
;;Author:Lee Mac, Copyright © 2017-www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;;Version 1.0 - 2017-08-06 ;;
;; ;;
;;- First release. ;;
;;----------------------------------------------------------------------;;
;;Version 1.1 - 2017-08-06 ;;
;; ;;
;;- Program modified to account for selection of existing annotation;;
;; objects which already contain a field expression. ;;
;;----------------------------------------------------------------------;;
(defun c:lf ( / *error* ent enx flg fmt idx lst obj oid prp sel str tab tag tmp typ )
(setq fmt "L=%lu6%pr2 cm" ;; Field Formatting ;; L1, L2, L3, L...
tag nil ;; Optional predefined attribute tag
)
(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(LM:startundo (LM:acdoc))
(setq prp
'(
("AcDbArc" . "ArcLength")
("AcDbCircle" . "Circumference")
("AcDbLine" . "Length")
("AcDbPolyline" . "Length")
("AcDb2dPolyline" . "Length")
("AcDb3dPolyline" . "Length")
)
)
(if
(setq sel
(LM:ssget "\nSelect objects to obtain total length <exit>: "
(list
(list
'(000 . "ARC,CIRCLE,LINE,*POLYLINE")
'(-04 . "<NOT")
'(-04 . "<AND")
'(000 . "POLYLINE") '(-04 . "&") '(070 . 80)
'(-04 . "AND>")
'(-04 . "NOT>")
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab))
'(410 . "Model")
)
)
)
)
)
(progn
(if (= 1 (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel 0))
str
(strcat
"%<\\AcObjProp Object(%<\\_ObjId "
(LM:objectid obj)
">%)." (cdr (assoc (vla-get-objectname obj) prp)) " \\f \"" fmt "\">%"
)
)
(progn
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
lst
(vl-list*
"%<\\AcObjProp Object(%<\\_ObjId "
(LM:objectid obj)
">%)." (cdr (assoc (vla-get-objectname obj) prp)) ">%" " + "
lst
)
)
)
(setq str
(strcat
"%<\\AcExpr "
(apply 'strcat (reverse (cdr (reverse lst))))
" \\f \"" fmt "\">%"
)
)
)
)
(if
(setq tmp
(ssget "_X"
(list '(0 . "ACAD_TABLE")
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab))
'(410 . "Model")
)
)
)
)
(repeat (setq idx (sslength tmp))
(setq tab (cons (vlax-ename->vla-object (ssname tmp (setq idx (1- idx)))) tab))
)
)
(while
(not
(progn
(if flg
(progn
(setvar 'errno 0)
(initget "Point eXit")
(setq sel (nentsel "\nSelect text, mtext, mleader, attribute or attributed block <eXit>: "))
)
(progn
(initget "Object eXit")
(setq sel (getpoint "\nSpecify point or cell for field <eXit>: "))
)
)
(cond
( (= 7 (getvar 'errno))
(prompt "\nMissed, try again.")
)
( (or (null sel) (= "eXit" sel)))
( (= "Point" sel)
(setq flg nil)
)
( (= "Object" sel)
(not (setq flg t))
)
( flg
(setq ent (car sel)
enx (entget ent)
typ (cdr (assoc 0 enx))
obj (vlax-ename->vla-object ent)
)
(cond
( (and (= 2 (length sel)) (wcmatch typ "TEXT,MTEXT"))
(if (vlax-write-enabled-p obj)
(LF:puttextstring obj str)
(prompt "\nThe selected text object is on a locked layer.")
)
)
( (and (= "ATTRIB" typ)
(/= 'str (type tag))
)
(if (vlax-write-enabled-p obj)
(progn
(LF:puttextstring obj str)
(LF:updatefield ent)
)
(prompt "\nThe selected attribute is on a locked layer.")
)
)
( (and
(or
(and (= "ATTRIB" typ)
(setq tmp (cdr (assoc 330 enx)))
)
(and (setq tmp (last (cadddr sel)))
(= "INSERT" (cdr (assoc 0 (entget tmp))))
)
)
(setq tmp (vlax-invoke (vlax-ename->vla-object tmp) 'getattributes))
(or
(and (= 'str (type tag))
(setq idx (vl-position (strcase tag) (mapcar 'vla-get-tagstring tmp)))
(setq obj (nth idx tmp))
)
(and (not (cdr tmp))
(setq obj (car tmp))
)
(and (setq idx (LM:listbox "Choose Attribute" (mapcar 'vla-get-tagstring tmp) 2))
(setq obj (nth (car idx) tmp))
)
)
)
(if (vlax-write-enabled-p obj)
(progn
(LF:puttextstring obj str)
(LF:updatefield (vlax-vla-object->ename obj))
)
(prompt "\nThe selected attribute is on a locked layer.")
)
)
( (and (= 2 (length sel)) (= "MULTILEADER" typ))
(setq typ (cdr (assoc 172 (reverse enx))))
(cond
( (and (<= acblockcontent typ acmtextcontent) (not (vlax-write-enabled-p obj)))
(prompt "\nThe selected multileader is on a locked layer.")
)
( (= acmtextcontent typ)
(LF:puttextstring obj str)
(vla-regen (LM:acdoc) acactiveviewport)
t
)
( (and
(= acblockcontent typ)
(setq tmp (LM:getmleaderattributes obj))
(or
(and (= 'str (type tag))
(setq oid (cdr (assoc (strcase tag) tmp)))
)
(and (not (cdr tmp))
(setq oid (cdar tmp))
)
(and (setq idx (LM:listbox "Choose Attribute" (mapcar 'car tmp) 2))
(setq oid (cdr (nth (car idx) tmp)))
)
)
)
(LM:setmleaderattributevalue obj oid str)
(vla-regen (LM:acdoc) acactiveviewport)
t
)
( (prompt "\nThe select multileader has no editable content."))
)
)
( (prompt "\nThe selected object is not text, mtext, multileader, attribute or attributed block."))
)
)
( (setq tmp (LM:getcell tab (trans sel 1 0)))
(if (vlax-write-enabled-p (car tmp))
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-settext (append tmp (list str)))))
(prompt "\nThe selected table cell belongs to a table on a locked layer.")
)
)
( (vla-addmtext
(vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
(vlax-3D-point (trans sel 1 0))
0.0
str
)
)
)
)
)
)
)
)
(*error* nil) (princ)
)
(defun LF:puttextstring ( obj str )
(vla-put-textstring obj "") ;; To clear any existing field
(vla-put-textstring obj str)
t
)
(defun LF:updatefield ( ent / cmd rtn )
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(setq rtn (vl-cmdf "_.updatefield" ent ""))
(setvar 'cmdecho cmd)
rtn
)
;; ssget-Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - selection prompt
;; arg - list of ssget arguments
(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)
;; Get MLeader Attributes-Lee Mac
;; Returns an association list of attribute tags & object IDs for all attributes held by an mleader block
;; mld - MLeader vla-object
;; Returns: List of ((<Attribute Tag> . <Object ID>) ... )
(defun LM:getmleaderattributes ( mld / rtn )
(vlax-for obj (vla-item (vla-get-blocks (vla-get-document mld)) (vla-get-contentblockname mld))
(if
(and
(= "AcDbAttributeDefinition" (vla-get-objectname obj))
(= :vlax-false (vla-get-constant obj))
)
(setq rtn (cons (cons (strcase (vla-get-tagstring obj)) (LM:intobjectid obj)) rtn))
)
)
(reverse rtn)
)
;; Object ID (integer)-Lee Mac
;; Returns an integer representing the ObjectID of a supplied 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)
)
;; Set MLeader Attribute Value-Lee Mac
;; obj - MLeader vla-object
;; idx - Attribute Definition Object ID
;; str - Attribute value
(defun LM:setmleaderattributevalue ( obj idx str )
(if (vlax-method-applicable-p obj 'setblockattributevalue32)
(defun LM:setmleaderattributevalue ( obj idx str ) (vla-setblockattributevalue32 obj idx str))
(defun LM:setmleaderattributevalue ( obj idx str ) (vla-setblockattributevalue obj idx str))
)
(LM:setmleaderattributevalue obj idx str)
)
;; List Box-Lee Mac
;; Displays a DCL list box allowing the user to make a selection from the supplied data.
;; msg - Dialog label
;; lst - List of strings to display
;; bit - 1=allow multiple; 2=return indexes
;; Returns: List of selected items/indexes, else nil
(defun LM:listbox ( msg lst bit / dch des tmp rtn )
(cond
( (not
(and
(setq tmp (vl-filename-mktemp nil nil ".dcl"))
(setq des (open tmp "w"))
(write-line
(strcat "listbox:dialog{label=\"" msg "\";spacer;:list_box{key=\"list\";multiple_select="
(if (= 1 (logand 1 bit)) "true" "false") ";width=50;height=15;}spacer;ok_cancel;}"
)
des
)
(not (close des))
(< 0 (setq dch (load_dialog tmp)))
(new_dialog "listbox" dch)
)
)
(prompt "\nError Loading List Box Dialog.")
)
( t
(start_list "list")
(foreach itm lst (add_list itm))
(end_list)
(setq rtn (set_tile "list" "0"))
(action_tile "list" "(setq rtn $value)")
(setq rtn
(if (= 1 (start_dialog))
(if (= 2 (logand 2 bit))
(read (strcat "(" rtn ")"))
(mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")")))
)
)
)
)
)
(if (< 0 dch)
(unload_dialog dch)
)
(if (and tmp (setq tmp (findfile tmp)))
(vl-file-delete tmp)
)
rtn
)
;; Get Cell-Lee Mac
;; If the supplied point lies within a cell boundary,
;; returns a list of: (<VLA Table Object> <Row> <Col>)
(defun LM:getcell ( lst pnt / dir )
(setq dir (vlax-3D-point (trans (getvar 'viewdir) 1 0))
pnt (vlax-3D-point pnt)
)
(vl-some
'(lambda ( tab / row col )
(if (= :vlax-true (vla-hittest tab pnt dir 'row 'col))
(list tab row col)
)
)
lst
)
)
;; 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 (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
(if (vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring)
(list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
'(LM:ename->objectid (vlax-vla-object->ename obj))
)
'(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:hex->decstr
(setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
ent (substr ent (+ (vl-string-position 58 ent) 3))
)
)
)
;; Hex to Decimal String-Lee Mac
;; Returns the decimal representation of a supplied hexadecimal string
(defun LM:hex->decstr ( hex / foo bar )
(defun foo ( lst rtn )
(if lst
(foo (cdr lst) (bar (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
(apply 'strcat (mapcar 'itoa (reverse rtn)))
)
)
(defun bar ( int lst )
(if lst
(if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
(cons (rem int 10) (bar (/ int 10) (cdr lst)))
)
(bar int '(0))
)
)
(foo (vl-string->list (strcase hex)) nil)
)
;; 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)
)
)
;; 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)
)
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
(strcat
"\n:: LengthField.lsp | Version 1.0 | \\U+00A9 Lee Mac "
(menucmd "m=$(edtime,0,yyyy)")
" www.lee-mac.com ::"
"\n:: Type \"LF\" to Invoke ::"
)
)
(princ)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;; 尝试查找代码numinc。它做你想要的。你找不到，给我一个信号。我会看着你的。 我发现它，非常好的Lisp程序，但不是我想要的。
我只想修改附加的lisp，而不是将“L=10 cm”修改为“L1=x cm”，将下一个修改为“L2=x cm” 只需应用与另一个lisp相同的代码更改，将它们并排打开并进行比较。 我试过了，我得到了不同的结果，我不知道为什么 这就是问题所在：
仍然不工作
(setq mynumber 0)
(defun increment (str / )
(setq mynumber (+ mynumber 1))
(vl-string-subst (itoa mynumber) "*" str)
)
;;-------------------------=={ Length Field }==-------------------------;;
;; ;;
;;This program allows a user to generate a field expression ;;
;;referencing the length/perimeter/circumference of one or more ;;
;;selected objects. In the case of selecting multiple objects, the ;;
;;field expression will reference the sum of the lengths of all ;;
;;objects in the selection. ;;
;; ;;
;;The user may opt to specify a point at which to create a new ;;
;;multiline text object housing the field expression, pick a table ;;
;;cell in which the field should be inserted, or select an existing ;;
;;single-line text, multiline text, multileader, or attribute to ;;
;;be populated with the field expression. ;;
;; ;;
;;Upon issuing the command syntax 'LF' (Length Field) at the AutoCAD;;
;;command-line, the program first prompts the user to make a ;;
;;selection of objects for which to return the length summation. ;;
;; ;;
;;At this prompt, the user may select any number of Arcs, Circles, ;;
;;Lines, 2D Polylines (light or heavy), or 3D Polylines. ;;
;; ;;
;;The user is then prompted to specify a point or table cell to ;;
;;insert a field expression referencing the summation of the lengths;;
;;of the selected objects. ;;
;; ;;
;;At this prompt, the user may also choose the 'Object' option in ;;
;;order to populate the content of an existing annotation object ;;
;;with the field expression. ;;
;; ;;
;;Upon choosing this option, the user may select any single-line ;;
;;text (DText), multiline text (MText), single-line or multiline ;;
;;attribute, attributed block, or multileader (MLeader) with either ;;
;;multiline text or attributed block content. ;;
;; ;;
;;If the user selects an attributed block or attributed multileader ;;
;;with more than one attribute, the user is presented with a dialog ;;
;;interface listing the available attributes, and is prompted to ;;
;;select a destination for the field expression. ;;
;; ;;
;;The user may optionally predefine the target block/multileader ;;
;;attribute by specifying the attribute tag where noted at the top ;;
;;of the program source code. ;;
;; ;;
;;The resulting field expression will display the sum of the lengths;;
;;of the selected objects, formatted using the field formatting code;;
;;specified at the top of the program. ;;
;; ;;
;;----------------------------------------------------------------------;;
;;Author:Lee Mac, Copyright © 2017-www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;;Version 1.0 - 2017-08-06 ;;
;; ;;
;;- First release. ;;
;;----------------------------------------------------------------------;;
;;Version 1.1 - 2017-08-06 ;;
;; ;;
;;- Program modified to account for selection of existing annotation;;
;; objects which already contain a field expression. ;;
;;----------------------------------------------------------------------;;
(defun c:lf ( / *error* ent enx flg fmt idx lst obj oid prp sel str tab tag tmp typ )
(setq fmt "L=%lu6%pr2 cm" ;; Field Formatting
(setq fmt (increment fmt))
tag nil ;; Optional predefined attribute tag
)
(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(LM:startundo (LM:acdoc))
(setq prp
'(
("AcDbArc" . "ArcLength")
("AcDbCircle" . "Circumference")
("AcDbLine" . "Length")
("AcDbPolyline" . "Length")
("AcDb2dPolyline" . "Length")
("AcDb3dPolyline" . "Length")
)
)
(if
(setq sel
(LM:ssget "\nSelect objects to obtain total length <exit>: "
(list
(list
'(000 . "ARC,CIRCLE,LINE,*POLYLINE")
'(-04 . "<NOT")
'(-04 . "<AND")
'(000 . "POLYLINE") '(-04 . "&") '(070 . 80)
'(-04 . "AND>")
'(-04 . "NOT>")
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab))
'(410 . "Model")
)
)
)
)
)
(progn
(if (= 1 (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel 0))
str
(strcat
"%<\\AcObjProp Object(%<\\_ObjId "
(LM:objectid obj)
">%)." (cdr (assoc (vla-get-objectname obj) prp)) " \\f \"" fmt "\">%"
)
)
(progn
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
lst
(vl-list*
"%<\\AcObjProp Object(%<\\_ObjId "
(LM:objectid obj)
">%)." (cdr (assoc (vla-get-objectname obj) prp)) ">%" " + "
lst
)
)
)
(setq str
(strcat
"%<\\AcExpr "
(apply 'strcat (reverse (cdr (reverse lst))))
" \\f \"" fmt "\">%"
)
)
)
)
(if
(setq tmp
(ssget "_X"
(list '(0 . "ACAD_TABLE")
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab))
'(410 . "Model")
)
)
)
)
(repeat (setq idx (sslength tmp))
(setq tab (cons (vlax-ename->vla-object (ssname tmp (setq idx (1- idx)))) tab))
)
)
(while
(not
(progn
(if flg
(progn
(setvar 'errno 0)
(initget "Point eXit")
(setq sel (nentsel "\nSelect text, mtext, mleader, attribute or attributed block <eXit>: "))
)
(progn
(initget "Object eXit")
(setq sel (getpoint "\nSpecify point or cell for field <eXit>: "))
)
)
(cond
( (= 7 (getvar 'errno))
(prompt "\nMissed, try again.")
)
( (or (null sel) (= "eXit" sel)))
( (= "Point" sel)
(setq flg nil)
)
( (= "Object" sel)
(not (setq flg t))
)
( flg
(setq ent (car sel)
enx (entget ent)
typ (cdr (assoc 0 enx))
obj (vlax-ename->vla-object ent)
)
(cond
( (and (= 2 (length sel)) (wcmatch typ "TEXT,MTEXT"))
(if (vlax-write-enabled-p obj)
(LF:puttextstring obj str)
(prompt "\nThe selected text object is on a locked layer.")
)
)
( (and (= "ATTRIB" typ)
(/= 'str (type tag))
)
(if (vlax-write-enabled-p obj)
(progn
(LF:puttextstring obj str)
(LF:updatefield ent)
)
(prompt "\nThe selected attribute is on a locked layer.")
)
)
( (and
(or
(and (= "ATTRIB" typ)
(setq tmp (cdr (assoc 330 enx)))
)
(and (setq tmp (last (cadddr sel)))
(= "INSERT" (cdr (assoc 0 (entget tmp))))
)
)
(setq tmp (vlax-invoke (vlax-ename->vla-object tmp) 'getattributes))
(or
(and (= 'str (type tag))
(setq idx (vl-position (strcase tag) (mapcar 'vla-get-tagstring tmp)))
(setq obj (nth idx tmp))
)
(and (not (cdr tmp))
(setq obj (car tmp))
)
(and (setq idx (LM:listbox "Choose Attribute" (mapcar 'vla-get-tagstring tmp) 2))
(setq obj (nth (car idx) tmp))
)
)
)
(if (vlax-write-enabled-p obj)
(progn
(LF:puttextstring obj str)
(LF:updatefield (vlax-vla-object->ename obj))
)
(prompt "\nThe selected attribute is on a locked layer.")
)
)
( (and (= 2 (length sel)) (= "MULTILEADER" typ))
(setq typ (cdr (assoc 172 (reverse enx))))
(cond
( (and (<= acblockcontent typ acmtextcontent) (not (vlax-write-enabled-p obj)))
(prompt "\nThe selected multileader is on a locked layer.")
)
( (= acmtextcontent typ)
(LF:puttextstring obj str)
(vla-regen (LM:acdoc) acactiveviewport)
t
)
( (and
(= acblockcontent typ)
(setq tmp (LM:getmleaderattributes obj))
(or
(and (= 'str (type tag))
(setq oid (cdr (assoc (strcase tag) tmp)))
)
(and (not (cdr tmp))
(setq oid (cdar tmp))
)
(and (setq idx (LM:listbox "Choose Attribute" (mapcar 'car tmp) 2))
(setq oid (cdr (nth (car idx) tmp)))
)
)
)
(LM:setmleaderattributevalue obj oid str)
(vla-regen (LM:acdoc) acactiveviewport)
t
)
( (prompt "\nThe select multileader has no editable content."))
)
)
( (prompt "\nThe selected object is not text, mtext, multileader, attribute or attributed block."))
)
)
( (setq tmp (LM:getcell tab (trans sel 1 0)))
(if (vlax-write-enabled-p (car tmp))
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-settext (append tmp (list str)))))
(prompt "\nThe selected table cell belongs to a table on a locked layer.")
)
)
( (vla-addmtext
(vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
(vlax-3D-point (trans sel 1 0))
0.0
str
)
)
)
)
)
)
)
)
(*error* nil) (princ)
)
(defun LF:puttextstring ( obj str )
(vla-put-textstring obj "") ;; To clear any existing field
(vla-put-textstring obj str)
t
)
(defun LF:updatefield ( ent / cmd rtn )
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(setq rtn (vl-cmdf "_.updatefield" ent ""))
(setvar 'cmdecho cmd)
rtn
)
;; ssget-Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - selection prompt
;; arg - list of ssget arguments
(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)
;; Get MLeader Attributes-Lee Mac
;; Returns an association list of attribute tags & object IDs for all attributes held by an mleader block
;; mld - MLeader vla-object
;; Returns: List of ((<Attribute Tag> . <Object ID>) ... )
(defun LM:getmleaderattributes ( mld / rtn )
(vlax-for obj (vla-item (vla-get-blocks (vla-get-document mld)) (vla-get-contentblockname mld))
(if
(and
(= "AcDbAttributeDefinition" (vla-get-objectname obj))
(= :vlax-false (vla-get-constant obj))
)
(setq rtn (cons (cons (strcase (vla-get-tagstring obj)) (LM:intobjectid obj)) rtn))
)
)
(reverse rtn)
)
;; Object ID (integer)-Lee Mac
;; Returns an integer representing the ObjectID of a supplied 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)
)
;; Set MLeader Attribute Value-Lee Mac
;; obj - MLeader vla-object
;; idx - Attribute Definition Object ID
;; str - Attribute value
(defun LM:setmleaderattributevalue ( obj idx str )
(if (vlax-method-applicable-p obj 'setblockattributevalue32)
(defun LM:setmleaderattributevalue ( obj idx str ) (vla-setblockattributevalue32 obj idx str))
(defun LM:setmleaderattributevalue ( obj idx str ) (vla-setblockattributevalue obj idx str))
)
(LM:setmleaderattributevalue obj idx str)
)
;; List Box-Lee Mac
;; Displays a DCL list box allowing the user to make a selection from the supplied data.
;; msg - Dialog label
;; lst - List of strings to display
;; bit - 1=allow multiple; 2=return indexes
;; Returns: List of selected items/indexes, else nil
(defun LM:listbox ( msg lst bit / dch des tmp rtn )
(cond
( (not
(and
(setq tmp (vl-filename-mktemp nil nil ".dcl"))
(setq des (open tmp "w"))
(write-line
(strcat "listbox:dialog{label=\"" msg "\";spacer;:list_box{key=\"list\";multiple_select="
(if (= 1 (logand 1 bit)) "true" "false") ";width=50;height=15;}spacer;ok_cancel;}"
)
des
)
(not (close des))
(< 0 (setq dch (load_dialog tmp)))
(new_dialog "listbox" dch)
)
)
(prompt "\nError Loading List Box Dialog.")
)
( t
(start_list "list")
(foreach itm lst (add_list itm))
(end_list)
(setq rtn (set_tile "list" "0"))
(action_tile "list" "(setq rtn $value)")
(setq rtn
(if (= 1 (start_dialog))
(if (= 2 (logand 2 bit))
(read (strcat "(" rtn ")"))
(mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")")))
)
)
)
)
)
(if (< 0 dch)
(unload_dialog dch)
)
(if (and tmp (setq tmp (findfile tmp)))
(vl-file-delete tmp)
)
rtn
)
;; Get Cell-Lee Mac
;; If the supplied point lies within a cell boundary,
;; returns a list of: (<VLA Table Object> <Row> <Col>)
(defun LM:getcell ( lst pnt / dir )
(setq dir (vlax-3D-point (trans (getvar 'viewdir) 1 0))
pnt (vlax-3D-point pnt)
)
(vl-some
'(lambda ( tab / row col )
(if (= :vlax-true (vla-hittest tab pnt dir 'row 'col))
(list tab row col)
)
)
lst
)
)
;; 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 (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
(if (vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring)
(list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
'(LM:ename->objectid (vlax-vla-object->ename obj))
)
'(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:hex->decstr
(setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
ent (substr ent (+ (vl-string-position 58 ent) 3))
)
)
)
;; Hex to Decimal String-Lee Mac
;; Returns the decimal representation of a supplied hexadecimal string
(defun LM:hex->decstr ( hex / foo bar )
(defun foo ( lst rtn )
(if lst
(foo (cdr lst) (bar (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
(apply 'strcat (mapcar 'itoa (reverse rtn)))
)
)
(defun bar ( int lst )
(if lst
(if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
(cons (rem int 10) (bar (/ int 10) (cdr lst)))
)
(bar int '(0))
)
)
(foo (vl-string->list (strcase hex)) nil)
)
;; 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)
)
)
;; 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)
)
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
(strcat
"\n:: LengthField.lsp | Version 1.0 | \\U+00A9 Lee Mac "
(menucmd "m=$(edtime,0,yyyy)")
" www.lee-mac.com ::"
"\n:: Type \"LF\" to Invoke ::"
)
)
(princ)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
页:
[1]