[LISP程序]：grread模拟橡皮筋

luyu9635

这个程序是自己写的grread模拟橡皮筋，但没能达到预想效果，请高手改错，谢谢,测试请用(grread-pt (getpoint)),用数字5做正交开关，没成功

gysjy

无法下载。你把源码贴上来。

luyu9635

哈哈，自己改好了，请测验,代码如下:
;;luyu 9635 2009.08.20
;;用grread模拟橡皮筋
;;按数字5转换正交
(defun grread-pt (po / gr pa pd pt ang)
  (princ "\n正交转换请按5:")
  (setq        ennext nil z t)
  (if (= nil f8)(setq f8 0))
  (while z
    (initget 128)
    (setq gr (grread t 4 3))
    (setq pa (car gr) pd (cadr gr))
    (cond ((= 5 (car  gr))        ;;如果鼠标在移动     
           (cond ((= f8 0)
              (setq ang (atoi (angtos (angle po pd))))
              (if(> ang 315)(setq ang (- 360 ang)))
              (cond ((and (< ang 45) (> ang -45))
                   (setq pt (list (car pd) (cadr po) 0))
                  )
                  ((and (< ang 135) (> ang 45))
                   (setq pt (list (car po) (cadr pd) 0))
                  )
                  ((and (< ang 225) (> ang 135))
                   (setq pt (list (car pd) (cadr po) 0))
                  )
                  ((and (< ang 315) (> ang 225))
                   (setq pt (list (car po) (cadr pd) 0))
                  )
              )
             )
             ((= f8 1)(setq pt pd))
           )
           (entmakeline)
          )
          ((= 2 pa)
           (if (= 5 (read(chr pd)));设定数字5为正交开关
             (if (= f8 0);转换状态
               (progn
                 (setq f8 1 pt (cadr (grread 1)))
                 (entmakeline)
                )
                 (setq f8 0)
                 )
            )
         )
         ((= pa 3)(setq z nil));;如果左击了退出
         (t  (setq  z nil))   
        )
  )  
  (princ)
)
;;;
(defun entmakeline()
  (if ennext (entdel ennext));;删除上次画的线
  (entmake (list '(0 . "line") '(62 . 7) (cons 10 po) (cons 11 pt)));;划线
  (setq ennext (entlast));;提取刚划的线
  )

gysjy

挺有意思的。

luyu9635

最初由 gysjy 发布
[B]挺有意思的。 [/B]

谢谢gysjy关注，能把你写的那个"钢筋拉伸"源码发给我吗?
cjhjinhua@126.com

gysjy

可以。拉伸钢筋的程序曾经在该网站上发过，后来由于网站的原因，地址失效了。

luyu9635

最初由 gysjy 发布
[B]可以。拉伸钢筋的程序曾经在该网站上发过，后来由于网站的原因，地址失效了。 [/B]

那我先谢谢了，哈我又改了一下这个程序，更好用了，接受F3和F8的输入〈捕捉和正交>，请试用,文件名改成了getgrread,虽然有抄袭之隙，也是一分心意，个人感觉好用，希望斑竹加分鼓励一下

hnfsf

论坛下载不了，能否直接贴代码？

pipilu1984

现在晓东论坛是怎么啦
附件都下载不了！！！

bububa918

最初由 gysjy 发布
[B]可以。拉伸钢筋的程序曾经在该网站上发过，后来由于网站的原因，地址失效了。 [/B]

是这个吗？以前在网上下的

(defun c:bj(/ p pt dis p1 p2 s1 s2 )
  ;;拉伸钢筋程序, 用于探索者或PKPM的板钢筋编辑;;
  (setq oer *error* *error* myerr)
  (setvar "cmdecho" 0)
  (setq box (getvar "pickbox"))
  (setvar "osmode" 0)
  (setvar "orthomode" 1)
  (command "undo" "g")
  (setvar "pickbox" 20)
  (setq p (entsel "\n指定要拉伸的范围:"))
  (setvar "pickbox" box)
  (while p
    (setq pt (cadr p) dis (* 0.034 (getvar "viewsize"))
          p1 (polar pt 0.79 dis) p2 (polar pt 3.93 dis)
          s1 (ssget "c" p1 p2)
          s2 (ssget "p" '((-4 . "<OR")(8 . "REIN")(8 . "支座钢筋")(8 . "板底钢筋")(-4 . "OR>")))
    )
    (if s2 (command "stretch" "c" p1 p2 "r" s1 "a" s2 "" pt pause)
           (princ "\n复选框中没有选中钢筋。")
    )
    (command "undo" "end")
    (setvar "pickbox" 20)
    (setq p (entsel "\n指定要拉伸的范围:"))
    (setvar "pickbox" box)
  );while
  (setq *error* oer)
  (princ)
)
(defun c:hf() (setvar "pickbox" (if box box 5))(princ))
(defun c:gj(/ p1 p2 p3 p4 p5 s1 s2 sn pt1 pt2 os)
  ;;延伸钢筋程序, 用于探索者或PKPM的板钢筋编辑;;
  (setq oer *error* *error* myerr os (getvar "osmode"))
  (command "undo" "g")
  (setvar "cmdecho" 0)
  (setvar "osmode" 0)
  (setq p1 (cadr (entsel "\n点取界线:"))
        p1 (osnap p1 "nea") p2 (osnap p1 "end")
  )
  
  (while (setq s1 (entsel "\n点取要延伸的钢筋:"))
    (setq
         sn (car s1)
         s2 (ssget "p" '((-4 . "<OR")
                       (8 . "REIN")(8 . "支座钢筋")
                       (8 . "板底钢筋")(-4 . "OR>"))
            )
          p3 (cadr s1) p3 (osnap p3 "nea") p4 (osnap p3 "end")
          pt1 (polar p4 0.79 500) pt2 (polar p4 3.93 500)
          p5 (inters p1 p2 p3 p4 nil)         
    )
    (if p5
      (if (or (eq (to 8) "REIN")  
              (eq (to 8) "支座钢筋")
              (eq (to 8) "板底钢筋")
              (eq (to 8) "GANGJ")
          )
          (if (< (distance p4 p5) 80000)
             (command "stretch" "c" pt1 pt2 "r" "all" "a" sn "" p4 p5)
             (princ "\n\t ***  与界线平行不能延伸。 ***")
          )
          (princ "\n\t ***  您没有选中钢筋。  ***")
       )
       (princ "\n\t ***  与界线平行不能延伸。 ***")
     )     
  );while
  (setvar "osmode" os)
  (command "undo" "end")
  (setq *error* oer)
  (princ)
)
(defun c:mgj(/ p pt dis p1 p2 p3 s1 s2 )
  ;;钢筋镜像程序, 用于探索者或PKPM的板钢筋编辑;;
  ;(setq oer *error* *error* myerr)
  (setvar "cmdecho" 0)
  (setq box (getvar "pickbox") ap (getvar "APERTURE"))
  (setvar "osmode" 0)
  (setvar "orthomode" 1)
  (command "undo" "g")
  (setvar "pickbox" 10)
  (setvar "APERTURE" 10)
  (setq p (entsel "\n指定要镜像的钢筋:"))
  (setvar "pickbox" box)
  (while p
    (setq pt (cadr p) dis (* 0.017 (getvar "viewsize"))
          p1 (polar pt 0.79 dis) p2 (polar pt 3.93 dis)
          p3 (osnap pt "nea")
          s1 (ssget "c" p1 p2)
          s2 (ssget "p" '((-4 . "<OR")(8 . "REIN")(8 . "TEXT")(8 . "支座钢筋")(8 . "板底钢筋")(-4 . "OR>")))
    )
    (if (and p3 s2) (command "mirror" s2 "" p3 (osnap p3 "end") "y")
           (princ "\n\t ** 复选框中没有选中钢筋。**")
    )
    (command "undo" "end")
    (setvar "pickbox" 10)
    (setq p (entsel "\n指定要拉伸的范围:"))
    (setvar "pickbox" box)
  );while
  (setvar "APERTURE" ap)
  (setq *error* oer)
  (princ)
)
(defun to(n)
  (cdr (assoc n (entget sn)))
)
(defun myerr (s)
  (if (/= s "Function canccelled")
   (if (= (substr s 1 13) "null function")
       (princ "\n该程序不能运行.") (princ "\n程序中止")
   )
  )
  (setq *error* oer)
  (princ)
)

gysjy

最初由 bububa918 发布
[B]
是这个吗？以前在网上下的

(defun c:bj(/ p pt dis p1 p2 s1 s2 )
  ;;拉伸钢?.. [/B]

不错，就是这些。