|
|
发表于 2002-5-28 22:29:00
|
显示全部楼层
(defun cht_Main (/ sset opt ssl
nsset temp unctr ct_ver
sslen style hgt rot
txt ent loc loc1
just-idx justp justq orthom
cht_ErrorHandler cht_OrgError
cht_OrgCmdecho cht_OrgTexteval
cht_OrgHighlight
)
(setq ct_ver "2.00")
(defun cht_ErrorHandler (s)
(if (/= s "Function cancelled")
(if (= s "quit / exit abort")
(princ)
(princ (strcat "\n错误: " s))
)
)
(eval (read U:E))
(if cht_OrgError
(setq *error* cht_OrgError)
)
(if temp
(redraw temp 1)
)
(ai_undo_off)
;; restore undo state
(if cht_OrgCmdecho
(setvar "cmdecho" cht_OrgCmdecho)
)
(if cht_OrgTexteval
(setvar "texteval" cht_OrgTexteval)
)
(if cht_OrgHighlight
(setvar "highlight" cht_OrgHighlight)
)
(princ)
)
(if *error*
(setq cht_OrgError *error*
*error* cht_ErrorHandler
)
(setq *error* cht_ErrorHandler)
)
(setq U:G "(command \"_.undo\" \"_group\")"
U:E "(command \"_.undo\" \"_en\")"
)
(ai_undo_on)
;; enable undo
(setq cht_OrgCmdecho (getvar "cmdecho"))
(setq cht_OrgHighlight (getvar "highlight"))
(setvar "cmdecho" 0)
(princ (strcat "\n 改变文本, 版权号 "
ct_ver
", 版权1997 。Autodesk, Inc."
)
)
(prompt "\n选择要改变的注释.")
(setq sset (ai_aselect))
(if (null sset)
(progn
(princ "\n没有选择物体.")
(exit)
)
)
(setq ssl (sslength sset)
nsset (ssadd)
)
(if (> ssl 25)
(princ "\n 检验选择的物体...")
)
(while (> ssl 0)
(setq temp (ssname sset (setq ssl (1- ssl))))
(if (or
(= (cdr (assoc 0 (entget temp))) "TEXT")
(= (cdr (assoc 0 (entget temp))) "ATTDEF")
(= (cdr (assoc 0 (entget temp))) "MTEXT")
)
(ssadd temp nsset)
)
)
(setq ssl (sslength nsset)
sset nsset
unctr 0
)
(print ssl)
(princ " 发现注释(nnotation objects found).")
(setq opt T)
(while (and opt (> ssl 0))
(setq unctr (1+ unctr))
(command "_.UNDO" "_GROUP")
(initget
"Location Justification Style Height Rotation Width Text Undo"
)
(setq opt (getkword
"\n高H/对齐J/定位L/旋转R/类型S/文字T/回退U/宽W: "
)
)
(if opt
(cond
((= opt "Undo")
(cht_Undo)
)
((= opt "Location")
(cht_Location)
)
((= opt "Justification")
(cht_Justification)
)
((= opt "Style")
(cht_Property "Style" "新类型名" 7)
)
((= opt "Height")
(cht_Property "Height" "新高度" 40)
)
((= opt "Rotation")
(cht_Property "Rotation" "新的旋转角度" 50)
)
((= opt "Width")
(cht_Property "Width" "新宽度" 41)
)
((= opt "Text")
(cht_Text)
)
)
(setq opt nil)
)
(command "_.UNDO" "_END")
)
(if cht_OrgError
(setq *error* cht_OrgError)
)
(eval (read U:E))
(ai_undo_off)
;; restore undo state
(if cht_OrgTexteval
(setvar "texteval" cht_OrgTexteval)
)
(if cht_OrgHighlight
(setvar "highlight" cht_OrgHighlight)
)
(if cht_OrgCmdecho
(setvar "cmdecho" cht_OrgCmdecho)
)
(princ)
)
(defun cht_Undo ()
(if (not nop)
(dscprinc)
)
(if (> unctr 1)
(progn
(command "_.UNDO" "_END")
(command "_.UNDO" "2")
(setq unctr (- unctr 2))
)
(progn
(princ "\n没有操作进行回退. ")
(setq unctr (- unctr 1))
)
)
)
(defun cht_Location ()
(if (not nop)
(dscprinc)
)
(setq sslen (sslength sset)
style ""
hgt ""
rot ""
txt ""
)
(command "_.CHANGE" sset "" "")
(while (> sslen 0)
(setq ent (entget (ssname sset (setq sslen (1- sslen))))
opt (list (cadr (assoc 11 ent))
(caddr (assoc 11 ent))
(cadddr (assoc 11 ent))
)
)
(prompt "\n新的文字位置: ")
(command pause)
(if (null loc)
(setq loc opt)
)
(command style hgt rot txt)
)
(command)
)
(defun cht_Justification ()
(if (not nop)
(dscprinc)
)
(initget
"TL TC TR ML MC MR BL BC BR Align Center Fit Left Middle Right ?"
)
(setq sslen (sslength sset))
(setq justp
(getkword
"\n 排列A/拟合F/中心C/左L/中M/右R/左上TL/左中TC/右上TR/左中ML/正中MC/右中MR/左下BL/中下BC/右下BR/: "
)
)
(cond
((= justp "Left")
(setq justp 0
justq 0
just-idx 4
)
)
((= justp "Center")
(setq justp 1
justq 0
just-idx 5
)
)
((= justp "Right")
(setq justp 2
justq 0
just-idx 6
)
)
((= justp "Align")
(setq justp 3
justq 0
just-idx 1
)
)
((= justp "Fit")
(setq justp 5
justq 0
just-idx 1
)
)
((= justp "TL")
(setq justp 0
justq 3
just-idx 1
)
)
((= justp "TC")
(setq justp 1
justq 3
just-idx 2
)
)
((= justp "TR")
(setq justp 2
justq 3
just-idx 3
)
)
((= justp "ML")
(setq justp 0
justq 2
just-idx 4
)
)
((= justp "Middle")
(setq justp 4
justq 0
just-idx 5
)
)
((= justp "MC")
(setq justp 1
justq 2
just-idx 5
)
)
((= justp "MR")
(setq justp 2
justq 2
just-idx 6
)
)
((= justp "BL")
(setq justp 0
justq 1
just-idx 7
)
)
((= justp "BC")
(setq justp 1
justq 1
just-idx 8
)
)
((= justp "BR")
(setq justp 2
justq 1
just-idx 9
)
)
((= justp "?") (setq justp nil))
(T (setq justp nil))
)
(if justp
(progn
;; Process them...
(while (> sslen 0)
(setq ent (entget (ssname sset (setq sslen (1- sslen)))))
(cond
((= (cdr (assoc 0 ent)) "MTEXT")
(setq ent (subst (cons 71 just-idx) (assoc 71 ent) ent))
)
((= (cdr (assoc 0 ent)) "TEXT")
(setq ent (subst (cons 72 justp) (assoc 72 ent) ent)
opt (trans (list (cadr (assoc 11 ent))
(caddr (assoc 11 ent))
(cadddr (assoc 11 ent))
)
(cdr (assoc -1 ent))
;; from ECS
1
)
;; to current UCS
)
(setq ent (subst (cons 73 justq) (assoc 73 ent) ent))
(cond
((or (= justp 3) (= justp 5))
(prompt "\n新的文字对齐点(New text alignment points): ")
(if (= (setq orthom (getvar "orthomode")) 1)
(setvar "orthomode" 0)
)
(redraw (cdr (assoc -1 ent)) 3)
(initget 1)
(setq loc (getpoint))
(initget 1)
(setq loc1 (getpoint loc))
(redraw (cdr (assoc -1 ent)) 1)
(setvar "orthomode" orthom)
(setq ent (subst (cons 10 loc) (assoc 10 ent) ent))
(setq ent (subst (cons 11 loc1) (assoc 11 ent) ent))
)
((or (/= justp 0) (/= justq 0))
(redraw (cdr (assoc -1 ent)) 3)
(prompt "\n新的文字位置: ")
(if (= (setq orthom (getvar "orthomode")) 1)
(setvar "orthomode" 0)
)
(setq loc (getpoint opt))
(setvar "orthomode" orthom)
(redraw (cdr (assoc -1 ent)) 1)
(if (null loc)
(setq loc opt)
(setq loc (trans loc 1 (cdr (assoc -1 ent))))
)
(setq ent (subst (cons 11 loc) (assoc 11 ent) ent))
)
)
)
)
(entmod ent)
)
)
(progn
;; otherwise list options
(textpage)
(princ "\n 对齐位置设置:\n")
(princ "\t 左上TL 中上TC 右上TR\n")
(princ "\t 左中ML 正中MC 右中MR\n")
(princ "\t 左下BL 中下BC 右下BR\n")
(princ "\t 左Left 中Center 右Right\n")
(princ "\t 对齐Align 中Middle 拟合Fit\n")
(princ "\n回车继续: ")
(grread)
(princ
"\r "
)
(graphscr)
)
)
(command)
)
(defun cht_Text (/ ans)
(if (not nop)
(dscprinc)
)
(setq sslen (sslength sset))
(initget "Globally Individually Retype")
(setq ans
(getkword
"\n 发现并替换文字. 单个(Individually)/重复(Retype)/:"
)
)
(setq cht_OrgTexteval (getvar "texteval"))
(setvar "texteval" 1)
(cond
((= ans "Individually")
(progn
(initget "Yes No")
(setq ans (getkword "\n在对话框中修改文字? :"))
)
(while (> sslen 0)
(redraw (setq sn (ssname sset (setq sslen (1- sslen)))) 3)
(setq ss (ssadd))
(ssadd (ssname sset sslen) ss)
(if (= ans "No")
(cht_Edit ss)
(command "_.DDEDIT" sn "")
)
(redraw sn 1)
)
)
((= ans "Retype")
(while (> sslen 0)
(setq ent (entget (ssname sset (setq sslen (1- sslen)))))
(redraw (cdr (assoc -1 ent)) 3)
(prompt (strcat "\nOld text: " (cdr (assoc 1 ent))))
(setq nt (getstring T "\nNew text: "))
(redraw (cdr (assoc -1 ent)) 1)
(if (> (strlen nt) 0)
(entmod (subst (cons 1 nt) (assoc 1 ent) ent))
)
)
)
(T
(cht_Edit sset)
;; Change all
)
)
(setvar "texteval" cht_OrgTexteval)
)
(defun C:CHGTEXT () (cht_Edit nil))
(defun cht_Edit (objs / last_o tot_o ent o_str n_str
st s_temp n_slen o_slen si chf chm
cont ans class
)
(if (not nop)
(dscprinc)
)
(if (null objs)
(setq objs (ssget))
)
(setq chm 0)
(if objs
(progn
;; If any objects selected
(if (= (type objs) 'ENAME)
(progn
(setq ent (entget objs))
(princ (strcat "\n存在的字符串: " (cdr (assoc 1 ent))))
)
(if (= (sslength objs) 1)
(progn
(setq ent (entget (ssname objs 0)))
(princ (strcat "\n存在的字符串: " (cdr (assoc 1 ent))))
)
)
)
(setq o_str (getstring "\n 匹配字符串 : " t))
(setq o_slen (strlen o_str))
(if (/= o_slen 0)
(progn
(setq n_str (getstring "\n 新字符串 : " t))
(setq n_slen (strlen n_str))
(setq last_o 0
tot_o (if (= (type objs) 'ENAME)
1
(sslength objs)
)
)
(while ( si 1)
(substr s_temp 1 (1- si))
""
)
n_str
(substr s_temp (+ si o_slen))
)
)
(setq chf t)
;; Found old string
(setq si (+ si n_slen))
)
(setq si (1+ si))
)
)
(if chf
(progn
;; Substitute new string for old
(entmod (subst (cons 1 s_temp) (assoc 1 ent) ent))
(setq chm (1+ chm))
)
)
)
)
(setq last_o (1+ last_o))
)
)
)
)
)
(if (/= (type objs) 'ENAME)
(if (/= (sslength objs) 1)
(princ
(strcat (rtos chm 2 0) " 多行文字改变(text lines changed).")
)
)
)
(terpri)
)
(defun cht_Property (typ prmpt fld / temp ow nw ent tw sty w hw lw sslen
n sn ssl)
(if (not nop)
(dscprinc)
)
(if (= (sslength sset) 1)
;; Special case if there is only
(cht_ProcessOne)
(progn
(cht_SetPrompt)
(if (= nw "List")
(cht_ProcessList)
(if (= nw "Individual")
(cht_ProcessIndividual)
(if (= nw "Select")
(cht_ProcessSelect)
(progn
(if (= typ "Rotation")
(setq nw (* (/ nw 180.0) pi))
)
(if (= (type nw) 'STR)
(if (not (tblsearch "style" nw))
(progn
(princ (strcat nw ": Style not found. "))
)
(cht_ProcessAll)
)
(cht_ProcessAll)
)
)
)
)
)
)
)
)
(defun cht_ProcessAll (/ hl temp)
(if (not nop)
(dscprinc)
)
(setq sslen (sslength sset))
(setq hl (getvar "highlight"))
(setvar "highlight" 0)
(while (> sslen 0)
(setq temp (ssname sset (setq sslen (1- sslen))))
(entmod (subst (cons fld nw)
(assoc fld (setq ent (entget temp)))
ent
)
)
)
(setvar "highlight" hl)
)
(defun cht_ProcessOne ()
(if (not nop)
(dscprinc)
)
(setq temp (ssname sset 0))
(setq ow (cdr (assoc fld (entget temp))))
(if (= opt "Rotation")
(setq ow (/ (* ow 180.0) pi))
)
(redraw (cdr (assoc -1 (entget temp))) 3)
(initget 0)
(if (= opt "Style")
(setq nw (getstring (strcat prmpt " : ")))
(setq nw (getreal (strcat prmpt " : ")))
)
(if (or (= nw "") (= nw nil))
(setq nw ow)
)
(redraw (cdr (assoc -1 (entget temp))) 1)
(if (= opt "Rotation")
(setq nw (* (/ nw 180.0) pi))
)
(if (= opt "Style")
(if (null (tblsearch "style" nw))
(princ (strcat nw ": Style not found. "))
(entmod (subst (cons fld nw)
(assoc fld (setq ent (entget temp)))
ent
)
)
)
(entmod (subst (cons fld nw)
(assoc fld (setq ent (entget temp)))
ent
)
)
)
)
(defun cht_SetPrompt ()
(if (not nop)
(dscprinc)
)
(if (= typ "Style")
(progn
(initget "Individual List New Select ")
(setq nw
(getkword
(strcat "\n 单个Individual/列表List/选择类型Select style/: "
)
)
)
(if (or (= nw "") (= nw nil) (= nw "Enter"))
(setq nw (getstring (strcat prmpt
" 对所有的文字"
": "
)
)
)
)
)
(progn
(initget "List Individual" 1)
(setq nw (getreal (strcat "\n单个Individual/列表List/: "
)
)
)
)
)
)
(defun cht_ProcessList ()
(if (not nop)
(dscprinc)
)
(setq unctr (1- unctr))
(setq sslen (sslength sset))
(setq tw 0)
(while (> sslen 0)
(setq temp (ssname sset (setq sslen (1- sslen))))
(if (= typ "Style")
(progn
(if (= tw 0)
(setq tw (list (cdr (assoc fld (entget temp)))))
(progn
(setq sty (cdr (assoc fld (entget temp))))
(if (not (member sty tw))
(setq tw (append tw (list sty)))
)
)
)
)
(progn
(setq tw (+ tw (setq w (cdr (assoc fld (entget temp))))))
(if (= (sslength sset) (1+ sslen))
(setq lw w
hw w
)
)
(if ( lw w)
(setq lw w)
)
)
)
)
(if (= typ "Rotation")
(setq tw (* (/ tw pi) 180.0)
lw (* (/ lw pi) 180.0)
hw (* (/ hw pi) 180.0)
)
)
(if (= typ "Style")
(progn
(princ (strcat "\n" typ "(s) -- "))
(princ tw)
)
(princ (strcat "\n"
typ
" -- 最小Min: "
(rtos lw 2)
"\t 最大Max: "
(rtos hw 2)
"\t 中间Avg: "
(rtos (/ tw (sslength sset)) 2)
)
)
)
)
(defun cht_ProcessIndividual ()
(if (not nop)
(dscprinc)
)
(setq sslen (sslength sset))
(while (> sslen 0)
(setq temp (ssname sset (setq sslen (1- sslen))))
(setq ow (cdr (assoc fld (entget temp))))
(if (= typ "Rotation")
(setq ow (/ (* ow 180.0) pi))
)
(initget 0)
(redraw (cdr (assoc -1 (entget temp))) 3)
(if (= typ "Style")
(progn
(setq nw (getstring (strcat "\n" prmpt " : ")))
)
(progn
(setq nw (getreal (strcat "\n" prmpt " : ")))
)
)
(if (or (= nw "") (= nw nil))
(setq nw ow)
)
(if (= typ "Rotation")
(setq nw (* (/ nw 180.0) pi))
)
(entmod (subst (cons fld nw)
(assoc fld (setq ent (entget temp)))
ent
)
)
(redraw (cdr (assoc -1 (entget temp))) 1)
)
)
(defun cht_ProcessSelect ()
(if (not nop)
(dscprinc)
)
(princ "\n 查找何种类型名? : ")
(setq sn (xstrcase (getstring))
n -1
nsset (ssadd)
ssl (1- (sslength sset))
)
(if (or (= sn "*") (null sn) (= sn ""))
(setq nsset sset
sn "*"
)
(while (and sn (< n ssl))
(setq temp (ssname sset (setq n (1+ n))))
(if (= (cdr (assoc 7 (entget temp))) sn)
(ssadd temp nsset)
)
)
)
(princ (strcat "\n类型: " sn))
(print (setq ssl (sslength nsset)))
(princ "发现.")
)
(cond
((and ai_dcl (listp ai_dcl))) ; it's already loaded.
((not (findfile "ai_utils.lsp")) ; find it
(ai_abort "CHT" nil)
)
((eq "failed" (load "ai_utils" "failed")) ; load it
(ai_abort "CHT" nil)
)
)
(if (not (ai_acadapp))
(ai_abort "CHT" nil)
)
(defun c:cht () (cht_Main))
(princ "\n\tCHT 命令调入.")
(princ)
(princ) |
|
置顶卡
请点击此处下载
