[LISP程序]：lsp冲子绘制造

zhou1688

;;;自动合模
(defun c:upt (/ os pt pt1 pt2 sss ss n cen ptt)
  (setq os (getvar "osmode"))
  (princ "请选取模板外形...")
  (while (not (setq ss (ssget '((0 . "LWPOLYLINE")
                                (-4 . "<OR")
                                (70 . 1)
                                (70 . 129)
                                (-4 . "OR>")
                               )
                       )
              )
         )
  )
  (setq ptt (getpoint "\n请选取合模点: "))
  (setvar "osmode" 0)
  (command "ucs" "" "" )
  (setq n 0)
  (repeat (sslength ss)
    (setq pt  (acet-ent-geomextents (ssname ss n))
          pt1 (car pt)
          pt2 (cadr pt)
          cen (polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2))
    )

    (command "zoom" "w" pt1 pt2)
    (setq sss (ssget "c" pt1 pt2))

    (command "copy" sss "" CEN ptt)
    (setq n (1+ n))
  )
  (setvar "osmode" os)
  (command "zoom" "e" "")
  (PRINC)
)
defun trap (errmsg)
(command "undo" "e")
(command "u")
(princ)
(setvar "osmode" oldosm)
(setq *error* temperr)
(princ)
) ;_ 结束defun

(defun ac ()
(setq ddk (getdist "\n刀口直径："))
(setq ldk (getdist "\n刀口段长度(不包含圆孤段)：")) ；A冲最小直径段的长度。
(setq p9 (list (- (car p0) (/ ddk 2)) (- (cadr p0) l0)))
(setq p10 (list (+ (car p0) (/ ddk 2)) (cadr p9)))
(setq p7 (list (car p9) (+ (cadr p9) ldk)))
(setq p8 (list (car p10) (cadr p7)))
(setq p5 (list (car p3) (+ (cadr p7) (* ddk 1.5))))
(setq p6 (list (car p4) (cadr p5)))
(command "rectang" p1 p2)
(command "pline" p3 p5 p6 p4 "")
(command "line" p9 p7 "")
(command "arc" "" p5)
(command "line" p10 p8 "")
(command "arc" "" p6)
(command "line" p7 p8 "")
(command "line" p9 p10 "")
) ;_ 结束defun

(defun ydc ()
(initget 1 "T C")
(setq ans1 (strcase (getkword "\n工作部位形状 [尖头(T)/圆头(C)]：")))
(setq p5 (list (car p3) (- (cadr p3) (- l0 5))))
(setq p6 (list (+ (car p5) d) (cadr p5)))
(setq p7 (list (car p0) (- (cadr p0) l0 (* d 1.5))))
(if (= ans1 "T")
(progn
(command "rectang" p1 p2)
(command "line" p3 p5 "")
(command "arc" "" p7)
(command "line" p4 p6 "")
(command "arc" "" p7)
(setq p12 (list (car p7) (- (cadr p7) (/ d 2))))
) ;_ 结束progn
) ;_ 结束if
(if (= ans1 "C")
(progn
(command "rectang" p1 p2)
(command "pline" p3 p5 "a" p6 "l" p4 "")
(setq p12 (list (car p0) (- (cadr p0) l0 d)))
) ;_ 结束progn
) ;_ 结束if

) ;_ 结束defun

(defun tc ()
(setq p5 (list (car p3) (- (cadr p3) (- l0 5))))
(setq p6 (list (+ (car p5) d) (cadr p5)))
(command "rectang" p1 p2)
(command "line" p3 p5 p6 p4 "")
) ;_ 结束defun

(defun message ()
(setq p0 (getpoint "\n插入点："))
(setq d (getdist "\n冲子直径："))
(setq l0 (getdist "\n冲子总长："))
(if (> d 3)
(setq dt (+ d 3))
(setq dt (+ d 1.5))
) ;_ 结束if
(setq p1 (polar p0 pi (/ dt 2)))
(setq p2 (list (+ (car p1) dt) (- (cadr p1) 5)))
(setq p3 (list (+ (car p1) (/ (- dt d) 2)) (- (cadr p1) 5)))
(setq p4 (list (- (car p2) (/ (- dt d) 2)) (cadr p2)))
(setq p11 (list (car p0) (+ (cadr p0) (/ d 2))))
(setq p12 (list (car p0) (- (cadr p0) l0 (/ d 2))))
) ;_ 结束defun

(defun c:ct (/ ans ans1 p1 p2 p3 p4 p5 p6
p7 p8 p9 p10 p11 p12 ddk ldk oldosm
oldlayer temperr dt
)
(setvar "cmdecho" 0)
(setq oldosm (getvar "osmode"))
(setq oldlayer (getvar "clayer"))

(setq temperr *error*)
(setq *error* trap)
(command "undo" "be")

(setvar "clayer" "con")
(setvar "osmode" 0)
(initget 1 "A T D")
(setq ans (strcase (getkword "\n冲子形状 [(A)冲/(T)冲/引导冲(D)]：")))
(message)
(if (= ans "T")
(tc)
) ;_ 结束if
(if (= ans "A")
(ac)
) ;_ 结束if
(if (= ans "D")
(ydc)
) ;_ 结束if

(setvar "clayer" "cen")
(command "line" p11 p12 "")
(setvar "clayer" oldlayer)

(setq *error* temperr)
(command "undo" "e")
(command "undo" "be")

(setvar "osmode" oldosm)
(setvar "cmdecho" 1)
(princ)
) ;_ 结束defun

kuangren202

不错的程序，感谢楼主分享