AutoCAD顧問
還沒有註冊嗎...即日起免費註冊,所有最完整的AutoCAD討論、教學及資源都在論壇裡喔~

[討論]分享繪製投影矩形lisp

上一篇主題 下一篇主題 向下

[討論]分享繪製投影矩形lisp

發表 由 stephen-peng 于 2016-06-03, 04:45

分享工作上實用的小程序
選取物件投影畫矩形

代碼:

;;;     ****************************************************************
;;;     *By stephen-peng************************************************
;;;     *版權沒有,歡迎取用**********************************************
;;;     ****************************************************************
(defun c:pe_exe (/     ssblock1   en col   lay   os   tt dly
 dlx   dl    pt_list pt1   pt2   pt3   pt4 pt5
 pt6   pt7
 )
  (princ "by stephen_peng")
  (setvar "blipmode" 0)
  (princ "\n->選擇製作投影矩形物件 <退出>:")
  (setq ssblock1 (ssget)) ;選取物件
  (if (= ssblock1 nil) ;判斷空選集退出
    (*error*)
    (progn
      (setq col (cdr (assoc 62 (entget (ssname ssblock1 0)))))
      (if (= col nil)
 (setq col "bylayer")
      )
      (setq lay (cdr (assoc 8 (entget (ssname ssblock1 0)))))
    )
  ) ;END if
  (command "ucs" "")
  (setq os (getvar "osmode"))
  (setvar "orthomode" 1)
  (setvar "cmdecho" 0)
  (command "undo" "be")
  (setq pt_list '()
 pt1 'nil
 pt2 'nil
 pt3 'nil
  )
  (command "ucs" "w")
  (setq n -1)
  (repeat (sslength ssblock1)
    (setq en (ssname ssblock1 (setq n (1+ n))))
    (vla-getboundingbox (vlax-ename->vla-object en) 'pt1 'pt2)
    (setq pt_list (cons (vlax-safearray->list pt1) pt_list))
    (setq pt_list (cons (vlax-safearray->list pt2) pt_list))
  )
  (setq pt1 (apply 'mapcar (cons 'min pt_list))) ;計算圖形左下角點
  (setq pt2 (apply 'mapcar (cons 'max pt_list))) ;右上角點
  (initget (+ 2 4))
  (setq tt (getdist "\n->輸入投影厚度<20>:")) ;輸入投影厚度
  (if (= tt nil) ;判斷輸入預設值20
    (setq tt 20)
  ) ;END if
  (setq pt7 (getpoint pt1 "\n指定視圖放置點:")) ;指定投影方向
  (setq dly (- (car pt1) (car pt7)))
  (setq dlx (- (cadr pt1) (cadr pt7)))
  (setvar "osmode" 16823)
 ;畫上投影
  (if (and (= dly 0) (< dlx 0)) ;判斷投影方向
    (progn
      (setq dl (abs dlx))
      (setq pt3 (list (car pt1) (+ (cadr pt1) dl)))
      (setq pt4 (list (car pt2) (+ (cadr pt1) dl tt)))
      (command "rectangle" "c" "0" "0" pt3 pt4)
      (command "change" "l" "" "p" "la" lay "c" col "")
      (command "explode" "l")
    )
  ) ;END if
 ;畫下投影
  (if (and (= dly 0) (> dlx 0)) ;判斷投影方向
    (progn
      (setq pt3 (list (car pt1) (- (cadr pt1) dlx)))
      (setq pt4 (list (car pt2) (- (cadr pt1) dlx tt)))
      (command "rectangle" "c" "0" "0" pt3 pt4)
      (command "change" "l" "" "p" "la" lay "c" col "")
      (command "explode" "l")
    )
  ) ;END if
 ;畫左投影
  (if (and (= dlx 0) (> dly 0)) ;判斷投影方向
    (progn
      (setq dl (+ (abs dly) (- (cadr pt2) (cadr pt1))))
      (setq pt5 (list (- (car pt2) dl) (cadr pt2)))
      (setq pt6 (list (- (car pt2) tt dl) (cadr pt1)))
      (command "rectangle" "c" "0" "0" pt5 pt6)
      (command "move"
       "l"
       ""
       pt6
       (list (- (car pt7) tt) (cadr pt7))
      )
      (command "change" "l" "" "p" "la" lay "c" col "")
      (command "explode" "l")
    )
  ) ;END if
 ;畫右投影
  (if (and (= dlx 0) (< dly 0)) ;判斷投影方向
    (progn
      (setq dl (- (abs dly) (- (cadr pt2) (cadr pt1))))
      (setq pt5 (list (- (car pt2) dl) (cadr pt2)))
      (setq pt6 (list (- (car pt2) tt dl) (cadr pt1)))
      (command "rectangle" "c" "0" "0" pt5 pt6)
      (command "move" "l" "" pt6 pt7)
      (command "change" "l" "" "p" "la" lay "c" col "")
      (command "explode" "l")
    )
  ) ;END if
  (setvar "osmode" os)
  (command "undo" "e")
  (setvar "cmdecho" 1)
  (princ)
)
竊喜
附件
pe_exe.zip 您無權下載這里的附件。(2 Kb) 下載 35 次
avatar
stephen-peng
一般會員
一般會員

文章總數 : 9
年齡 : 46
來自 : 板橋區
職業 : 工程師
愛好 : 電腦維修
個性 : 內向
使用年資 : 20年
使用版本 : 2014
經驗值 : 716
威望值 : 24
注冊日期 : 2016-03-15
男 處女座 豬

回頂端 向下

回復: [討論]分享繪製投影矩形lisp

發表 由 poiuyy 于 2016-06-11, 06:45

感謝大大分享
測試看看
avatar
poiuyy
初級會員
初級會員

文章總數 : 171
年齡 : 43
來自 : 台中
職業 : 小監
愛好 : 電影
個性 : 中庸
使用年資 : 5
使用版本 : 2010
積分 : 1
經驗值 : 2000
威望值 : 78
注冊日期 : 2014-06-24
藍鵲656號
男 天秤座 虎

回頂端 向下

上一篇主題 下一篇主題 回頂端


 
這個論壇的權限:
無法 在這個版面回復文章