求各位大神，把这个程序改成循环的

664571221 · 发表于 2018-7-12 12:42:43

本帖最后由 664571221 于 2018-7-13 09:06 编辑

===============================================
(defun Dk:PtRelateLine (Pt1 Pt2 Pt3 / Dis12 Dis13 Dis23)
(cond ((= (rtos (setq Dis12 (distance Pt1 Pt2)) 2 5) "0.00000") 1)
      ((= (rtos (setq Dis13 (distance Pt1 Pt3)) 2 5) "0.00000") 2)
      ((= (rtos (+ Dis12 Dis13) 2 5) (rtos (setq Dis23 (distance Pt2 Pt3)) 2 5)) 4)
      ((= (rtos (+ Dis13 Dis23) 2 5) (rtos Dis12 2 5)) 8)
      ((= (rtos (+ Dis12 Dis23) 2 5) (rtos Dis13 2 5)) 16)
      (t 32)))

(defun C:EXT (/ n s j dxf_a a10 a11 k data1 data2 dxf_b b10 b11 insect d1 d2 index)
  (setq n (sslength (setq s (ssget '((8 . "中心线")(0 . "ARC,LINE,*POLYLINE"))))))
  (setq j -1)
  (while (< (setq j (1+ j)) n)
(setq dxf_a (entget (ssname s j)))
(setq a10 (cdr (assoc 10 dxf_a)))
(setq a11 (cdr (assoc 11 dxf_a)))
(setq k -1  data1 (list) data2 (list))
(while (< (setq k (1+ k)) n)
   (setq dxf_b (entget (ssname s k)))
   (if (/= (cdr (assoc 5 dxf_a)) (cdr (assoc 5 dxf_b)))
      (progn
      (setq b10 (cdr (assoc 10 dxf_b)) b11 (cdr (assoc 11 dxf_b)))
      (if (null (inters a10 a11 b10 b11))
         (progn
            (if (setq insect (inters a10 a11 b10 b11 nil))
            (progn
               (if (/= 0 (logand 7 (Dk:PtRelateLine insect b10 b11)))
                  (progn
                  (cond ((> (setq d1 (distance insect a10))(setq d2 (distance insect a11)))
                           (setq data1 (append data1 (list (list d2 insect 11)))))
                        ((setq data2 (append data2 (list (list d1 insect 10))))))
                  ))
               )) ;end if (setq insect (inters a10 a11 b10 b11 nil))
            )) ;end if (null (inters a10 a11 b10 b11))
      )) ;end if (/= (cdr (assoc 5 dxf_a)) (cdr (assoc 5 dxf_b)))
   ) ;end while

(if (> (length data1) 0)
   (progn
      (setq data1 (vl-sort data1 '(lambda (X Y) (< (car X)(car Y)))))
      (setq index (last (car data1)))
      (entmod (setq dxf_a (subst (cons index (cadr (car data1)))(assoc index dxf_a) dxf_a)))
      )
   )

(if (> (length data2) 0)
   (progn
      (setq data2 (vl-sort data2 '(lambda (X Y) (< (car X)(car Y)))))
      (setq index (last (car data2)))
      (entmod (subst (cons index (cadr (car data2)))(assoc index dxf_a) dxf_a))
      )
   )
) ;end while
  (princ))

bluefcc1 · 发表于 2018-7-14 08:22:16

本帖最后由 bluefcc1 于 2018-7-14 08:28 编辑

可以循環執行(滑鼠右鍵>繼續,滑鼠左鍵>結束)
(defun Dk:PtRelateLine (Pt1 Pt2 Pt3 / Dis12 Dis13 Dis23)
(cond ((= (rtos (setq Dis12 (distance Pt1 Pt2)) 2 5) "0.00000") 1)
      ((= (rtos (setq Dis13 (distance Pt1 Pt3)) 2 5) "0.00000") 2)
      ((= (rtos (+ Dis12 Dis13) 2 5) (rtos (setq Dis23 (distance Pt2 Pt3)) 2 5)) 4)
      ((= (rtos (+ Dis13 Dis23) 2 5) (rtos Dis12 2 5)) 8)
      ((= (rtos (+ Dis12 Dis23) 2 5) (rtos Dis13 2 5)) 16)
      (t 32)))
(defun C:E (/ n s j dxf_a a10 a11 k data1 data2 dxf_b b10 b11 insect d1 d2 index)
  (setq n (sslength (setq s (ssget '((0 . "ARC,LINE,*POLYLINE")(8 . "中心線"))))))
  (setq j -1)
  (while (< (setq j (1+ j)) n)
(setq dxf_a (entget (ssname s j)))
(setq a10 (cdr (assoc 10 dxf_a)))
(setq a11 (cdr (assoc 11 dxf_a)))
(setq k -1  data1 (list) data2 (list))
(while (< (setq k (1+ k)) n)
   (setq dxf_b (entget (ssname s k)))
   (if (/= (cdr (assoc 5 dxf_a)) (cdr (assoc 5 dxf_b)))
      (progn
      (setq b10 (cdr (assoc 10 dxf_b)) b11 (cdr (assoc 11 dxf_b)))
      (if (null (inters a10 a11 b10 b11))
         (progn
            (if (setq insect (inters a10 a11 b10 b11 nil))
            (progn
               (if (/= 0 (logand 7 (Dk:PtRelateLine insect b10 b11)))
                  (progn
                  (cond ((> (setq d1 (distance insect a10))(setq d2 (distance insect a11)))
                           (setq data1 (append data1 (list (list d2 insect 11)))))
                        ((setq data2 (append data2 (list (list d1 insect 10))))))
                  ))
               )) ;end if (setq insect (inters a10 a11 b10 b11 nil))
            )) ;end if (null (inters a10 a11 b10 b11))
      )) ;end if (/= (cdr (assoc 5 dxf_a)) (cdr (assoc 5 dxf_b)))
   ) ;end while

(if (> (length data1) 0)
   (progn
      (setq data1 (vl-sort data1 '(lambda (X Y) (< (car X)(car Y)))))
      (setq index (last (car data1)))
      (entmod (setq dxf_a (subst (cons index (cadr (car data1)))(assoc index dxf_a) dxf_a)))
      )
   )

(if (> (length data2) 0)
   (progn
      (setq data2 (vl-sort data2 '(lambda (X Y) (< (car X)(car Y)))))
      (setq index (last (car data2)))
      (entmod (subst (cons index (cadr (car data2)))(assoc index dxf_a) dxf_a))
      )
   )
) ;end while
(princ "\n<結束>左鍵> / <繼續>右鍵> :")
(setq TEST t)
         (while TEST
      (setq TMP (grread t 7 1))
      (cond
               ((= (car TMP) 3)
                  (setq TEST NIL)
      )
               ((= (car TMP) 25)
                  (C:E)
                  (setq TEST NIL)
               )
               );end cond
         )
  (princ)
)

bluefcc1 · 发表于 2018-8-8 19:11:25

本帖最后由 bluefcc1 于 2018-8-8 22:23 编辑

664571221 发表于 2018-8-8 11:35
你好大神，能不能帮我看下这个程序如何改成循环
(defun c:FB( / msg osmode pp_start pp_end ss ss_2 ss ...

(defun c:FB( / msg osmode pp_start pp_end ss ss_2 ss_leng k short_pp_all ss_name ss_obj_name short_obj_pp short_pp_all pp_length i pp_1 pp_2  test tmp)
      (setq olderr *error* *error* error)
      (setq osmode (getvar "osmode"))
      (setvar "osmode" 0)
      (setvar "cmdecho" 0)
      (vl-cmdf "_.undo" "be")
      (setq pp_start (getpoint "\n指點欄選起點"))
      (setq pp_end (getpoint pp_start "\n指定欄選終點"))
      (setq ss (ssget "f" (list pp_start pp_end) '((0 . "line,lwpolyline"))))
      (setq ss_2 (ssget "f" (list pp_start pp_end) '((0 . "lwpolyline"))))
      (if (/= ss_2 nil)(vl-cmdf "qaflags" 1 "_.explode" ss_2 "" "qaflags" 0))
      (setq ss (ssget "f" (list pp_start pp_end) '((0 . "line"))))
      (setq ss_leng (sslength ss))
      (setq k -1)
      (setq short_pp_all '())
      (repeat ss_leng
            (setq k (1+ k))
            (setq ss_name (ssname ss k))
            (setq ss_obj_name (vlax-ename->vla-object ss_name))
            (setq short_obj_pp (list (vlax-curve-getclosestpointto ss_obj_name pp_start)))
            (setq short_pp_all (append short_obj_pp short_pp_all))
      )
      (setq pp_length (length short_pp_all))
      (setq i -1)
      (repeat (- pp_length 1)
            (setq i (1+ i))
            (setq pp_1 (nth i short_pp_all))
            (setq pp_2 (nth (+ i 1) short_pp_all))
            (vl-cmdf "dimaligned" pp_1 pp_2 (polar pp_1 (angle pp_1 pp_2) (/ (distance pp_1 pp_2) 2)))
      )
      (princ "\n<結束>左鍵> / <繼續>右鍵> :")
      (setq TEST t)
      (while TEST
            (setq TMP (grread t 7 1))
            (cond
               ((= (car TMP) 3)
                     (setq TEST NIL)
               )
               ((= (car TMP) 25)
                     (c:fb)
               )
            );end cond
      )
      (vl-cmdf "_.undo" "e")
      (setvar "osmode" osmode)
      (setvar "cmdecho" 1)
      (princ)
)
(defun error(msg)
      (setvar "osmode" osmode)
      (setvar "cmdecho" 1)
      (setq *error* olderr)
)

664571221 · 发表于 2018-8-8 11:35:17

bluefcc1 发表于 2018-7-14 08:22
可以循環執行(滑鼠右鍵>繼續,滑鼠左鍵>結束)
(defun DktRelateLine (Pt1 Pt2 Pt3 / Dis12 Dis13 Dis23)
...

你好大神，能不能帮我看下这个程序如何改成循环
(defun c:FB( / msg osmode pp_start pp_end ss ss_2 ss_leng k short_pp_all ss_name ss_obj_name short_obj_pp short_pp_all pp_length i pp_1 pp_2)
(setq olderr *error* *error* error)
(setq osmode (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(vl-cmdf "_.undo" "be")
(setq pp_start (getpoint "\n指点栏选起点"))
(setq pp_end (getpoint pp_start "\n指定栏选终点"))
(setq ss (ssget "f" (list pp_start pp_end) '((0 . "line,lwpolyline"))))
(setq ss_2 (ssget "f" (list pp_start pp_end) '((0 . "lwpolyline"))))
(if (/= ss_2 nil)(vl-cmdf "qaflags" 1 "_.explode" ss_2 "" "qaflags" 0))
(setq ss (ssget "f" (list pp_start pp_end) '((0 . "line"))))
(setq ss_leng (sslength ss))
(setq k -1)
(setq short_pp_all '())
(repeat ss_leng
(setq k (1+ k))
(setq ss_name (ssname ss k))
(setq ss_obj_name (vlax-ename->vla-object ss_name))
(setq short_obj_pp (list (vlax-curve-getclosestpointto ss_obj_name pp_start)))
(setq short_pp_all (append short_obj_pp short_pp_all))
)
(setq pp_length (length short_pp_all))
(setq i -1)
(repeat (- pp_length 1)
(setq i (1+ i))
(setq pp_1 (nth i short_pp_all))
(setq pp_2 (nth (+ i 1) short_pp_all))
(vl-cmdf "dimaligned" pp_1 pp_2 (polar pp_1 (angle pp_1 pp_2) (/ (distance pp_1 pp_2) 2)))
)
(vl-cmdf "_.undo" "e")
(setvar "osmode" osmode)
(setvar "cmdecho" 1)
(princ)

)

(defun error(msg)
(setvar "osmode" osmode)
(setvar "cmdecho" 1)
(setq *error* olderr)
)

Linhay · 发表于 2018-7-12 13:48:23

土方法，把lisp加载后，(repeat 10000 (c:命令)),循环执行10000次

张大锤 · 发表于 2018-7-12 16:52:06

Linhay 发表于 2018-7-12 13:48
土方法，把lisp加载后，(repeat 10000 (c:命令)),循环执行10000次

你這個簡單粗暴啊

evayleung · 发表于 2018-7-12 16:58:46

多按一下回车嘛

664571221 · 发表于 2018-7-12 22:09:41

evayleung 发表于 2018-7-12 16:58
多按一下回车嘛

可不可以帮忙改下

664571221 · 发表于 2018-7-12 22:10:24

张大锤发表于 2018-7-12 16:52
你這個簡單粗暴啊

牛逼啊，那比如执行了10次就想退出呢

664571221 · 发表于 2018-7-12 22:11:07

Linhay 发表于 2018-7-12 13:48
土方法，把lisp加载后，(repeat 10000 (c:命令)),循环执行10000次

能不能帮忙改下，我不是想执行10000次

Linhay · 发表于 2018-7-13 07:23:33

执行够了就按ecs退出

Andyhon · 发表于 2018-7-13 08:43:57

;;(setq n (sslength (setq s (ssget '((8 . "中心线")(0 . "ARC,LINE,*POLYLINE"))))))
(while (setq s (ssget '((8 . "中心线")(0 . "ARC,LINE,*POLYLINE")))))
(setq n (sslength s))
(setq j -1)
(while (< (setq j (1+ j)) n)
   (setq dxf_a (entget (ssname s j)))
   ...
) ;_ end while
  ) ;_ end while

张大锤 · 发表于 2018-7-13 08:48:42

664571221 发表于 2018-7-12 22:10
牛逼啊，那比如执行了10次就想退出呢

(repeat 10000 (c:命令)),循环执行10000次

(repeat 10 (c:命令)),循环执行10次
但是这个不解决你实际问题

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

[提问] 求各位大神，把这个程序改成循环的

本帖子中包含更多资源

本帖子中包含更多资源

浏览过的版块