[討論]分享繪製投影矩形lisp
2 posters
AutoCAD顧問 :: 技術(發言等級:一般會員) :: :: 進階討論
第1頁(共1頁)
[討論]分享繪製投影矩形lisp
分享工作上實用的小程序
選取物件投影畫矩形
選取物件投影畫矩形
- 代碼:
;;; ****************************************************************
;;; *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)
)
- 附件
stephen-peng- 一般會員
- 文章總數 : 9
年齡 : 53
來自 : 板橋區
職業 : 工程師
愛好 : 電腦維修
個性 : 內向
使用年資 : 20年
使用版本 : 2014
經驗值 : 3218
威望值 : 30
注冊日期 : 2016-03-15
回復: [討論]分享繪製投影矩形lisp
感謝大大分享
測試看看
測試看看
poiuyy- 初級會員
- 文章總數 : 226
年齡 : 50
來自 : 台中
職業 : 小監
愛好 : 電影
個性 : 中庸
使用年資 : 5
使用版本 : 2010
積分 : 2
經驗值 : 4735
威望值 : 84
注冊日期 : 2014-06-24
AutoCAD顧問 :: 技術(發言等級:一般會員) :: :: 進階討論
第1頁(共1頁)
這個論壇的權限:
您 無法 在這個版面回復文章