【文件属性】：
文件名称：CAD lisp程序
文件大小：611KB
文件格式：RAR
更新时间：2021-06-24 16:38:15
CAD
超级详细
(defun *error*(st)
(if (and (/= st "Function cancelled")
(/= st "quit / exit abort")
)
(princ (strcat "错误: " st))
)
(setq *error* old_err)
(princ)
)
(defun sort (l / lt ltem vmax vmin l1 l2 l3
lt0 ltem0 ltem1 l30 vmax0 vmin0 l10 l20)
(setq ltem (mapcar 'car l) ;ltem : 取出l的第一项形成的表
vmin (1- (apply 'min ltem)) ;vmin : 是一个比ltem中最小的数还小的数
)
(while (< vmin (setq vmax (apply 'max ltem))) ;从ltem中取出最大值
(setq l1 l l3 nil ltem (subst vmin vmax ltem)) ;去掉最大值
(while (setq l2 (assoc vmax l1)) ;取出最大值所对应的项
(setq l1 (cdr (member l2 l1))) ;处理相同的值
(setq l3 (cons l2 l3))
)
(progn
(setq ltem0 (mapcar 'cadr l3)
ltem1 (mapcar 'car l3)
l30 (mapcar 'cdr l3)
vmin0 (1- (apply 'min ltem0))
)
(while (< vmin0 (setq vmax0 (apply 'max ltem0)))
(setq l10 l30 ltem0 (subst vmin0 vmax0 ltem0))
(while (setq l20 (assoc vmax0 l10))
(setq l10 (cdr (member l20 l10)))
(setq lt0 (cons l20 lt0))
)
)
(setq l3 (mapcar 'cons ltem1 lt0))
; (setq l3 (reverse l3))
)
(setq lt (append l3 lt))
)
)
(defun dxf (code en)
(cdr (assoc code en))
)
(defun pross (bp sp / tem ss n el ip lpt lpt0 en pt pt0 en pt1 ang ang1)
; (if (> (car bp) (car sp))
; (setq tem bp bp sp sp tem)
; )
(setq ss nil)
(if (setq ss (ssget "c" bp sp))
(progn
(setq n 0)
(repeat (sslength ss)
(setq el (entget (ssname ss n)))
(if (and (= (dxf 0 el) "LINE")
(or (= (dxf 8 el) "WALL") (= (dxf 8 el) "AXIS"))
(setq ip (inters bp sp (dxf 10 el) (dxf 11 el)))
) ; ip 交点
(progn
(setq lpt (cons ip lpt))
)
)
(setq n (1+ n))
) ; repeat 找出所有的交点并形成表lpt
(if (/= nil lpt) (setq lpt (sort lpt)))
)
)
(setq pt0 '(0 0 0)) ;以下9行去掉相同的数据
(foreach pt lpt
(if (< (distance pt0 pt) 0.000001)
(princ "\n警告:墙线有重线")
(setq lpt0 (cons pt lpt0))
)
(setq pt0 pt)
)
(setq lpt (sort lpt0))
(setq el (entget (setq en (car (entsel "\n点一下第二排尺寸线: ")))))
(setq ang (angle bp sp))
; (if (= ang (* pi 2)) (setq ang 0))(princ ang)
;(if (>= ang pi) (setq ang (- ang pi)))
(setq di (distance bp (inters bp (polar bp (+ ang (* pi 0.5)) 100) (dxf 10 el) (dxf 11 el) nil)))
(setq di (- di 700))
(setq pt1 (polar (car lpt) (+ ang (* pi 0.5)) di))
(command "line" (polar pt1 (+ ang (* pi 1.5)) 700) (polar pt1 (+ ang (* pi 0.5)) 300) "")
(command "pline" (polar pt1 (+ ang (* pi 1.25)) 70.7) "w" "50" "50" (polar pt1 (+ ang (* pi 0.25)) 70.7) "")
(foreach pt (cdr lpt)
(setq pt (polar pt (+ ang (* pi 0.5)) di))
(command "line" (polar pt (+ ang (* pi 1.5)) 700) (polar pt (+ ang (* pi 0.5)) 300) "")
(command "pline" (polar pt (+ ang (* pi 1.25)) 70.7) "w" "50" "50" (polar pt (+ ang (* pi 0.25)) 70.7) "")
(command "line" pt1 pt "")
(setq txt (rtos (setq dis (distance pt1 pt)) 2 0))
(setq len (sqrt (+ (* 115 115) (* (/ dis 2.0) (/ dis 2.0)))))
(setq ang1 (atan (/ 115 (/ dis 2.0))))
(command "text" "c" (polar pt1 (+ ang ang1) len) "300" (* (/ ang pi) 180) txt)
(setq pt1 pt)
)
)
;;;==============================================
;;; main programm
;;;==============================================
(defun C:3dimzs(/ bp sp)
(setq old_err *error*)
(setvar "CMDECHO" 0)
(setvar "BLIPMODE" 0)
(command "layer" "m" "dim" "c" "g" "dim" "")
(setq bp (getpoint "\n第一点(一般为外墙线上两点): "))
(if (= nil bp) (quit))
(setq sp (getpoint bp "\n第二点: "))
(if (= nil sp) (quit))
(pross bp sp)
(princ)
)