2007年7月13日 星期五

LISP 圖塊中心點連線

 
(defun c:TSK001 ()
(prompt "\n **<日期:2007-07-14.TSK001>**")
(prompt "\n **<用途:圖塊中心點連線>**")
(command "undo" "be")
;;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(PRINT "選取連線圖塊...")
(SETQ S1 (SSGET (LIST (CONS 2 "12")) )) ;;圖塊名稱請自行命名設定
(SETQ I 0)
(setq PT_S1 nil)
(REPEAT (SSLENGTH S1)
(SETQ EN (SSNAME S1 I))
(SETQ VLA_EN (vlax-ename->vla-object EN))
(SETQ PT_S1 (append PT_S1 (LIST (vlax-get VLA_EN 'insertionpoint) )))
(SETQ I (1+ I))
)
;;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(PRINT "選取連線基準圖塊...")
(SETQ S2 (SSGET (LIST (CONS 2 "12")) )) ;;圖塊名稱請自行命名設定
(SETQ I 0)
(setq PT_S2 nil)
(REPEAT (SSLENGTH S2)
(SETQ EN (SSNAME S2 I))
(SETQ VLA_EN (vlax-ename->vla-object EN))
(SETQ PT_S2 (append PT_S2 (LIST (vlax-get VLA_EN 'insertionpoint) )))
(SETQ I (1+ I))
)
 
(princ "\n 提示排序方式: E配A , C配B ...")
(SETQ PT_S1 (SORT_TYPE8_PT_LIST PT_S1)) ;E配A
(SETQ PT_S2 (SORT_TYPE8_PT_LIST PT_S2))
 
(SETQ E 0)
(REPEAT (1- (length PT_S2))
(SETQ PT_S2-X (NTH E PT_S2)
      PT_S2-Y (NTH (1+ E) PT_S2)
      ) ;_ 結束SETQ
(COMMAND "_LINE" PT_S2-X PT_S2-Y "")
(SETQ E (1+ E))
)
 
(SETQ I 0)
(REPEAT (LENGTH PT_S2)
(SETQ PT_XT (NTH I PT_S2))
(SETQ PT_X PT_XT)
 
(IF (EQUAL PT_XT (LAST PT_S2))
(SETQ PT_XL (LAST PT_S2))
(SETQ PT_XL (NTH (1+ I) PT_S2))
)
 
(SETQ E 0)
(SETQ Q 0) ;while關鍵
(WHILE Q
(SETQ PT_Y (CAR PT_S1))
(COND
  ((= PT_S1 NIL) ;;判斷串列是否為空
   (SETQ Q NIL)
  ) 
  ((EQUAL PT_XT PT_Y) ;;判斷座標是否相同
   (SETQ Q 0)
   (SETQ PT_S1 (cdr PT_S1))
   )
 
  ((EQUAL PT_XL PT_Y)
   (SETQ PT_S1 (cdr PT_S1))
   (SETQ Q NIL)
   )
(T
(COMMAND "_LINE" PT_X PT_Y "")
(SETQ PT_X PT_Y)
(SETQ Q 0)
(SETQ PT_S1 (cdr PT_S1))
)
)

(SETQ I (1+ I))
)
;;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(command "undo" "e")
(prin1))
 
;;階層排序
(defun sort-x-min-li (lst)
(vl-sort lst '(lambda (x y) (< (car x)(car y) ) ))
) ;X左->右
(defun sort-x-max-li (lst)
(vl-sort lst '(lambda (x y) (> (car x)(car y) ) ))
) ;X右->左
(defun sort-y-min-li (lst)
(vl-sort lst '(lambda (x y) (< (cadr x)(cadr y) ) ))
) ;Y下->上
(defun sort-y-max-li (lst)
(vl-sort lst '(lambda (x y) (> (cadr x)(cadr y) ) ))
) ;Y上->下
 
;;處理排序程式
(DEFUN SORT_TYPE8_PT_LIST ( lst / )
(princ "\n 排序方式:")
(princ "\n <Y方向>")
(princ "\n (A)左->右&上->下_(B)左->右&下->上_(C)右->左&上->下_(D)右->左&下->上")
(princ "\n <X方向>")
(princ "\n (E)上->下&左->右_(F)上->下&右->左_(G)下->上&左->右_(H)下->上&右->左")
(princ ".....<<")(princ "預設為A") (princ ">>:")
(initget "a b c d e f g h")
(setq sf1 (getkword))
(if (= sf1 nil)(setq sf1 A))
 
(cond
((= sf1 "a")(progn
(setq lstnew (sort-y-max-li lst))     
(setq lstnew2 (sort-x-min-li lstnew))
)) ;;_(A)左->右&上->下
 
((= sf1 "b")(progn
(setq lstnew (sort-y-min-li lst))     
(setq lstnew2 (sort-x-min-li lstnew))
)) ;;_(B)左->右&下->上
 
((= sf1 "c")(progn
(setq lstnew (sort-y-max-li lst))     
(setq lstnew2 (sort-x-max-li lstnew))
)) ;;_(C)右->左&上->下
 
((= sf1 "d")(progn
(setq lstnew (sort-y-min-li lst))     
(setq lstnew2 (sort-x-max-li lstnew))
)) ;;_(D)右->左&下->上
 
((= sf1 "e")(progn
(setq lstnew (sort-x-min-li lst))     
(setq lstnew2 (sort-y-max-li lstnew))
)) ;;_(E)上->下&左->右
 
((= sf1 "f")(progn
(setq lstnew (sort-x-max-li lst))     
(setq lstnew2 (sort-y-max-li lstnew))
)) ;;_(F)上->下&右->左
 
((= sf1 "g")(progn
(setq lstnew (sort-x-min-li lst))     
(setq lstnew2 (sort-y-min-li lstnew))
)) ;;_(G)下->上&左->右
 
((= sf1 "h")(progn
(setq lstnew (sort-x-max-li lst))     
(setq lstnew2 (sort-y-min-li lstnew))
)) ;;_(H)下->上&右->左
)
lstnew2
)
(prompt "\n **<問題:沒有解決圖塊框線切割問題...>**")
(prompt "\n **<命令:TSK001>**")