怎样用lisp只选取"文字（包括多行文字）、尺寸、带属性的块"?

jaminth · 发表于 2008-1-3 17:17

ZZXXQQ · 发表于 2008-1-3 22:14

(SSGET '((-4 . "<OR") (0 . "*TEXT,DIMENSION") (-4 . "<AND") (0 . "INSERT") (66 . 1) (-4 . "AND>") (-4 . "OR>"))))

jaminth · 发表于 2008-1-4 07:03

本帖最后由作者于 2008-1-4 7:17:40 编辑

这是一个对只"文字（包括多行文字）、尺寸、带属性的块"加下划线的LISP,ZZXXQQ能不能帮我优化一下,提高CAD的运行速度:比如有些函数能不能用VLISP函数代替,,,因为图太大时,框选之后运行起来很慢!!
----->还有,想多补充一个的功能,就是如果有些地方已经加了下划线了,程序框选后,检测出已经加了下划线了就自动跳过,不再加下划线!

(defun c:ga()
(vl-load-com)
(setvar "cmdecho" 0)
(command "_.undo" "be")
(setq oldclyer (getvar "clayer"))
(setq chklay (tblsearch "layer" "RLP064_C240"))
(setq ss (SSGET '((-4 . "<OR") (0 . "*TEXT,DIMENSION") (-4 . "<AND") (0 . "INSERT") (66 . 1) (-4 . "AND>") (-4 . "OR>"))))
; (setq ss (ssget '((-4 . "<not") (0 . "*line") (-4 . "not>"))))
(setq len (sslength ss))
(setq count 0)
(setq count1 0)
(repeat len
(setq ent (ssname ss count))
(setq endata (entget ent))
(setq count (1+ count))
(setq entlay (cdr (assoc 8 endata)))
(setq entype (cdr (assoc 0 endata)))
(cond
((= entype "DIMENSION")(dmdl))
((= entype "TEXT")(tadl))
((= entype "MTEXT")(tamdl))
((= entype "INSERT")(indl))
(t nil)
))
(command "._layer" "s" oldclyer "")
(command "_.undo" "e")
(prin1)
)
(defun tadl ()
(command "ucs" "world")
(setq pt10 (cdr (assoc 10 endata)))
(setq txtang (cdr (assoc 50 endata)))
(setq tbox (textbox endata))
(setq xdat (caadr tbox))
(setq txtht (cdr (assoc 40 endata)))
(setq lspace (* txtht 0.25))
(setq lpt (polar pt10 (- txtang (/ pi 2.0)) lspace))
(setq lpt1 (polar lpt (+ txtang pi) (* txtht 0.25)))
(setq lpt2 (polar lpt1 txtang (+ xdat (* txtht 0.5))))
; (setq orent (ssget "c" lpt1 lpt2))
; (if (= orent nil)
; (command "line" lpt1 lpt2 ""))
(command "line" lpt1 lpt2 "")
(setq linet (entlast))
(if (/= entlay "RLP581")
(progn
(setq chklay (tblsearch "layer" "RLP064_C240"))
(if (null chklay)
(command "._layer" "m" "RLP064_C240" "color" "240" "" "L" "continuous" "" "" "color" "bylayer" "linetype" "s" "bylayer" "")
(command "._layer" "t" "RLP064_C240" "on" "RLP064_C240" "u" "RLP064_C240" "" )
)
(command "._change" linet "" "p" "la" "RLP064_C240" "")
)
(progn
(setq chklay (tblsearch "layer" "RLP064_C240FS"))
(if (null chklay)
(command "._layer" "m" "RLP064_C240FS" "color" "240" "" "L" "continuous" "" "" "color" "bylayer" "linetype" "s" "bylayer" "")
(command "._layer" "t" "RLP064_C240FS" "on" "RLP064_C240FS" "u" "RLP064_C240FS" "" )
)
(command "._change" linet "" "p" "la" "RLP064_C240FS" "")
)
)
(command "ucs" "p")
)
(defun dmdl()
(command "._copy" ent "" "@" "@")
(command "explode" ent)
(setq ssdm (ssget "p"))
(setq lendm (sslength ssdm))
(setq cct 0)
(repeat lendm
(setq entdm (ssname ssdm cct))
(setq endtdm (entget entdm))
(setq dmtype (cdr (assoc 0 endtdm)))
(if (= dmtype "MTEXT")
(progn
(command "explode" entdm)
(setq entmt (entlast))
(setq endata (entget entmt))
(tadl)
(vla-erase (vlax-ename->vla-object entmt))
; (entdel entmt);;在command命令作用中可能无效!!!!
)
(vla-erase (vlax-ename->vla-object entdm))
; (entdel entdm);;在command命令作用中可能无效!!!!
)
(setq cct (1+ cct))
)
)
(defun indl()
(setq ctstl (getvar "textstyle"))
(setq cts (getvar "textsize"))
(setq attdata (entget (entnext (cdr (assoc -1 endata)))))
(setq txt (cdr (assoc 1 attdata)));clutch the attribute value for add text
(setq txtstl (cdr (assoc 7 attdata)));clutch the style of attribute value
(setq txtpt (cdr (assoc 10 attdata)));clutch the point for insert text
(setq txth (cdr (assoc 40 attdata)));clutch the height of the attribute value
(setq txts (assoc 41 attdata))
(setq txtang (* (/ (cdr (assoc 50 attdata)) pi) 180));clutch the angle of the attribute value
(setvar "textsize" txth)
(command "text" txtpt "" txtang txt)
; (command "._text" "s" txtstl txtpt txth txtang txt)
(setq atttxt (entlast))
(setq endata (entget atttxt))
(setq otxts (assoc 41 endata))
(setq endata (subst txts otxts endata))
(entmod endata)
(if (/= ctstl txtstl)
(setvar "textstyle" ctstl)
)
(if (/= cts txth)
(setvar "textsize" cts)
)
(tadl)
(vla-erase (vlax-ename->vla-object atttxt))
; (entdel atttxt);;在command命令作用中可能无效!!!!
(prin1)
)
(defun tamdl()
(command "._copy" ent "" "@" "@")
(command "explode" ent)
(setq enttmt (entlast))
(setq endtata (entget enttmt))
(setq endata endtata )
(tadl)
)
(prin1)

(defun c:ga()
(vl-load-com)
(setvar "cmdecho" 0)
(command "_.undo" "be")
(setq oldclyer (getvar "clayer"))
(setq chklay (tblsearch "layer" "RLP064_C240"))
(setq ss (SSGET '((-4 . "<OR") (0 . "*TEXT,DIMENSION") (-4 . "<AND") (0 . "INSERT") (66 . 1) (-4 . "AND>") (-4 . "OR>"))))
; (setq ss (ssget '((-4 . "<not") (0 . "*line") (-4 . "not>"))))
(setq len (sslength ss))
(setq count 0)
(setq count1 0)
(repeat len
(setq ent (ssname ss count))
(setq endata (entget ent))
(setq count (1+ count))
(setq entlay (cdr (assoc 8 endata)))
(setq entype (cdr (assoc 0 endata)))
(cond
((= entype "DIMENSION")(dmdl))
((= entype "TEXT")(tadl))
((= entype "MTEXT")(tamdl))
((= entype "INSERT")(indl))
(t nil)
))
(command "._layer" "s" oldclyer "")
(command "_.undo" "e")
(prin1)
)
(defun tadl ()
(command "ucs" "world")
(setq pt10 (cdr (assoc 10 endata)))
(setq txtang (cdr (assoc 50 endata)))
(setq tbox (textbox endata))
(setq xdat (caadr tbox))
(setq txtht (cdr (assoc 40 endata)))
(setq lspace (* txtht 0.25))
(setq lpt (polar pt10 (- txtang (/ pi 2.0)) lspace))
(setq lpt1 (polar lpt (+ txtang pi) (* txtht 0.25)))
(setq lpt2 (polar lpt1 txtang (+ xdat (* txtht 0.5))))
; (setq orent (ssget "c" lpt1 lpt2))
; (if (= orent nil)
; (command "line" lpt1 lpt2 ""))
(command "line" lpt1 lpt2 "")
(setq linet (entlast))
(if (/= entlay "RLP581")
(progn
(setq chklay (tblsearch "layer" "RLP064_C240"))
(if (null chklay)
(command "._layer" "m" "RLP064_C240" "color" "240"  "" "L" "continuous" "" "" "color"  "bylayer" "linetype" "s"  "bylayer"  "")
(command "._layer" "t" "RLP064_C240" "on" "RLP064_C240" "u" "RLP064_C240" "" )
)
(command "._change" linet "" "p" "la" "RLP064_C240" "")
)
(progn
(setq chklay (tblsearch "layer" "RLP064_C240FS"))
(if (null chklay)
(command "._layer" "m" "RLP064_C240FS" "color" "240"  "" "L" "continuous" "" "" "color"  "bylayer" "linetype" "s"  "bylayer"  "")
(command "._layer" "t" "RLP064_C240FS" "on" "RLP064_C240FS" "u" "RLP064_C240FS" "" )
)
(command "._change" linet "" "p" "la" "RLP064_C240FS" "")
)
)
(command "ucs" "p")
)
(defun dmdl()
(command "._copy" ent "" "@" "@") 
(command "explode" ent)
(setq ssdm (ssget "p"))
(setq lendm (sslength ssdm))
(setq cct 0)
(repeat lendm
(setq entdm (ssname ssdm cct))
(setq endtdm (entget entdm))
(setq dmtype (cdr (assoc 0 endtdm)))
(if (= dmtype "MTEXT")
(progn
(command "explode" entdm)
(setq entmt (entlast))
(setq endata (entget entmt))
(tadl)
(vla-erase (vlax-ename->vla-object entmt))
; (entdel entmt);;在command命令作用中可能无效!!!!
)
(vla-erase (vlax-ename->vla-object entdm))
; (entdel entdm);;在command命令作用中可能无效!!!!
)
(setq cct (1+ cct))
)
)
(defun indl()
(setq ctstl (getvar "textstyle"))
(setq cts (getvar "textsize"))
(setq attdata (entget (entnext (cdr (assoc -1 endata)))))
(setq txt (cdr (assoc 1 attdata)));clutch the attribute value for add text
(setq txtstl (cdr (assoc 7 attdata)));clutch the style of attribute value
(setq txtpt (cdr (assoc 10 attdata)));clutch the point for insert text
(setq txth (cdr (assoc 40 attdata)));clutch the height of the attribute value
(setq txts (assoc 41 attdata))
(setq txtang (* (/ (cdr (assoc 50 attdata)) pi) 180));clutch the angle of the attribute value
(setvar "textsize" txth)
(command "text" txtpt "" txtang txt)
; (command "._text" "s" txtstl txtpt txth txtang txt)
(setq atttxt (entlast))
(setq endata (entget atttxt))
(setq otxts (assoc 41 endata))
(setq endata (subst txts otxts endata))
(entmod endata)
(if (/= ctstl txtstl)
(setvar "textstyle" ctstl)
)
(if (/= cts  txth)
(setvar "textsize" cts)
)
(tadl)
(vla-erase (vlax-ename->vla-object atttxt))
; (entdel atttxt);;在command命令作用中可能无效!!!!
(prin1)
)
(defun tamdl()
(command "._copy" ent "" "@" "@") 
(command "explode" ent)
(setq enttmt (entlast))
(setq endtata (entget enttmt))
(setq endata endtata )
(tadl)
)
(prin1)

jaminth · 发表于 2008-1-6 06:52

ZZXXQQ有时间帮我看看吗？如果没有时间就算了！谢谢

linheyuanpcb · 发表于 2008-1-6 08:32

把程序复制了,呵^^^^我不会改,只是拿来学下

carrot1983 · 发表于 2008-1-6 11:58

;;;给文字下划线 carrot1983 2008-1-6
(vl-load-com)
(defun c:underLine (/ E ELST I O SS STR V0 V1 V2 VALUE)
;;ss2Elst选择集->图元表
(defun ss2Elst (ss / elst)
(setq i 0)
(repeat (sslength ss)
(setq elst (cons (ssname ss i) elst)
i (1+ i)
) ;_ end setq
) ;_ end repeat
(reverse elst)
) ;_ end defun
(defun getValue (ename code)
(setq value (cdr (assoc code (entget ename))))
) ;_ end defun
(defun replaceValue (e code val / data)
(setq data (entget e))
(setq data (subst (cons code val) (assoc code data) data))
(entmod data)
) ;_ end defun
(setq ss (ssget '((-4 . "<or")
(0 . "*TEXT,DIMENSION,ATTDEF")
(-4 . "<and")
(0 . "INSERT")
(66 . 1)
(-4 . "and>")
(-4 . "or>")
)
) ;_ end ssget
) ;_ end setq
(setq elst (ss2Elst ss))
(foreach e elst
(setq v0 (getValue e 0)
v1 (getValue e 1)
v2 (getValue e 2)
) ;_ end setq
(cond
((and (wcmatch v0 "TEXT")
(/= "%%u" (strcase (substr v1 1 3) T))
) ;_ end and
(replaceValue e 1 (strcat "%%u" v1))
)
((and (wcmatch v0 "MTEXT") (not (VL-STRING-SEARCH "\\L" v1)))
(replaceValue e 1 (strcat "{\\L" v1 "}"))
)
((and (wcmatch v0 "DIMENSION")
(not (VL-STRING-SEARCH "\\L" v1))
) ;_ end and
(if (= v1 "")
(replaceValue e 1 (strcat "{\\L" "<>" "}"))
(replaceValue e 1 (strcat "{\\L" v1 "}"))
) ;_ end if
)
((and (wcmatch v0 "ATTDEF")
(/= "%%u" (strcase (substr v2 1 3) T))
) ;_ end and
(replaceValue e 2 (strcat "%%u" v2))
)
((wcmatch v0 "INSERT")
(progn
(setq o (vlax-ename->vla-object e))
(setq str (vla-get-TextString
(car (vlax-safearray->list
(vlax-variant-value (vla-GetAttributes o))
)
)
)
)
(if (/= "%%u" (strcase (substr str 1 3) T))
(vla-put-TextString
(car (vlax-safearray->list
(vlax-variant-value (vla-GetAttributes o))
)
)
(strcat "%%u" str)
)
) ;_ end if
) ;_ end progn
)
) ;_ end cond
) ;_ end foreach
(princ)
) ;_ end defun
(defun c:tt ()
(c:underLine)
) ;_ end defun

;;;给文字下划线 carrot1983 2008-1-6
(vl-load-com)
(defun c:underLine (/ E ELST I O SS STR V0 V1 V2 VALUE)
  ;;ss2Elst选择集->图元表
  (defun ss2Elst (ss / elst)
    (setq i 0)
    (repeat (sslength ss)
      (setq elst (cons (ssname ss i) elst)
     i  (1+ i)
      ) ;_ end setq
    ) ;_ end repeat
    (reverse elst)
  ) ;_ end defun
  (defun getValue (ename code)
    (setq value (cdr (assoc code (entget ename))))
  ) ;_ end defun
  (defun replaceValue (e code val / data)
    (setq data (entget e))
    (setq data (subst (cons code val) (assoc code data) data))
    (entmod data)
  ) ;_ end defun
  (setq ss (ssget '((-4 . "<or")
      (0 . "*TEXT,DIMENSION,ATTDEF")
      (-4 . "<and")
      (0 . "INSERT")
      (66 . 1)
      (-4 . "and>")
      (-4 . "or>")
     )
    ) ;_ end ssget
  ) ;_ end setq
  (setq elst (ss2Elst ss))
  (foreach e elst
    (setq v0 (getValue e 0)
   v1 (getValue e 1)
   v2 (getValue e 2)
    ) ;_ end setq
    (cond
      ((and (wcmatch v0 "TEXT")
     (/= "%%u" (strcase (substr v1 1 3) T))
       ) ;_ end and
       (replaceValue e 1 (strcat "%%u" v1))
      )
      ((and (wcmatch v0 "MTEXT") (not (VL-STRING-SEARCH "\\L" v1)))
       (replaceValue e 1 (strcat "{\\L" v1 "}"))
      )
      ((and (wcmatch v0 "DIMENSION")
     (not (VL-STRING-SEARCH "\\L" v1))
       ) ;_ end and
       (if (= v1 "")
  (replaceValue e 1 (strcat "{\\L" "<>" "}"))
  (replaceValue e 1 (strcat "{\\L" v1 "}"))
       ) ;_ end if
      )
      ((and (wcmatch v0 "ATTDEF")
     (/= "%%u" (strcase (substr v2 1 3) T))
       ) ;_ end and
       (replaceValue e 2 (strcat "%%u" v2))
      )
      ((wcmatch v0 "INSERT")
       (progn
  (setq o (vlax-ename->vla-object e))
  (setq str (vla-get-TextString
       (car (vlax-safearray->list
       (vlax-variant-value (vla-GetAttributes o))
     )
       )
     )
  )
  (if (/= "%%u" (strcase (substr str 1 3) T))
    (vla-put-TextString
      (car (vlax-safearray->list
      (vlax-variant-value (vla-GetAttributes o))
    )
      )
      (strcat "%%u" str)
    )
  ) ;_ end if
       ) ;_ end progn
      )
    ) ;_ end cond
  ) ;_ end foreach
  (princ)
) ;_ end defun
(defun c:tt ()
  (c:underLine)
) ;_ end defun

账号		自动登录	找回密码
密码			注册