好程序不敢独享！
本帖最后由 lucas_3333 于 2015-5-15 20:07 编辑从第一版到第二版 都只支持第一点捕捉，因为grread的关系，第二点带捕捉有点困难！
这是第一版本
(defun c:cam4 (/ *ERROR* STRBRK FOO1 FOO2
ANG BLG C1 CEN CEN2 CODE DATA DELTA DIS
EN GR IANG LEN LST POLY RAD RAD1 RAD2 TAN)
;; by Lee McDonnell (Lee Mac)~19.12.2009
(vl-load-com)
(defun *error* (msg)
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ))
(defun StrBrk (str chrc / pos lst)
(while (setq pos (vl-string-position chrc str))
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ pos 2))))
(reverse (cons str lst)))
(if (setq cen (getpoint "\nPick Center of First Radius: "))
(progn
(setq poly (entmakex
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 2)
(cons 70 1)
(cons 10 cen)
(cons 10 (polar cen 0 1.))))
en (reverse
(vl-member-if
(function
(lambda (x)
(= 39 (car x))))
(reverse (entget poly)))))
(defun foo1 nil (setq str "")
(while
(progn
(setq gr (grread 't 15 0) code (car gr) data (cadr gr))
(cond ((and (= 5 code) (listp data))
(setq rad2 (distance cen2 data) delta (- rad rad2))
(if (< (abs delta) len)
(progn
(setq tan(sqrt (- (* len len) (* delta delta))) iAng (atan tan delta)
blg1 (/ (sin (* 0.5 (- pi iAng))) (cos (* 0.5 (- pi iAng))))
blg2 (/ (sin (* 0.5 iAng)) (cos (* 0.5 iAng))))
(entmod
(append en
(list
(cons 10 (polar cen(+ ang iAng) rad))
(cons 42 blg1)
(cons 10 (polar cen(- ang iAng) rad))
(cons 10 (polar cen2 (- ang iAng) rad2))
(cons 42 blg2)
(cons 10 (polar cen2 (+ ang iAng) rad2)))))) t))
((and (= 3 code) (listp data))
(setq rad2 (distance cen2 data) delta (- rad rad2))
(if (< (abs delta) len)
(progn
(setq tan(sqrt (- (* len len) (* delta delta))) iAng (atan tan delta)
blg1 (/ (sin (* 0.5 (- pi iAng))) (cos (* 0.5 (- pi iAng))))
blg2 (/ (sin (* 0.5 iAng)) (cos (* 0.5 iAng))))
(entmod
(append en
(list
(cons 10 (polar cen(+ ang iAng) rad))
(cons 42 blg1)
(cons 10 (polar cen(- ang iAng) rad))
(cons 10 (polar cen2 (- ang iAng) rad2))
(cons 42 blg2)
(cons 10 (polar cen2 (+ ang iAng) rad2))))) nil)))
((= 2 code)
(cond ((or (= data 46) (< 47 data 58))
(setq str (strcat str (princ (chr data)))))
((and (< 0 (strlen str)) (= 8 data))
(setq str (substr str 1 (1- (strlen str))))
(princ (vl-list->string '(8 32 8))))
((vl-position data '(32 13))
(cond ((zerop (strlen str)) t)
((and (setq tmp (distof str)) (not (zerop tmp)))
(setq data (polar cen2 0 tmp) rad2 (distance cen2 data)
delta (- rad rad2))
(if (< (abs delta) len)
(progn
(setq tan(sqrt (- (* len len) (* delta delta))) iAng (atan tan delta)
blg1 (/ (sin (* 0.5 (- pi iAng))) (cos (* 0.5 (- pi iAng))))
blg2 (/ (sin (* 0.5 iAng)) (cos (* 0.5 iAng))))
(entmod
(append en
(list
(cons 10 (polar cen(+ ang iAng) rad))
(cons 42 blg1)
(cons 10 (polar cen(- ang iAng) rad))
(cons 10 (polar cen2 (- ang iAng) rad2))
(cons 42 blg2)
(cons 10 (polar cen2 (+ ang iAng) rad2))))) nil)))
(t (setq str "")
(princ (strcat "\n** Invalid Input **" msg)))))
(t )))
(t )))))
(defun foo2 nil(setq str "")
(while
(progn
(setq gr (grread 't 15 0) code (car gr) data (cadr gr))
(cond ((and (= 5 code) (listp data))
(setq dis (distance cen data) ang (angle cen data))
(if (< rad dis)
(progn
(setq tan(sqrt (- (* dis dis) (* rad rad)))
iAng (atan tan rad)
blg(/ (sin (* 0.5 (- pi iAng)))
(cos (* 0.5 (- pi iAng)))))
(entmod
(append en
(setq lst
(list
(cons 10 data)
(cons 10 (polar cen (+ ang iAng) rad))
(cons 42 blg)
(cons 10 (polar cen (- ang iAng) rad))))))) t))
((and (= 3 code) (listp data))
(setq dis (distance cen data) ang (angle cen data))
(if (< rad dis)
(progn
(setq tan(sqrt (- (* dis dis) (* rad rad)))
iAng (atan tan rad)
blg(/ (sin (* 0.5 (- pi iAng)))
(cos (* 0.5 (- pi iAng)))))
(setq en
(append en
(list
(cons 10 data)
(cons 10 data)
(cons 10 (polar cen (+ ang iAng) rad))
(cons 42 blg)
(cons 10 (polar cen (- ang iAng) rad)))))
(setq en (reverse
(vl-member-if
(function
(lambda (x)
(= 39 (car x))))
(reverse
(entmod
(subst (cons 90 4) (assoc 90 en) en)))))
cen2 data len (distance cen cen2) ang (angle cen cen2))
(setq msg (princ "\nPick Second Radius: "))
(foo1))))
((= 2 code)
(cond ((or (vl-position data '(44 46)) (< 47 data 58))
(setq str (strcat str (princ (chr data)))))
((and (< 0 (strlen str)) (= 8 data))
(setq str (substr str 1 (1- (strlen str))))
(princ (vl-list->string '(8 32 8))))
((vl-position data '(32 13))
(cond ((zerop (strlen str)) t)
((apply (function and)
(setq tmp
(mapcar (function distof) (StrBrk str 44))))
(setq data tmp dis (distance cen data) ang (angle cen data))
(if (< rad dis)
(progn
(setq tan(sqrt (- (* dis dis) (* rad rad)))
iAng (atan tan rad)
blg(/ (sin (* 0.5 (- pi iAng)))
(cos (* 0.5 (- pi iAng)))))
(setq en
(append en
(list
(cons 10 data)
(cons 10 data)
(cons 10 (polar cen (+ ang iAng) rad))
(cons 42 blg)
(cons 10 (polar cen (- ang iAng) rad)))))
(setq en (reverse
(vl-member-if
(function
(lambda (x)
(= 39 (car x))))
(reverse
(entmod
(subst (cons 90 4) (assoc 90 en) en)))))
cen2 data len (distance cen cen2) ang (angle cen cen2))
(setq msg (princ "\nPick Second Radius: "))
(foo1))))
(t (setq str "")
(princ (strcat "\n** Invalid Input **" msg)))))
(t )))
(t )))))
(setq msg (princ "\nPick First Radius: ")) (setq str "")
(while
(progn
(setq gr (grread 't 15 0) code (car gr) data (cadr gr))
(cond ((and (= 5 code) (listp data))
(setq data (trans data 1 0) ang (angle cen data)
dis (distance cen data))
(entmod
(append en
(setq lst
(list
(cons 10 data)
(cons 42 1.)
(cons 10 (polar data (+ ang pi) (* 2. dis)))
(cons 42 1.))))))
((and (= 3 code) (listp data))
(setq data (trans data 1 0))
(setq en
(append en
(setq lst
(list
(cons 10 data)
(cons 42 1.)
(cons 10 (polar data (+ ang pi) (* 2. dis)))
(cons 42 1.)
(cons 10 data))))
en (reverse
(vl-member-if
(function
(lambda (x)
(= 39 (car x))))
(reverse
(entmod
(subst (cons 90 3) (assoc 90 en) en)))))
rad (distance cen data))
(princ (setq msg "\nPick Center of Second Radius: "))
(foo2))
((= code 2)
(cond ((or (= data 46) (< 47 data 58))
(setq str (strcat str (princ (chr data)))))
((and (< 0 (strlen str)) (= 8 data))
(setq str (substr str 1 (1- (strlen str))))
(princ (vl-list->string '(8 32 8))))
((vl-position data '(32 13))
(cond ((zerop (strlen str)) t)
((and (setq tmp (distof str))
(not (zerop tmp)))
(setq data (polar cen 0 tmp))
(setq en
(append en
(setq lst
(list
(cons 10 data)
(cons 42 1.)
(cons 10 (polar data (+ ang pi) (* 2. dis)))
(cons 42 1.)
(cons 10 data))))
en (reverse
(vl-member-if
(function
(lambda (x)
(= 39 (car x))))
(reverse
(entmod
(subst (cons 90 3) (assoc 90 en) en)))))
rad (distance cen data))
(setq msg (princ "\nPick Center of Second Radius: "))
(foo2))
(t (setq str "")
(princ (strcat "\n** Invalid Input **" msg)))))
(t )))
(t ))))))
(princ))
后来，我向leemac 提出，第二点捕捉就没有办法了吗？遗憾！
没过几天，leemac升级到了第三版，第一点与第二点都支持捕捉，好东西，不敢独享，特来与大家分享！
**** Hidden Message *****
山寨版本
强大的程序，目前想到可以用在链条、转动设备，齿轮机械。 很强大不过我用不到！ 好程序,不错 用不到，但是可以学习学习代码！支持源码！ 好强大的程序啊 太牛了...好厉害的样子啊..
切线都可以动态...
高手啊 我记得leemac好像是动态高手吧
下过他的程序
楼主有他的主页网盘什么的吗? ysq101 发表于 2014-8-26 12:13 static/image/common/back.gif
我记得leemac好像是动态高手吧
下过他的程序
楼主有他的主页网盘什么的吗?
http://lee-mac.com/index.html 的确够强大
虽然用不到，也顶一下 谢谢楼主无私分享。