LISP动态拖动生成圆代码

marting · 发表于 2017-5-5 22:37:30

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 newer 于 2017-5-6 08:10 编辑

LISP拖动生成圆.gif

(defun c:test2 ()
;; CAB version 1.2
;; Calling routine to pass a tangent point (p1) & offset distance (od)
;; Routine will allow user to stretch outer circle using diameter
;; Note if offset distance is a negative number the offset circle
;; will be on the outside
;;
;; Returns the 2nd pick point
(setq rMin 0.001) ; Minimum Radius allowed
(setq c1
(entmakex (list (cons 0 "CIRCLE")
(cons 6 "BYLAYER")
(cons 8 "0")
(cons 10 p1)
(cons 39 0.0)
(cons 40 rMin) ; radius
(cons 62 256)
(cons 210 (list 0.0 0.0 1.0))
)
)
)
(setq c2
(entmakex (list (cons 0 "CIRCLE")
(cons 6 "BYLAYER")
(cons 8 "0")
(cons 10 p1)
(cons 39 0.0)
(cons 40 rMin) ; radius
(cons 62 256)
(cons 210 (list 0.0 0.0 1.0))
)
)
)
(setq el1 (entget c1)
el2 (entget c2)
)
;; p1 is a tangent point
;; p2 is a tangent point with center at mid point of p1 p2
(while (and (setq gr (grread 5)) (= (car gr) 5))
(cond
((> (setq d1 (distance p1 (setq p2 (cadr gr)))) rMin)
(setq el1 (subst (cons 40 (setq r1 (/ d1 2.))) (assoc 40 el1) el1))
(setq el1 (entmod (subst (cons 10 (polar p1 (angle p1 p2) r1)) (assoc 10 el1) el1)))
(entupd (cdr (assoc -1 el1)))
(cond
((< rMin (- d1 (* od 2.)))
(setq el2 (subst (cons 40 (/ (- d1 (* od 2.)) 2.)) (assoc 40 el2) el2))
(setq el2 (entmod (subst (assoc 10 el1) (assoc 10 el2) el2)))
(entupd (cdr (assoc -1 el2)))
)
(t ; minimize the inner circle
(setq el2 (subst (cons 40 rMin) (assoc 40 el2) el2))
(setq el2 (entmod (subst (assoc 10 el1) (assoc 10 el2) el2)))
(entupd (cdr (assoc -1 el2)))
)
)
)
(t ; minimize the outer circle
(setq el1 (subst (cons 40 rMin) (assoc 40 el1) el1))
(setq el1 (entmod (subst (cons 10 (polar p1 (angle p1 p2) (/ rMin 2.))) (assoc 10 el1) el1)))
(entupd (cdr (assoc -1 el1)))
)
)
)
;(entdel c1) ; to remove the circle
;(entdel c2) ; to remove the circle
p2
)
(setq pc (getpoint "\nPick center point."))
(princ "\n Select new radius ")
(setq rad (ghostcircle pc 850.0))
(princ rad)
(princ)
)

(defun c:test2 () 
 
  ;;  CAB version 1.2 
  ;;  Calling routine to pass a tangent point (p1) & offset distance (od) 
  ;;  Routine will allow user to stretch outer circle using diameter 
  ;;  Note if offset distance is a negative number the offset circle 
  ;;  will be on the outside 
  ;; 
  ;;  Returns the 2nd pick point 
    
    (setq rMin 0.001) ; Minimum Radius allowed 
    (setq c1 
           (entmakex (list (cons 0 "CIRCLE") 
                           (cons 6 "BYLAYER") 
                           (cons 8 "0") 
                           (cons 10 p1) 
                           (cons 39 0.0) 
                           (cons 40 rMin) ; radius 
                           (cons 62 256) 
                           (cons 210 (list 0.0 0.0 1.0)) 
                     ) 
           ) 
    ) 
    (setq c2 
           (entmakex (list (cons 0 "CIRCLE") 
                           (cons 6 "BYLAYER") 
                           (cons 8 "0") 
                           (cons 10 p1) 
                           (cons 39 0.0) 
                           (cons 40 rMin) ; radius 
                           (cons 62 256) 
                           (cons 210 (list 0.0 0.0 1.0)) 
                     ) 
           ) 
    ) 
    (setq el1 (entget c1) 
          el2 (entget c2) 
    ) 
    ;;  p1 is a tangent point 
    ;;  p2 is a tangent point with center at mid point of p1 p2 
    (while (and (setq gr (grread 5)) (= (car gr) 5)) 
      (cond 
        ((> (setq d1 (distance p1 (setq p2 (cadr gr)))) rMin) 
         (setq el1 (subst (cons 40 (setq r1 (/ d1 2.))) (assoc 40 el1) el1)) 
         (setq el1 (entmod (subst (cons 10 (polar p1 (angle p1 p2) r1)) (assoc 10 el1) el1))) 
         (entupd (cdr (assoc -1 el1))) 
         (cond 
           ((< rMin (- d1 (* od 2.))) 
            (setq el2 (subst (cons 40 (/ (- d1 (* od 2.)) 2.)) (assoc 40 el2) el2)) 
            (setq el2 (entmod (subst (assoc 10 el1) (assoc 10 el2) el2))) 
            (entupd (cdr (assoc -1 el2))) 
           ) 
           (t ; minimize the inner circle 
            (setq el2 (subst (cons 40 rMin) (assoc 40 el2) el2)) 
            (setq el2 (entmod (subst (assoc 10 el1) (assoc 10 el2) el2))) 
            (entupd (cdr (assoc -1 el2))) 
           ) 
         ) 
        ) 
        (t ; minimize the outer circle 
         (setq el1 (subst (cons 40 rMin) (assoc 40 el1) el1)) 
         (setq el1 (entmod (subst (cons 10 (polar p1 (angle p1 p2) (/ rMin 2.))) (assoc 10 el1) el1))) 
         (entupd (cdr (assoc -1 el1))) 
        ) 
      ) 
    ) 
    ;(entdel c1) ; to remove the circle 
    ;(entdel c2) ; to remove the circle 
    p2 
  ) 
 
 
  (setq pc (getpoint "\nPick center point.")) 
  (princ "\n Select new radius  ") 
  (setq rad (ghostcircle pc 850.0)) 
  (princ rad) 
  (princ) 
)

ghostCircle函数：

游客，如果您要查看本帖隐藏内容请回复

kqqt6236 · 发表于 2017-5-6 00:02:34

沙发，谢谢分享！

freefor5127 · 发表于 2017-5-6 00:17:46

谢谢楼主分享

Michael527 · 发表于 2017-5-6 06:47:50

可以学习动态拖动

Michael527 · 发表于 2017-5-6 06:52:40

代码不全吧？

HLCAD · 发表于 2017-5-6 07:50:24

向大师学习程序！

434939575 · 发表于 2017-5-6 08:24:46

谢谢分享！

sh_h · 发表于 2017-5-6 09:38:26

好程序，感谢楼主分享！
一看动态就想到grread函数，一想到grread函数就晕

winerfjy · 发表于 2017-5-6 09:53:06

动态好视觉化好

lrd1861 · 发表于 2017-5-6 10:17:48

学习一下

bonny123 · 发表于 2017-5-6 10:29:55

赞一个

ynhh · 发表于 2017-5-6 12:03:13

谢谢分享！
谢谢分享！

范建威 · 发表于 2017-5-24 13:58:25

向楼主学习

yufeng37 · 发表于 2017-6-6 14:33:34

向楼主学习，能做个动态云线的效果吗？类似与cad2018的云线效果。

819534890 · 发表于 2017-6-6 15:08:34

回复学习学习

账号		自动登录	找回密码
密码			立即注册

[每日一码] LISP动态拖动生成圆代码

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分