在autocad中计算曲线要素的lisp程序。
请大家指教此lisp程序有何改进之处？感谢大家！！
程序源码：
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;曲线要素计算;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;说明:本程序的功能是:通过分别选取两条直线上的每两个点,及输入的半径把曲线要素标注出来,并画弧;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;出错处理
(VL-Load-Com)
(SetQ **SysVarNL** '("AUNITS" "AUPREC" "ATTDIA" "BLIPMODE" "CECOLOR" "CELTYPE"
"CLAYER" "CMDECHO" "EXPERT" "HIGHLIGHT" "LUNITS" "LUPREC"
"OSMODE" "ORTHOMODE" "TEXTSTYLE" "PLINEWID"
)
)
(Defun-Q SetIErr (/ sv)
(If (= 'LIST (Type *error*))
(Alert "注意：最后一个(SetIErr)函数没有配对的(ReErr)!")
(Progn (SetQ **svarl** '())
(ForEach sv **SysVarNL**
(SetQ **svarl** (Cons (GetVar sv) **svarl**))
)
(ForEach sv '("ATTDIA" "BLIPMODE" "CMDECHO" "HIGHLIGHT"
"OSMODE" "ORTHOMODE"
)
(SetVar sv 0)
)
(SetVar "EXPERT" 5)
(Defun-Q *error* (st) (ReErr))
)
)
)
(Defun-Q ReErr ()
(If (= 'List (Type *error*))
(Progn (MapCar 'SetVar **SysVarNL** (Reverse **svarl**))
(SetQ *error* nil) (PrinC)
)
(Alert "注意：没有对应引用 (SetIErr)!")
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;主程序
(defun C:qxjs()
(setierr)
(vl-load-com)
(setq acadobject(vlax-get-acad-object)
acaddocument(vla-get-activedocument acadobject)
mspace1(vla-get-modelspace acaddocument)
mspace2(vla-get-modelspace acaddocument))
(command "layer" "m" "曲线要素" "c" 1 "" "")
(command "style" "standard" "txt,hztxt" "0" ".8" "0" "n" "n" "n")
(command "units" 2 3 2 4 "" "")
(command "graphscr")
(ysjs);;;;;;;;调用要素计算函数(YSJS)
(princ)
(reerr)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;要素计算
(defun ysjs ()
(princ "\n※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※")
(princ "\n※※※※※※※※※※※欢迎使用本程序,Thank You!※※※※※※※※※※※※")
(princ "\n※※※曲线要素计算程序 V1.0 版本 作者:谢亮 2003年10月15日 于娄底。※※※")
(princ "\n※※※※※※※※※※※※※※※※※说明※※※※※※※※※※※※※※※※※")
(princ "\n※※※※※※本程序的功能是:通过分别选取两条直线上的每两个点,※※※※※※")
(princ "\n※※※※※※及输入的半径把曲线要素标注出来,并画弧。※※※※※※※※※※")
(princ "\n※※※※※※注意:如果两直线共线则程序退出!※※※※※※※※※※※※※※※")
(princ "\n※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;计算方角
(command "osmode" 16383)
;;;;;;;;;;;;;选择直线上的点以计算方位角
(setq a10 (getpoint"\n请选择一直线上一点:"))
;;;;;;;出错循环
(while (= nil a10)
(setq a10 (getpoint"\n请重新选择直线上一点:")))
(setq a11 (getpoint"\n请选择直线上另一点:"))
;;;;;;;出错循环
(while (or (= nil a11)
(= a11 a10))
(setq a11 (getpoint"\n请重新选择直线上另一点:")))
(setq a20 (getpoint"\n请选择另一直线上一点:"))
;;;;;;;出错循环
(while (or (= nil a20)
(= a20 a11)
(= a20 a10))
(setq a20 (getpoint"\n请重新选择另一直线上一点:")))
(setq a21 (getpoint"\n请选择直线上另一点:"))
;;;;;;;出错循环
(while (or (= nil a21)
(= a21 a11)
(= a21 a10)
(= a21 a20))
(setq a21 (getpoint"\n请重新选择直线上另一点:")))
;;;;;;;得到选中点(a10与a11、a20与a21)的X、Y坐标及增量
(setq a10x (car a10))
(setq a10y (cadr a10))
(setq a11x (car a11))
(setq a11y (cadr a11))
(setq a20x (car a20))
(setq a20y (cadr a20))
(setq a21x (car a21))
(setq a21y (cadr a21))
(setq da1y (- a11y a10y))
(setq da1x (- a11x a10x))
(setq da2x (- a21x a20x))
(setq da2y (- a21y a20y))
;;;;;;;;;;;判断除数是否为零(方位角是否为：0、90、180、270、360度)
(if (= da1x 0) (setq da1x (+ da1x 0.000000000000001)))
(if (= da1y 0) (setq da1y (+ da1y 0.000000000000001)))
(if (= da2x 0) (setq da2x (+ da2x 0.000000000000001)))
(if (= da2y 0) (setq da2y (+ da2y 0.000000000000001)))
;;;;;;;;判断方位角象限(一、二、三、四)
;;;;;;;;;判断直线一
;;;;;;;;;一象限
(if (and (> da1x 0)
(> da1y 0))
(setq a1 (atan (/ da1y da1x))))
;;;;;;;;;二象限
(if (and (< da1x 0)
(> da1y 0))
(setq a1 (+ 3.1415926 (atan (/ da1y da1x)))))
;;;;;;;;;三象限
(if (and (< da1x 0)
(< da1y 0))
(setq a1 (+ 3.1415926 (atan (/ da1y da1x)))))
;;;;;;;;;四象限
(if (and (> da1x 0)
(< da1y 0))
(setq a1 (+ (* 2 3.1415926) (atan (/ da1y da1x)))))
;;;;;;;;;判断直线二
;;;;;;;;;一象限
(if (and (> da2x 0)
(> da2y 0))
(setq a2 (atan (/ da2y da2x))))
;;;;;;;;;二象限
(if (and (< da2x 0)
(> da2y 0))
(setq a2 (+ 3.1415926 (atan (/ da2y da2x)))))
;;;;;;;;;三象限
(if (and (< da2x 0)
(< da2y 0))
(setq a2 (+ 3.1415926 (atan (/ da2y da2x)))))
;;;;;;;;;四象限
(if (and (> da2x 0)
(< da2y 0))
(setq a2 (+ (* 2 3.1415926) (atan (/ da2y da2x)))))
;;;;;;;;;;;;;;;;;;判断a1(直线一)、a2(直线二)的方位角(逆时针)、(顺时针)是否大于一个圆周(360度)
;;;;;;;;;;;;;;;判断a1(直线一)的方位角(逆时针)是否大于一个圆周(360度)
(if (> a1 (* 2 3.1415926))
(setq a1 (- a1 (* 2 3.1415926))))
;;;;;;;;;;;;;;;判断a1(直线一)的方位角(顺时针)是否大于一个圆周(360度)
(if (< a1 (* -2 3.1415926))
(setq a1 (+ a1 (* 2 3.1415926))))
;;;;;;;;;;;;;;;判断a2(直线二)的方位角(逆时针)是否大于一个圆周(360度)
(if (> a2 (* 2 3.1415926))
(setq a2 (- a2 (* 2 3.1415926))))
;;;;;;;;;;;;;;;判断a2(直线二)的方位角(顺时针)是否大于一个圆周(360度)
(if (< a2 (* -2 3.1415926))
(setq a2 (+ a2 (* 2 3.1415926))))
;;;;;;;;;;;求点
(setq u1 (sin a1))
(setq u2 (cos a1))
(setq u3 (/ u1 u2))
;;;;;;;;;;(直线2斜率
(setq w1 (sin a2))
(setq w2 (cos a2))
(setq w3 (/ w1 w2))
;;;;;;;;判断斜率是否等
(setq k1 (- w3 u3))
(if (= 0 k1)
(setq k1 (+ k1 0.000000000000001)))
;;;;;;;;;求交点
(setq jd1x (/ (+ (* -1 u3 a10x) (* w3 a20x) (* -1 a20y) a10y) k1));;;;;交点X坐标
(setq jd1y (+ a10y (* u3 jd1x) (* -1 u3 a10x)));;;;;;;;交点Y坐标
;;;;;;;;;求出1与交点方位角，交点与4方位角
(setq da10xjd1x (- jd1x a10x))
(setq da10yjd1y (- jd1y a10y))
(setq djd1xa21x (- a21x jd1x))
(setq djd1ya21y (- a21y jd1y))
;;;;;;;;;;;判断除数是否为零(方位角是否为：0、90、180、270、360度)
(if (= da10xjd1x 0) (setq da10xjd1x (+ da10xjd1x 0.000000000000001)))
(if (= da10yjd1y 0) (setq da10yjd1y (+ da10yjd1y 0.000000000000001)))
(if (= djd1xa21x 0) (setq djd1xa21x (+ djd1xa21x 0.000000000000001)))
(if (= djd1ya21y 0) (setq djd1ya21y (+ djd1ya21y 0.000000000000001)))
;;;;;;;;判断方位角象限(一、二、三、四)
;;;;;;;;;判断直线一
;;;;;;;;;一象限
(if (and (> da10xjd1x 0)
(> da10yjd1y 0))
(setq a1j (atan (/ da10yjd1y da10xjd1x))))
;;;;;;;;;二象限
(if (and (< da10xjd1x 0)
(> da10yjd1y 0))
(setq a1j (+ 3.1415926 (atan (/ da10yjd1y da10xjd1x)))))
;;;;;;;;;三象限
(if (and (< da10xjd1x 0)
(< da10yjd1y 0))
(setq a1j (+ 3.1415926 (atan (/ da10yjd1y da10xjd1x)))))
;;;;;;;;;四象限
(if (and (> da10xjd1x 0)
(< da10yjd1y 0))
(setq a1j (+ (* 2 3.1415926) (atan (/ da10yjd1y da10xjd1x)))))
;;;;;;;;;判断直线二
;;;;;;;;;一象限
(if (and (> djd1xa21x 0)
(> djd1ya21y 0))
(setq a2j (atan (/ djd1ya21y djd1xa21x))))
;;;;;;;;;二象限
(if (and (< djd1xa21x 0)
(> djd1ya21y 0))
(setq a2j (+ 3.1415926 (atan (/ djd1ya21y djd1xa21x)))))
;;;;;;;;;三象限
(if (and (< djd1xa21x 0)
(< djd1ya21y 0))
(setq a2j (+ 3.1415926 (atan (/ djd1ya21y djd1xa21x)))))
;;;;;;;;;四象限
(if (and (> djd1xa21x 0)
(< djd1ya21y 0))
(setq a2j (+ (* 2 3.1415926) (atan (/ djd1ya21y djd1xa21x)))))
;;;;;;;;;;;;;;;;;;判断a1(直线一)、a2(直线二)的方位角(逆时针)、(顺时针)是否大于一个圆周(360度)
;;;;;;;;;;;;;;;判断a1(直线一)的方位角(逆时针)是否大于一个圆周(360度)
(if (> a1j (* 2 3.1415926))
(setq a1j (- a1j (* 2 3.1415926))))
;;;;;;;;;;;;;;;判断a1(直线一)的方位角(顺时针)是否大于一个圆周(360度)
(if (< a1j (* -2 3.1415926))
(setq a1j (+ a1j (* 2 3.1415926))))
;;;;;;;;;;;;;;;判断a2(直线二)的方位角(逆时针)是否大于一个圆周(360度)
(if (> a2j (* 2 3.1415926))
(setq a2j (- a2j (* 2 3.1415926))))
;;;;;;;;;;;;;;;判断a2(直线二)的方位角(顺时针)是否大于一个圆周(360度)
(if (< a2j (* -2 3.1415926))
(setq a2j (+ a2j (* 2 3.1415926))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;求出(直线一)与(直线二)偏角
(setq a31 (abs (- a1j a2j)))
(if (= "3.14159" a31) (quit))
(setq a3 a31)
;;;;;;;;;;;;;;;判断偏角是否大于180度
(if (> a3 3.1415926)
(setq a3 (- (* 2 3.1415926) a3)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;半偏角、半圆角
(setq a4 (/ a3 2))
;;;;;;;;;;;;;输入半径
(setq r1 (getreal "\n圆角半径："))
;;;;;;;半径数值出错循环
(while (= nil r1)
(setq r1 (getreal "\n圆角半径：")))
;;;;;;;;求出切线长
(setq n1 (sin a4))
(setq n2 (cos a4))
(setq n3 (/ n1 n2))
(setq t1 (* n3 r1))
;;;;;;;;;求出外距长
(setq e1(- (/ r1 n2) r1))
;;;;;;;;;求出曲线长
(setq m1 (* a3 180))
(setq m2 (/ m1 3.1415926))
(setq m3 (/ m2 360))
(setq m4 (* 2 3.1415926 r1))
(setq l1 (* m3 m4))
;;;;;;;;;角度转换
;;;;;;;;弧度转换为度
(setq a5 (/ (* a3 180) 3.1415926))
;;;;;;;;度转换为度分秒
(setq a6 (fix a5));;;;;;;度
(setq a7 (fix (* (- a5 a6) 60)));;;;;;;;分
(setq a8 (fix (* (- (* (- a5 a6) 60) a7) 60)));;;;;;;;秒
(hjx);;;;;;;;调用画矩形函数(HJX)
(princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;画矩形
(defun hjx()
(command "osnap" "off")
(setq d0 (getpoint "\n标注基点："));;;;;;;;;;;标注基点
(while (= nil d0)
(setq d0 (getpoint "\n标注基点：")))
(setq d1 (list (+ (car d0) 23) (+ (cadr d0) 25)))
(command "rectang" d0 d1 )
(bzwz);;;;;;;;调用标注文字函数(BZWZ)
(princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;标注文字
(defun bzwz()
(setq f1 (list (+ (car d0) 1) (+ (cadr d0) 1)))
(setq f2 (list (car f1) (+ (cadr f1) 5)))
(setq f3 (list (car f2) (+ (cadr f2) 5)))
(setq f4 (list (car f3) (+ (cadr f3) 5)))
(setq f5 (list (car f4) (+ (cadr f4) 5)))
(command "text" f5 "2.5" "0" (strcat "a=" (rtos a6 2 0) "%%d" (rtos a7 2 0) "\U+2032" (rtos a8 2 0) "\U+2033"))
(command "text" f4 "2.5" "0" (strcat "R=" (rtos r1 2 3) "m"))
(command "text" f3 "2.5" "0" (strcat "T=" (rtos t1 2 3) "m"))
(command "text" f2 "2.5" "0" (strcat "L=" (rtos l1 2 3) "m"))
(command "text" f1 "2.5" "0" (strcat "E=" (rtos e1 2 3) "m"))
(reerr)
(princ)
(yj);;;;;;;;调用圆角函数(YJ)
(princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;圆角
(defun yj()
(setierr)
(command "fillet" "r" r1)
(command "fillet" )
(princ)
)
;**************************************************************
