将标记集添加到另一个L
我有这两个口吃，都是李做的，如果我没有错的话，我经常使用并喜欢它们。我正在竭尽全力让更多的大学使用它们，因为它们是如此节省时间！因为它们写得很好，所以即使是在大厅对面的近退休女士也可以使用它们并理解它们。你知道我在拍马屁吗？我知道
TG lisp（用引线将定位号放置在圆中）有一个标记集命令，用于设置文字高度和圆半径。CR lisp（在图形中放置坐标）没有标记集，如果有，那将非常棒*闪烁闪烁*当然CR不需要圆半径。。。
我听见你叹口气说：“可是老虎，你为什么不自己动手？”嗯，有两个原因，今天是星期五，我很快就要回家庆祝了（说来话长，但警察撤销了指控，哇！）我知道这里有人可以做得比我好得多*
; .: Nozzle & Equipment Tags :.
;
; .: by Lee McDonnell :.
(defun c:tg(/ olderr *error* varLst oldVars tagpt tagline linent linest linend tagang tcirc tcirccent t1)
(or (getenv "tag:tsize") (setenv "tag:tsize" (rtos (getvar "TEXTSIZE"))))
(or (getenv "tag:tcircr") (setenv "tag:tcircr" "4.2"))
(princ
(strcat "\nType \"TAGSET\" to Change Base Variables--Current Settings:"
"\n\tText Height: "
(getenv "tag:tsize")
",\tText Circle Radius: "
(getenv "tag:tcircr")))
; --- Error Trap ---
(setq olderr *error* *error* errtrap)
(defun errtrap(msg)
(mapcar 'setvar varLst oldVars)
(setq *error* olderr)
(if (= msg "")
(princ "\nFunction Complete.")
(princ "\nError or Esc pressed... "))
(princ))
(setq varLst (list "CMDECHO" "CLAYER")
oldVars (mapcar 'getvar varLst))
; --- Error Trap ---
(setvar "cmdecho" 0)
(if (not (tblsearch "LAYER" "TAGLINE"))
(command "-layer" "m" "TAGLINE" "c" "5" "TAGLINE" ""))
(if (not (tblsearch "LAYER" "TEXT"))
(command "-layer" "m" "TEXT" "c" "2" "TEXT" ""))
(while
(/= (setq tagpt (getpoint "\nSelect First Tag Point: ")) nil)
(setvar "clayer" "TAGLINE")
(prompt "\nSpecify Second Point... ")
(command "_line" tagpt pause "")
(setq tagline (entlast)
linent(entget tagline)
linest(cdr (assoc 10 linent))
linend(cdr (assoc 11 linent))
tagang(angle linest linend)
tcirc (atof (getenv "tag:tcircr")))
(setvar "clayer" "TEXT")
(setq tcirccent (polar linend tagang tcirc))
(command "_circle" "_non" tcirccent tcirc)
(command "-mtext" tcirccent "H" (getenv "tag:tsize") "J" "MC" "@8.4,0" "")
(command "_ddedit" (setq t1 (entlast)) "")
(entmod (subst (cons 10 tcirccent) (assoc 10 (entget t1)) (entget t1))))
(*error* "")
(princ))
; Base Variables
(defun c:tagset (/ tsize tcircr)
(or (getenv "tag:tsize") (setenv "tag:tsize" (rtos (getvar "TEXTSIZE"))))
(or (getenv "tag:tcircr") (setenv "tag:tcircr" "4.2"))
(princ
(strcat "\nCurrent Settings:"
"\n\tText Height: "
(getenv "tag:tsize")
",\tText Circle Radius @ 1:1: "
(getenv "tag:tcircr")))
(if (setq tsize (getreal (strcat "\nSpecify Text Height <" (getenv "tag:tsize") ">: ")))
(setenv "tag:tsize" (rtos tsize)))
(if (setq tcircr (getreal (strcat "\nSpecify Text Circle Radius <" (getenv "tag:tcircr") ">: ")))
(setenv "tag:tcircr" (rtos tcircr)))
(princ "\nBase Variables Set.")
(princ))
(defun c:cr (/ *error* doc lFac tSze tLay tSty vl ov pt t1 t2)
(vl-load-com)
(setq doc (vla-get-ActiveDocument
(vlax-get-acad-object)))
(defun *error* (msg)
(if doc (vla-EndUndoMark doc))
(if ov (mapcar 'setvar vl ov))
(if (not
(wcmatch
(strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))
(setq
lFac 1.5 ;; <<-- Line Spacing Factor
tSze 500 ;; <<-- TextSize (nil to use TEXTSIZE sys var)
tLay nil ;; <<-- Text Layer (nil to use CLAYER sys var)
tSty nil ;; <<-- Text Style (nil to use TEXTSTYLE sys var)
)
(setq vl '("CMDECHO" "OSMODE")
ov (mapcar 'getvar vl))
(setvar "CMDECHO" 0)
(setvar "LUPREC" 3)
;;<<--Error Checking-->>
(cond ((not (and (numberp lFac) (< 0 lFac)))
(princ "\n** Line Spacing not Valid **"))
((and tLay (not (eq 'STR (type tLay))))
(princ "\n** Layer not a String **"))
(t
(or tSze (setq tSze (getvar "TEXTSIZE")))
(or tLay (setq tLay (getvar "CLAYER")))
(or tSty (setq tSty (getvar "TEXTSTYLE")))
(and tLay (not (tblsearch "LAYER" tLay))
(vla-add
(vla-get-layers doc) tLay))
;; <<---------------------->>
;; <<-- Business End-->>
(while (setq pt (getpoint "\n Välj Punkt - <RETURN> för att avsluta :"))
(vla-StartUndoMark doc)
(setvar "OSMODE" 0)
(setq pt (trans pt 1 0))
(command "_.point" pt) ;; << Comment this if unnecessary
(setq t1
(Make_Text pt
(strcat "Y: " (rtos (/ (car pt) 1000.)))
0.;; Text is at 0 deg.
tSze tLay tSty))
(setq t2
(Make_Text (polar pt (/ (* 3 pi) 2.) (* lFac tSze))
(strcat "X: " (rtos (/ (cadr pt) 1000.)))
0.
tSze tLay tSty))
(setvar "OSMODE" (cadr ov))
(command "_.move" t1 t2 "" pt pause)
(vla-EndUndoMark doc))
;; <<------------------>>
))
(mapcar 'setvar vl ov)
(princ))
;; <<--Sub-Function-->>
(defun Make_Text(pt val rot sZe lay sty)
(entmakex
(list
(cons 0 "TEXT")
(cons 8lay)
(cons 10 pt)
(cons 40 sZe)
(cons 1val)
(cons 50 rot)
(cons 7sty)
(cons 71 0)
(cons 72 0);; 0 = Left, 1 = Center, 2 = Right
(cons 73 1);; 0 = Base, 1 = Bottom, 2 = Middle, 3 = Top
(cons 11 pt))))因为这是setenv将值保存到的位置。
现在，我假设现在的注册表足够大，几个额外的键可以忽略不计，但同样的，当程序停止使用时，键仍然存在，除非用户知道通过注册表深入到上面的位置来删除它。。。然而，一个小的文本/cfg文件更容易处理。
李 谢谢你的澄清，李。
它仍然没有计算（还没有），但我会做一些阅读，Googl'ing，并重新访问这一点，一旦我得到这个提交了大门。
干杯
不客气
在本例中，我只使用了setenv/getenv函数-我认为这些函数比vl registry write更简单，因为它们只写入注册表中的一个位置-我认为最好的学习方法是尝试，但要小心干预注册表-也就是说，不要像大多数人一样害怕注册表——除非你是一个彻头彻尾的傻瓜，在不知道键做什么的情况下删除/修改键，否则它并没有那么危险。 ... 我可能有点“神经质”。
莫哈哈-他们总会回来缠着你的，你知道的 顺便说一句，我不久前写的Tiger可能有用：
(strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\FixedProfile\\General" 谢谢李，我喜欢在你之前的lisp中手动输入数字（有时需要在数字套装中打断），所以我坚持使用这个方法：wink： BTW Tiger, I wrote this a while back, may be of use:
;;------------------------=={ Tag }==-------------------------;;;; ;;;;Prompts the user for a tag prefix and starting tag number ;;;;then proceeds to add tag blocks with incrementing tag ;;;;attribute until the user fails to pick a tag point. ;;;; ;;;;Tag block is created if non-existent. Tag Block layers ;;;;are created if non-existent. ;;;;------------------------------------------------------------;;;;Author: Lee McDonnell, 2010 ;;;; ;;;;Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;;;Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;;;------------------------------------------------------------;;(defun c:tag ( / *error* ATT BL BLK BNME DEF DOC P1 P2 PR SCL SPC ) (vl-load-com) ;; © Lee Mac 2010 (setq bNme "TAG" scl (cond ( (zerop (getvar 'DIMSCALE)) 1. ) ( (getvar 'DIMSCALE) ))) (defun *error* ( msg ) (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **"))) (princ) )(LM:ActiveSpace 'doc 'spc) (if (not (LM:Itemp (setq blk (vla-get-Blocks doc)) bNme)) (progn (setq def (vla-Add blk (vlax-3D-point '(0. 0. 0.)) bNme)) (vla-put-layer (vla-AddCircle def (vlax-3D-point '(0. 0. 0.)) 5.) "0") (setq att (vla-AddAttribute def 2.5 0 "Tag Number: " (vlax-3D-point '(0. 0. 0.)) "TNO" "N1")) (vla-put-layer att "0") (vla-put-Alignment att acAlignmentMiddleCenter) ) ) (foreach l '("2" "5") (or (tblsearch "LAYER" l) (vla-Add (vla-get-layers doc) l))) (setq pr (getstring t "\nSpecify Tag Prefix: ")) (setq *tag* (cond ( (getint (strcat "\nSpecify Tag Number: " ) ) ) ( *tag* ) ) ) (while (and (setq p1 (getpoint "\nSpecify First Point: ")) (setq p2 (getpoint (strcat "\nSpecify Point for Tag (" pr (itoa *tag*) "): ") p1))) (vla-put-Layer (vla-AddLine spc (vlax-3D-point (trans p1 1 0)) (vlax-3D-point (trans (polar p2 (angle p2 p1) (* 5.0 scl)) 1 0)) ) "5" ) (setq bl (vla-InsertBlock spc (vlax-3D-point (trans p2 1 0)) bNme scl scl scl 0.)) (vla-put-layer bl "2") (mapcar (function (lambda ( att ) (if (eq "TNO" (vla-get-TagString att)) (vla-put-TextString att (strcat pr (itoa *tag*))) ) ) ) (vlax-invoke bl 'GetAttributes) ) (setq *tag* (1+ *tag*)) ) (princ));;-----------------------=={ Itemp }==------------------------;;;; ;;;;Retrieves the item with index 'item' if present in the ;;;;specified collection, else nil ;;;;------------------------------------------------------------;;;;Author: Lee McDonnell, 2010 ;;;; ;;;;Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;;;Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;;;------------------------------------------------------------;;;;Arguments: ;;;;coll - the VLA Collection Object ;;;;item - the index of the item to be retrieved ;;;;------------------------------------------------------------;;;;Returns:the VLA Object at the specified index, else nil ;;;;------------------------------------------------------------;;(defun LM:Itemp ( coll item ) ;; © Lee Mac 2010 (if (not (vl-catch-all-error-p (setq item (vl-catch-all-apply (function vla-item) (list coll item) ) ) ) ) item ));;--------------------=={ ActiveSpace }==---------------------;;;; ;;;;Retrieves pointers to the Active Document and Space ;;;;------------------------------------------------------------;;;;Author: Lee McDonnell, 2010 ;;;; ;;;;Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;;;Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;;;------------------------------------------------------------;;;;Arguments: ;;;;*doc - quoted symbol other than *doc ;;;;*spc - quoted symbol other than *spc ;;;;------------------------------------------------------------;;(defun LM:ActiveSpace ( *doc *spc ) ;; © Lee Mac 2010 (set *spc (if (or (eq AcModelSpace (vla-get-ActiveSpace (set *doc (vla-get-ActiveDocument (vlax-get-acad-object) ) ) ) ) (eq :vlax-true (vla-get-MSpace (eval *doc))) ) (vla-get-ModelSpace (eval *doc)) (vla-get-PaperSpace (eval *doc)) ) )) Thanks Lee, I like that I can enter the number by hand (need to make breaks in the numbering suit sometimes) in your previous lisp so I stick with that one though :wink:
页:
[1]