明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1977|回复: 16

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

[复制链接]
发表于 2018-7-12 12:42 | 显示全部楼层 |阅读模式
本帖最后由 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))


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
"觉得好,就打赏"
还没有人打赏,支持一下
发表于 2018-7-14 08:22 | 显示全部楼层
本帖最后由 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)
)

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2018-8-8 19:11 | 显示全部楼层
本帖最后由 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)
)
 楼主| 发表于 2018-8-8 11:35 | 显示全部楼层
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)
)
发表于 2018-7-12 13:48 | 显示全部楼层
土方法,把lisp加载后,(repeat 10000 (c:命令)),循环执行10000次
发表于 2018-7-12 16:52 | 显示全部楼层
Linhay 发表于 2018-7-12 13:48
土方法,把lisp加载后,(repeat 10000 (c:命令)),循环执行10000次

你這個簡單 粗暴啊
发表于 2018-7-12 16:58 | 显示全部楼层
多按一下回车嘛
 楼主| 发表于 2018-7-12 22:09 | 显示全部楼层

可不可以帮忙改下
 楼主| 发表于 2018-7-12 22:10 | 显示全部楼层
张大锤 发表于 2018-7-12 16:52
你這個簡單 粗暴啊

牛逼啊 ,那比如执行了10次就想退出呢
 楼主| 发表于 2018-7-12 22:11 | 显示全部楼层
Linhay 发表于 2018-7-12 13:48
土方法,把lisp加载后,(repeat 10000 (c:命令)),循环执行10000次

能不能帮忙改下,我不是想执行10000次
发表于 2018-7-13 07:23 | 显示全部楼层
执行够了就按ecs退出
发表于 2018-7-13 08:43 | 显示全部楼层
;;(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 | 显示全部楼层
664571221 发表于 2018-7-12 22:10
牛逼啊 ,那比如执行了10次就想退出呢

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


(repeat 10 (c:命令)),循环执行10次
但是这个 不解决你实际问题
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 15:39 , Processed in 0.236732 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表