zbbz的lisp_学习LISP语言的体会
自己从事的工作关系，利用autoCAD软件已经很多年了。
有时候，遇到一些很机械很机械的工作，总想着能不能用程序来帮帮忙。
于是，有一天就开始接触Lisp，翻翻相关的参考书，再看看别人的实例，
渐渐地，居然慢慢地就觉得开始有点上手。
之后，开始编写一些简单的功能，同时，不断的翻阅参考书，
了解其中的条理，熟悉了Liap语言的诸多函数命令。
到了一定地步，又有更野心的想法——编一个超大的程序！
一边摸索一边在努力，一个星期一个月过去，利用闲暇之余，
居然把它弄出来。那一下，真正体会到的其中的乐趣。
挑战自我，还要有点野心，再加上不懈的追求。
下面是本人的编写的一个“坐标标注”的例子，本文只是作为一个引子，希望有相同爱好的人能够互相沟通，互相促进。在工作中遇到种种繁琐之事，不妨考虑采用程序来帮忙，提高自己的工作效率，从中把自己解脱出来。
坐标标注选项界面定制
zbbzsz_dlg : dialog {label = "坐标标注设置编辑框";
: boxed_column {label = "标注点XYZ显示效果";width = 45;
: row {
: text {label = "";}
: text {label = "X";}
: text {label = "Y";}
: text {label = "Z";}
}
: row {
: edit_box {label = "前缀:";key = "xq";}
: edit_box {key = "yq";}
: edit_box {key = "zq";}
}
: row {
: popup_list {label = "精度";key = "xz";list="0\n0.0\n0.00\n0.000\n0.0000\n0.00000\n0.000000";}
: popup_list {label = "";key = "yz";list="0\n0.0\n0.00\n0.000\n0.0000\n0.00000\n0.000000";}
: popup_list {label = "";key = "zz";list="0\n0.0\n0.00\n0.000\n0.0000\n0.00000\n0.000000";}
}
: row {
: edit_box {label = "后缀:";key = "xh";}
: edit_box {key = "yh";}
: edit_box {key = "zh";}
}
: row {
: edit_box {label = "比例:";key = "xbl";}
: edit_box {key = "ybl";}
: edit_box {key = "zbl";}
}
}
: row {
: boxed_column {label = "文字描述";fixed_width = true;
: row {
: button {key = "pickGD";fixed_width = true; label = "高度";}
: edit_box {label = "";key = "zg";width = 4;}
//: text {label = " ";}
}
: row {
: button {key = "pickBL";fixed_width = true; label = "宽度比例";}
: edit_box {label = "";key = "gkb";width = 4;fixed_width = true;}
//: text {label = " ";}
}
: row {
: button {key = "pickpj";fixed_width = true; label = "偏距";}
: edit_box {label = "";key = "pj";}
//: text {label = " ";}
}
: row {
: button {key = "pickfx";fixed_width = true; label = "方向";}
: edit_box {label = "";key = "fx";width = 6;fixed_width = true;}
: text {label = "度";}
}
}
spacer_1;
:column {
spacer;
: toggle {label = "显示高程";key = "gckg";}
: toggle {label = "显示前缀和后缀";key = "qzhz";}
: toggle {label = "指定标注位置";key = "bzwz";}
: toggle {label = "标注方向同引出方向";key = "bzfx";}
spacer;
}
}
ok_cancel;
errtile;
}
;;;该程序功能:用于坐标点的坐标标注
;;;改进前面版本的功能有
;;;1.可以指定或不指定标注位置进行标注
;;;2.可以连续进行标注,同时允许定义'字高''字宽比''方向''高程开关''前缀开关''退一步'
;;;
(defun biaozhu-a ($in / p1 p2 p3 m a old_aunits old_ORTHOMODE plw oldos
str
qianzhui
textH width_f definep biaozhuweizhi sw_h
;前缀qz 后缀hz 精度jd
xqz yqz hqz xhz yhz hhz xjd yjd hjd
;XYZ的例
xbl ybl zbl
;偏距defaultPJ 方向defaultFX
defaultPJ defaultFX
savefile biaozhuxuanxiang
*merrmsg* write_t style1 mod_style select1
)
(If (setq a (findfile "ME_TOOL.mnu"))
(setq savefile (strcat (substr a 1 (- (strlen a) 11)) "坐标标注.def"))
(setq savefile "坐标标注.def")
)
(defun *merrmsg* (msg)
(princ msg)
(setq *error* m:err m:err nil)
(setvar "osmode" oldos)
(setvar "plinewid" plw)
(setvar "aunits" old_aunits)
(setvar "ORTHOMODE" old_ORTHOMODE)
(command "undo" "end")
(setvar "CMDECHO" 1)
(princ)
)
(defun ZWX::pickPJorFX (doMode oldValue / a b entg exi)
(cond
((= 0 doMode)
(if (setq a (getdist "\n输入文字的偏距:"))
(setq a (abs a))
)
)
((= 1 doMode)
(if (setq a (getangle "\n输入文字的方向:"))
(setq a (/ (* 180 a) pi))
)
)
((> 4 doMode)
(setq exi nil)
(while (not exi)
(if (setq a (entsel "\n选择文字:"))
;(progn
(if (= "TEXT" (strcase (cdr (assoc 0 (setq entg (entget (car a)))))))
(setq a (cdr (assoc (if (= 2 doMode) 40 41) entg)) exi t)
)
;)
(setq exi t)
)
)
)
)
(if a a oldValue)
)
(defun biaozhuxuanxiang ( / dcl_id xqz1 xjd1 xhz1 yqz1 yjd1 yhz1 hqz1 hjd1 hhz1
textH1 width_f1 pj1 fx1 qzhz
definep1 biaozhuweizhi1 sw_h1
doWhile
)
(setq xqz1 xqz xjd1 xjd xhz1 xhz
yqz1 yqz yjd1 yjd yhz1 yhz
hqz1 hqz hjd1 hjd hhz1 hhz
textH1 textH width_f1 width_f sw_h1 sw_h
pj1 defaultPJ fx1 defaultFX
definep1 definep biaozhuweizhi1 biaozhuweizhi
qzhz qianzhui
doWhile 2
)
(if (not (setq dcl_id (load_dialog "坐标标注.dcl")))(exit))
(while (< 1 doWhile)
(if (not (new_dialog "zbbzsz_dlg" dcl_id))(exit))
(set_tile "xq" xqz)
(set_tile "xz" (itoa xjd))
(set_tile "xh" xhz)
(set_tile "yq" yqz)
(set_tile "yz" (itoa yjd))
(set_tile "yh" yhz)
(set_tile "zq" hqz)
(set_tile "zz" (itoa hjd))
(set_tile "zh" hhz)
(set_tile "zg" (rtos textH 2))
(set_tile "gkb" (rtos width_f 2))
(set_tile "pj" (rtos defaultPJ 2))
(set_tile "fx" (rtos defaultFX 2))
(set_tile "gckg" (if sw_h "1" "0"))
(set_tile "qzhz" (if qianzhui "1" "0"))
(set_tile "bzwz" (if definep "1" "0"))
(set_tile "bzfx" (if biaozhuweizhi "1" "0"))
(set_tile "xbl" (rtos xbl 2))
(set_tile "ybl" (rtos ybl 2))
(set_tile "zbl" (rtos zbl 2))
(action_tile "xq" "(setq xqz (get_tile $key))")
(action_tile "xz" "(setq xjd (atoi (get_tile $key)))")
(action_tile "xh" "(setq xhz (get_tile $key))")
(action_tile "yq" "(setq yqz (get_tile $key))")
(action_tile "yz" "(setq yjd (atoi (get_tile $key)))")
(action_tile "yh" "(setq yhz (get_tile $key))")
(action_tile "zq" "(setq hqz (get_tile $key))")
(action_tile "zz" "(setq hjd (atoi (get_tile $key)))")
(action_tile "zh" "(setq hhz (get_tile $key))")
(action_tile "zg" "(setq textH (atof (get_tile $key)))")
(action_tile "gkb" "(setq width_f (atof (get_tile $key)))")
(action_tile "gckg" "(setq sw_h (if (= 1 (atoi (get_tile $key))) t nil))")
(action_tile "qzhz" "(setq qianzhui (if (= 1 (atoi (get_tile $key))) t nil))")
(action_tile "bzwz" "(setq definep (if (= 1 (atoi (get_tile $key))) t nil))") ; p2 nil
(action_tile "bzfx" "(setq biaozhuweizhi (if (= 1 (atoi (get_tile $key))) t nil))") ; p3 nil
(action_tile "pj" "(setq defaultPJ (atof (get_tile $key)))")
(action_tile "fx" "(setq defaultFX (atof (get_tile $key)))")
(action_tile "xbl" "(setq xbl (atof (get_tile $key)))")
(action_tile "ybl" "(setq ybl (atof (get_tile $key)))")
(action_tile "zbl" "(setq zbl (atof (get_tile $key)))")
(action_tile "pickpj" "(done_dialog 2)")
(action_tile "pickfx" "(done_dialog 3)")
(action_tile "pickGD" "(done_dialog 4)")
(action_tile "pickBL" "(done_dialog 5)")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cencel" "(done_dialog 0)")
(setq doWhile (start_dialog))
(cond
((= 1 doWhile)
(if (> 0 defaultPJ)(setq defaultPJ 7.5))
(if (> 0 xbl)(setq xbl 1))
(if (> 0 ybl)(setq ybl 1))
(if (> 0 zbl)(setq zbl 1))
(select1 "ALL")(cover-def nil)
)
((= 0 doWhile)
(setq xqz xqz1 xjd xjd1 xhz xhz1
yqz yqz1 yjd yjd1 yhz yhz1
hqz hqz1 hjd hjd1 hhz hhz1
textH textH1 width_f width_f1 sw_h sw_h1
definep1 definep biaozhuweizhi1 biaozhuweizhi
defaultPJ pj1 defaultFX fx1 qianzhui qzhz
)
)
((= 2 doWhile)(setq defaultPJ (ZWX::pickPJorFX 0 defaultPJ)))
((= 3 doWhile)(setq defaultFX (ZWX::pickPJorFX 1 defaultFX)))
((= 4 doWhile)(setq textH (ZWX::pickPJorFX 2 textH)));
((= 5 doWhile)(setq width_f (ZWX::pickPJorFX 3 width_f)))
)
)
)
(defun read-def (headlist / $a $b $c $d $l $exit)
(if (setq $a (open savefile "r"))(progn
(while (and (not $exit) (setq $b (read-line $a)) $b (/= "" $b))
(if (/= (substr $b 1 2) "//")(progn
(setq $b (fg $b '("====") nil) $b (subst (strcase (car $b)) (car $b) $b)) ;改为大写
(if (not headlist)
(setq $l (cons $b $l))
(progn
(if (member (car $b) headlist)(setq $l (cons $b $l)))
(if (and $l (= (length $l) (length headlist)))(setq $exit t))
)
)
))
)(setq $l (reverse $l))
(close $a)
)) ;(if (setq $a (open dat_filename
(setq textH (cadr (assoc "TEXTH" $l))
width_f (cadr (assoc "WIDTH_F" $l))
sw_h (cadr (assoc "SW_H" $l))
definep (cadr (assoc "DEFINEP" $l))
biaozhuweizhi (cadr (assoc "BIAOZHUWEIZHI" $l))
qianzhui (cadr (assoc "QIANZHUI" $l))
xqz (cadr (assoc "XQZ" $l))
yqz (cadr (assoc "YQZ" $l))
hqz (cadr (assoc "HQZ" $l))
xhz (cadr (assoc "XHZ" $l))
yhz (cadr (assoc "YHZ" $l))
hhz (cadr (assoc "HHZ" $l))
xjd (cadr (assoc "XJD" $l))
yjd (cadr (assoc "YJD" $l))
hjd (cadr (assoc "HJD" $l))
defaultPJ (cadr (assoc "DEFAULTPJ" $l))
defaultFX (cadr (assoc "DEFAULTFX" $l))
xbl (cadr (assoc "XBL" $l))
ybl (cadr (assoc "YBL" $l))
zbl (cadr (assoc "ZBL" $l))
)
(setq width_f (if (or (not width_f) (>= 0 (atof width_f))) 1 (atof width_f))
textH (if (or (not textH) (>= 0 (atof textH))) 1 (atof textH))
sw_h (if (and sw_h (= "T" (strcase sw_h))) t nil)
definep (if (and definep (= "T" (strcase definep))) t nil)
biaozhuweizhi (if (and biaozhuweizhi (= "T" (strcase biaozhuweizhi))) t nil)
qianzhui (if (and qianzhui (= "T" (strcase qianzhui))) t nil)
xbl (if (or (not xbl) (>= 0 (atof xbl))) 1 (atof xbl))
ybl (if (or (not ybl) (>= 0 (atof ybl))) 1 (atof ybl))
zbl (if (or (not zbl) (>= 0 (atof zbl))) 1 (atof zbl))
)
(if (not xqz) (setq xqz ""))
(if (not yqz) (setq yqz ""))
(if (not hqz) (setq hqz ""))
(if (not xhz) (setq xhz ""))
(if (not yhz) (setq yhz ""))
(if (not hhz) (setq hhz ""))
(if (or (not xjd) (> 0 (atoi xjd))) (setq xjd 3)(setq xjd (atoi xjd)))
(if (or (not yjd) (> 0 (atoi yjd))) (setq yjd 3)(setq yjd (atoi yjd)))
(if (or (not hjd) (> 0 (atoi hjd))) (setq hjd 3)(setq hjd (atoi hjd)))
(if (or (not defaultPJ) (>= 0 (atof defaultPJ))) (setq defaultPJ 7.5)(setq defaultPJ (atof defaultPJ)))
(if (not defaultFX) (setq defaultFX 45.0)(setq defaultFX (atof defaultFX)))
)
(defun cover-def (coverlist / $a $b $c $d $l)
(if (not coverlist)
(setq coverlist
(list (list "TEXTH" textH)
(list "WIDTH_F" width_f)
(list "SW_H" sw_h)
(list "DEFINEP" definep)
(list "BIAOZHUWEIZHI" biaozhuweizhi)
(list "QIANZHUI" qianzhui)
(list "XQZ" xqz)
(list "YQZ" yqz) (list "HQZ" hqz)
(list "XHZ" xhz) (list "YHZ" yhz)
(list "HHZ" hhz) (list "XJD" xjd)
(list "YJD" yjd) (list "HJD" hjd)
(list "defaultPJ" defaultPJ)
(list "defaultFX" defaultFX)
))
)
(if (setq $a (open savefile "w"))(progn
(write-line "//更改下面的参数设置的值,只有当重新开始一个新的文档时才生效.//" $a)
(foreach $b coverlist ;(princ $b)
(if (not (cadr $b))(setq $b (list (car $b) "")))
(if (numberp (cadr $b))(setq $b (list (car $b) (rtos (cadr $b) 2 4))))
(if (= t (cadr $b))(setq $b (list (car $b) "t")))
(write-line (strcat (car $b) "====" (cadr $b)) $a)
)
(close $a)
))
)
(defun write_t($p1 $p2 $p3 $textH $biaozhuweizhi /
$a t1 t2 t3 c1 tem tem2 tem3 tem4 l1 LText
p5 p6 p7 p8 p9 $p11 $p12 $p13 $p14 in1 in2 in3
defaultFX1
;;; yjd1 xjd1 hjd1
)
(setq defaultFX1 (/ (* pi defaultFX) 180.0))
(if (and $p1 (not $p2)) (progn
;;; (setq $p2 (polar $p1 (* pi 0.25) (* 2.5 $textH)))
(setq $p2 (polar $p1 defaultFX1 defaultPJ))
;;; (if biaozhuweizhi
;;; (setq $p3 (polar $p2 defaultFX1 1.0))
;;; (setq $p3 (polar $p2 0 1.0))
;;; )
))
(if (and $p1 $p2 (not $p3))(progn
(setq $a (angle $p1 $p2))
(if biaozhuweizhi
(setq $p3 (polar $p2 $a 1.0))
(if (and (< (* pi 0.5) $a) (> (* pi 1.5) $a))
(setq $p3 (polar $p2 pi 1.0))
(setq $p3 (polar $p2 0 1.0))
)
)
))
;; 多义线三点p1 $p2 $p3 字高p4
(setq t1 (if qianzhui (strcat yqz (rtos (/ (nth 0 $p1) ybl) 2 yjd) yhz) (rtos (/ (nth 0 $p1) ybl) 2 yjd))
t2 (if qianzhui (strcat xqz (rtos (/ (nth 1 $p1) xbl) 2 xjd) xhz) (rtos (/ (nth 1 $p1) xbl) 2 xjd))
t3 (if qianzhui (strcat hqz (rtos (/ (nth 2 $p1) zbl) 2 hjd) hhz) (rtos (/ (nth 2 $p1) zbl) 2 hjd)))
(setq $p11 (caadr (textbox (list (cons 1 t1))));
$p11 (/ $p11 (strlen t1)))
(setq LText (max (strlen t1) (strlen t2) (strlen t3)))
(setq LText (* $p11 (+ 0.5 Ltext)))
;
(setq p9 $p1)
(setq tem (if (< (nth 0 $p2) (nth 0 $p3)) $p2 $p3))
(setq tem2 (if (= tem $p2) 1 0))
(setq $p14 (if (= tem $p2) $p3 $p2))
(setq $p3 (angle $p2 $p3))
(setq $p1 (angle $p2 $p1))
(setq c1 (- $p3 $p1))
;;;
;;;判断c1是锐角tem4=1还是钝角tem4=0
;;;
(setq tem4 (if (and (>= (abs c1) 1.570796) (<= (abs c1) 4.7123892)) 0 1))
;;;
;;;判断p3是在p1的左边tem3=1还是右边tem3=0
;;;
(setq tem3 (if (or (and (>= c1 0) (<= c1 3.1415926)) (and (>= c1 -6.2831852) (<= c1 -3.1415926))) 1 0))
;;;
;;;将p3化弧度为角度存放于p2
;;;
(setq $p2 (* $p3 57.29578049))
(setq $p2 (if (= tem2 0) (+ $p2 180) $p2))
;;;
;;;按字大小的0.25倍依比例计算行距p5
;;;
(setq p5 (* $textH 0.25))
;;;
;;;分别计算各行注记的起始位置
;;;
;;;tem4=1为锐角
;;;
(cond ((= tem4 1)
(progn
(cond ((and (= tem3 0) (= tem2 1))
(progn
(setq l1 (* (/ (cos (- 6.283185 c1)) (sin (- 6.283185 c1))) (+ (* p5 3) $textH)))
(setq $p11 (+ (atan p5 l1) $p3))
(setq p6 (sqrt (+ (* l1 l1) (* p5 p5))))
(setq $p12 (- $p3 (atan p5 l1)))
(setq p7 (sqrt (+ (* l1 l1) (* p5 p5))))
; (setq $p12 (- $p3 (atan (+ p5 $textH) l1)))
; (setq p7 (sqrt (+ (* l1 l1) (* (+ p5 $textH) (+ p5 $textH)))))
(setq $p13 (- $p3 (atan (+ (* 2 p5) (* 2 $textH)) l1)))
(setq p8 (sqrt (+ (* l1 l1) (* (+ (* 2 p5) (* 2 $textH)) (+ (* 2 p5) (* 2 $textH))))))
(setq l1 (- (+ Ltext l1) (distance tem $p14)))
))
((and (= tem3 0) (= tem2 0))
(progn
(setq l1 (abs (* (/ (cos (- 6.283185 c1)) (sin (- 6.283185 c1))) (+ (* p5 3) $textH))))
(setq l1 (- (+ Ltext l1) (distance tem $p14)))
(setq $p11 (if (< l1 0) (- $p3 (atan p5 l1)) (- $p3 (atan p5 l1))))
(setq p6 (sqrt (+ (* l1 l1) (* p5 p5))))
(setq $p12 (if (< l1 0) (+ $p3 (atan p5 l1)) (+ $p3 (atan p5 l1))))
(setq p7 (sqrt (+ (* l1 l1) (* p5 p5))))
; (setq p7 (sqrt (+ (* l1 l1) (* (+ p5 $textH) (+ p5 $textH)))))
; (setq $p12 (if (< l1 0) (+ $p3 (atan (+ p5 $textH) l1)) (+ $p3 (atan (+ p5 $textH) l1))))
(setq $p13 (if (< l1 0) (+ $p3 (atan (+ (* 2 p5) (* 2 $textH)) l1)) (+ $p3 (atan (+ (* 2 p5) (* 2 $textH)) l1))))
(setq p8 (sqrt (+ (* l1 l1) (* (+ (* 2 p5) (* 2 $textH)) (+ (* 2 p5) (* 2 $textH))))))
))
((and (= tem3 1) (= tem2 1))
(progn
(setq l1 (abs (* (/ (cos (- 6.283185 c1)) (sin (- 6.283185 c1))) (+ (* p5 4) (* 2 $textH)))))
(setq $p11 (+ (atan p5 l1) $p3))
(setq p6 (sqrt (+ (* l1 l1) (* p5 p5))))
(setq $p12 (- $p3 (atan p5 l1)))
(setq p7 (sqrt (+ (* l1 l1) (* p5 p5))))
; (setq $p12 (- $p3 (atan (+ p5 $textH) l1)))
; (setq p7 (sqrt (+ (* l1 l1) (* (+ p5 $textH) (+ p5 $textH)))))
(setq $p13 (- $p3 (atan (+ (* 2 p5) (* 2 $textH)) l1)))
(setq p8 (sqrt (+ (* l1 l1) (* (+ (* 2 p5) (* 2 $textH)) (+ (* 2 p5) (* 2 $textH))))))
(setq l1 (- (+ Ltext l1) (distance tem $p14)))
))
((and (= tem3 1) (= tem2 0))
(progn
(setq l1 (abs (* (/ (cos (- 6.283185 c1)) (sin (- 6.283185 c1))) (+ (* p5 3) $textH))))
(setq l1 (- (+ Ltext l1) (distance tem $p14)))
(setq $p11 (if (< l1 0) (- $p3 (atan p5 l1)) (- $p3 (atan p5 l1))))
(setq p6 (sqrt (+ (* l1 l1) (* p5 p5))))
(setq $p12 (if (< l1 0) (+ $p3 (atan p5 l1)) (+ $p3 (atan p5 l1))))
(setq p7 (sqrt (+ (* l1 l1) (* p5 p5))))
; (setq $p12 (if (< l1 0) (+ $p3 (atan (+ p5 $textH) l1)) (+ $p3 (atan (+ p5 $textH) l1))))
; (setq p7 (sqrt (+ (* l1 l1) (* (+ p5 $textH) (+ p5 $textH)))))
(setq $p13 (if (< l1 0) (+ $p3 (atan (+ (* 2 p5) (* 2 $textH)) l1)) (+ $p3 (atan (+ (* 2 p5) (* 2 $textH)) l1))))
(setq p8 (sqrt (+ (* l1 l1) (* (+ (* 2 p5) (* 2 $textH)) (+ (* 2 p5) (* 2 $textH))))))
))
)
))
;;;
;;;tem4=0为钝角
;;;
((= tem4 0)
(cond ((= tem2 0)
(progn
(setq l1 (- Ltext (distance tem $p14)))
(setq $p11 (if (< l1 0) (- $p3 (atan p5 l1)) (- $p3 (atan p5 l1))))
(setq p6 (sqrt (+ (* l1 l1) (* p5 p5))))
(setq $p12 (if (< l1 0) (+ $p3 (atan p5 l1)) (+ $p3 (atan p5 l1))))
(setq p7 (sqrt (+ (* l1 l1) (* p5 p5))))
; (setq $p12 (if (< l1 0) (+ $p3 (atan (+ p5 $textH) l1)) (+ $p3 (atan (+ p5 $textH) l1))))
(setq $p13 (if (< l1 0) (+ $p3 (atan (+ (* 2 p5) (* 2 $textH)) l1)) (+ $p3 (atan (+ (* 2 p5) (* 2 $textH)) l1))))
(setq p8 (sqrt (+ (* l1 l1) (* (+ (* 2 p5) (* 2 $textH)) (+ (* 2 p5) (* 2 $textH))))))
))
((= tem2 1)
(progn
(setq l1 (* 1.5 p5))
(setq $p11 (+ (atan p5 l1) $p3))
(setq p6 (sqrt (+ (* l1 l1) (* p5 p5))))
(setq $p12 (- $p3 (atan p5 l1)))
(setq p7 (sqrt (+ (* l1 l1) (* p5 p5))))
; (setq $p12 (- $p3 (atan (+ p5 $textH) l1)))
; (setq p7 (sqrt (+ (* l1 l1) (* (+ p5 $textH) (+ p5 $textH)))))
(setq $p13 (- $p3 (atan (+ (* 2 p5) (* 2 $textH)) l1)))
(setq p8 (sqrt (+ (* l1 l1) (* (+ (* 2 p5) (* 2 $textH)) (+ (* 2 p5) (* 2 $textH))))))
(setq l1 (- Ltext (distance tem $p14)))
) ))
)
)
;;;
(setq in1 (polar tem $p11 p6))
(setq in2 (polar tem $p12 p7))
(setq in3 (polar tem $p13 p8))
(if (= tem2 0) (setq tem (polar tem $p3 l1)) (setq $p14 (polar $p14 $p3 l1)))
;;;
;;;
(if (= tem2 0) (command "pline" p9 $p14 tem "") (command "pline" p9 tem $p14 ""))
(command "text" in1 $textH $p2 t2)
(command "text" "j" "tl" in2 $textH $p2 t1)
(if sw_h (command "text" in3 $textH $p2 t3))
(princ (strcat "\t" t2 "," t1 "," t3))
)
(defun mod_style( / entg1 _en)
(setq entg1 (entget (setq _en (tblobjname "style" "坐标")))
entg1 (subst (cons 41 width_f) (assoc 41 entg1) entg1))
(entmod entg1)(entupd _en)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;select1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun select1(sp / a)
(IF (or (= "W" sp)(= "ALL" sp)) (progn
(if (= "W" sp) (progn
(setq a (getreal (strcat "\n设置高宽比(" (rtos width_f 2 4) "): ")))
(cond ((not a))
((>= 0 a)(setq width_f 1))
(t (setq width_f a))
)
))
(mod_style)
))
(IF (or (= "H" sp)(= "ALL" sp)) (progn
(if (= "H" sp) (progn
(command "ortho" "on")
(setq a (getdist (strcat "\n输入字高(" (rtos textH 2 4) ")?")))
(cond ((>= 0 a)(setq textH 1))
((= nil a))
(t (setq textH a))
)
(princ (strcat "新的字高=" (rtos textH 2 4)))
(command "ortho" "off")
))
(setvar "TEXTSIZE" textH)
))
(IF (= "S" sp)(progn
(setq sw_h (not sw_h))
(princ (if sw_h "\t显示高程." "\t不显示高程."))
))
(IF (= "Q" sp)(progn
(setq qianzhui (not qianzhui))
(princ (if qianzhui "\t显示前缀和后缀." "\t不显示前缀和后缀."))
))
(IF (= "P" sp)(progn
(setq definep (not definep))
(princ (if definep "\t需要指定文字位置." "\t不需要指定文字位置."))
))
(IF (= "A" sp)(progn
(setq biaozhuweizhi (not biaozhuweizhi))
(princ (if biaozhuweizhi "\t文字方向同引线方向打印." "\t文字方向横向或竖向打印."))
))
;保存参数 字高 比例 高 指定位置 标注位置 前缀;
(setq define_biaozhu (list textH width_f sw_h definep biaozhuweizhi qianzhui
xqz yqz hqz xhz yhz hhz xjd yjd hjd
defaultFX defaultPJ
xbl ybl zbl
))
)
;;;
;;;
(setvar "CMDECHO" 0)
(if (setq style1 (tblsearch "style" "坐标"))
(progn
(setq width_f (cdr (assoc 41 style1)))
(if (/= "坐标" (getvar "textstyle"))(setvar "textstyle" "坐标"))
)
(command "style" "坐标" "黑体" 0 1 0 "" "")
)
(if (not define_biaozhu)
(progn
;设置原始参数
(read-def nil)
(cover-def nil)
(setvar "TEXTSIZE" textH)
;(select1 "ALL")
)
;读取参数
(progn
(setq textH (nth 0 define_biaozhu)
width_f (nth 1 define_biaozhu)
sw_h (nth 2 define_biaozhu)
definep (nth 3 define_biaozhu)
biaozhuweizhi (nth 4 define_biaozhu)
qianzhui (nth 5 define_biaozhu)
xqz (nth 6 define_biaozhu) yqz (nth 7 define_biaozhu)
hqz (nth 8 define_biaozhu) xhz (nth 9 define_biaozhu)
yhz (nth 10 define_biaozhu) hhz (nth 11 define_biaozhu)
xjd (nth 12 define_biaozhu) yjd (nth 13 define_biaozhu)
hjd (nth 14 define_biaozhu)
defaultFX (nth 15 define_biaozhu)
defaultPJ (nth 16 define_biaozhu)
xbl (nth 17 define_biaozhu)
ybl (nth 18 define_biaozhu)
zbl (nth 19 define_biaozhu)
)
(if style1 (setq width_f (cdr (assoc 41 style1))))
(if (= 0 textH)(setq textH 1))
(if (= 0 width_f)(setq width_f 1))
(if (= 0 sw_h)(setq sw_h t))
(mod_style)
)
)
;;;
;;;
(setq m:err *error* *error* *merrmsg*)
(command "undo" "be")
(setq plw (getvar "plinewid")
old_aunits (getvar "aunits")
old_ORTHOMODE (getvar "ORTHOMODE")
)
(setvar "plinewid" 0)
(setvar "aunits" 0)
(setq oldos (getvar "osmode")); xqz "X=" yqz "Y=" hqz "H="
(if (not $in)(progn
(setvar "ORTHOMODE" 0)
(setvar "osmode" 553)
(setq p1 "W" str "\n待标注的点[指定位置P/方向A/字高H/长宽比W/高程S/前后缀Q/选项X]:")
(princ (strcat "\n当前字高=" (rtos textH) ".长宽比=" (rtos width_f) ".高程"
(if (not sw_h) "不显示." "显示.")))
(initget "W H S L P A Q X")
(while (setq p1 (getpoint str))
(cond
((= "U" p1)(command "undo" "back")(princ "\t退一步."))
((= "X" p1)(biaozhuxuanxiang))
;;; ((= "Q" p1)(setq qianzhui (not qianzhui))
;;; (if (setq qianzhui (not qianzhui))
;;; (setq xqz "X=" yqz "Y=" hqz "H=")
;;; (setq xqz "" yqz "" hqz "")
;;; )
;;; )
;;; ((= "P" p1)
;;; (if (setq definep (not definep)) (princ "\t需要指定文字位置.")(princ "\t不需要指定文字位置."))
;;; (select1 "")
;;; )
;;; ((= "A" p1)
;;; (if (setq biaozhuweizhi (not biaozhuweizhi)) (princ "\t文字方向同引线方向.")(princ "\t需要指定文字方向."))
;;; (select1 "")
;;; )
((or (= "Q" p1) (= "A" p1) (= "P" p1) (= "W" p1) (= "H" p1) (= "S" p1))
(select1 p1)
(cover-def nil)
)
((listp p1)
(command "undo" "mark")
(if definep (progn
(setq m (getvar "osmode"))
(command "osnap" "none")
(setq p2 (getpoint p1 "\n指定文字位置(空回车文字位置及方向按缺省方式):"))
(if p2 (progn
(command "ortho" "on")
(setq p3 (getpoint p2 "\n指定文字方向(空回车文字方向按缺省方向):"))
(command "ortho" "off")
))
(setvar "osmode" m)
))
(setq m (getvar "osmode"))
(setvar "osmode" 0)
(write_t p1 p2 p3 textH biaozhuweizhi)
(setvar "osmode" m)
(setq p1 nil p2 nil p3 nil)
))
(initget "W H S U L P A Q X")
(setq str "\n待标注的点[指定位置P/方向A/字高H/长宽比W/高程S/前后缀Q/选项X/退一步U]:")
)
)
(if (listp $in) (progn
(setq p1 $in)(undefinep)
))
)
(setvar "osmode" oldos)
(setvar "plinewid" plw)
(setvar "aunits" old_aunits)
(setvar "ORTHOMODE" old_ORTHOMODE)
(command "undo" "end")
(setvar "CMDECHO" 1)
(princ)
)
(defun c:biaozhu ()
(biaozhu-a nil)
)
posted on 2006-08-20 20:59 深藏记忆 阅读(1386) 评论(3) 编辑 收藏 所属分类: Vlisp之韵