Chuyển đến nội dung
Diễn đàn CADViet

Các bài được khuyến nghị

Hi i find this code in this site https://www.cadviet.com/forum/topic/13203-viết-lisp-theo-yêu-cầu-phần-2/?page=68. The project started by phamngoctukts . Is any one finish this code? Can any one help?

Thanks

 

 

(DEFUN stretchblock()
(batdau)  
 (princ "chon doi tuong: ")
 (setq ss0 (ssget))
 (initget 1)
 (setq hs (getreal "Cho biet he so STRETCH: "))
 (setq P01 (getpoint "\nChon diem chen: "))
(delblock)
 (command "-Block" "vkc_temp1" "0,0" ss0 "")
 (command "-insert" "vkc_temp1" "0,0" "" "" "")
 (setq sstt1 (entlast))
 (setq sstt (ssget "l"))
(blockrectang)
 (setq re1 (entlast))
 (setq tt (entget re1)) 
 (setq tt (vl-remove-if '(lambda (x) (/= 10 (car x))) tt)) 
 (setq dinh1 (cdr (nth 0 tt)))
 (setq dinh2 (cdr (nth 1 tt)))
 (command "_.erase" "l" "")
 (command "_.copy" sstt1 "" "0,0" "0,0")
 (command "_.explode" "l")
 (setq ss00 (ssget "p"))
 (Command "_.Explode" sstt1)
 (command "-Block" "vkc_temp1" "y" dinh1 ss00 "")
 (command "line" dinh2 dinh1 "")
 (setq re (ssget "l"))
 (command "_.move" re "" dinh1 p01)
 (command "_.rotate" re "" p01 "45")
 (command "-insert" "vkc_temp1" "r" "45" p01 "" "")
 (setq blgoc (entlast))
 (Command "Explode" blgoc)
 (setq bl (ssget "p")) 
 (command "-Block" "vkc_temp2" P01 re "")
 (command "-Block" "vkc_temp3" P01 bl "")
 (Command "-Insert" "vkc_temp3" P01 "" hs "")  
 (setq dt1 (entlast))
 (Command "-Insert" "vkc_temp2" P01 "" hs "")  
 (Command "_.Explode" "l" "")
 (setq dt2 (entlast))
 (setq tt1 (entget dt2))
 (setq tt1 (vl-remove-if '(lambda (x) (/= 10 (car x))) tt1))
 (setq dinh11 (cdr (nth 0 tt1)))
 (command "_.align" dt1 "" p01 dinh1 dinh11 dinh2 "" "y")
 (command "_.erase" dt2 "")
 (command "_.move" dt1 "" dinh1 p01)
 (Command "_.Explode" "l")
(ketthuc)
 (princ)
)
;**************************************************************
(defun c:stb ()
(stretchblock)
)

(defun batdau ()
 (command "undo" "be")
 (setvar "cmdecho" 0)
 (while (/= (logand (getvar "cmdactive") 31) 0)(command pause))
)
;**************************************************************
(defun ketthuc ()
 (command "undo" "e")
 (setvar "cmdecho" 1)
)
;**************************************************************
(defun delblock ()
(Command "-Purge" "B" "vkc_temp1" "Y" "Y")
(Command "-Purge" "B" "vkc_temp2" "Y" "Y")
(Command "-Purge" "B" "vkc_temp3" "Y" "Y")
)
;**************************************************************       
(defun blockrectang ()
(while (setq e (ssname sstt 0))
(setq sstt (ssdel e sstt)
tmp (vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p3)
p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3) 
p1 (list (car p1) (cadr p1))
p3 (list (car p3) (cadr p3))
p2 (list (car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
tmp (list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity") 
(cons 100 "AcDbPolyline") 
(cons 90 4)
(cons 70 1)
(cons 10 p1)
(cons 10 p2)
(cons 10 p3)
(cons 10 p4)
)
)
(entmake tmp)
) 
)

 

stb.jpg

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Hi bro, try this (in the same link) . Ken you sờ pik Vietnamese ?

;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/13203-vi%E1%BA%BFt-lisp-theo-y%C3%AAu-c%E1%BA%A7u-ph%E1%BA%A7n-2/?page=68
(defun nhapsolieu ()
(setq goc1 (getangle p01 "chon diem thu 2 theo huong bac: "))
(setq goc (/ (* goc1 180) pi))
(setq xulygoc (- 45 (/ goc 2)))
(setq gocra (/ (* pi xulygoc) 180))
(setq sina (sin gocra))
(setq cosa (sqrt (- 1 (expt sina 2))))
(setq tang (/ sina cosa))
(setq a (distance dinh2 dinh3))
(setq duongcheo (* a (sqrt 2)))
(setq b (/ duongcheo (* 2 tang)))
(setq anso (- b (/ duongcheo 2)))
(setq x (* anso 2))
(setq hs (+ (/ x duongcheo) 1))
)

(DEFUN stretchblock()
(batdau)  
 (princ "chon doi tuong: ")
 (setq ss0 (ssget))
 (initget 1)
 (setq P01 (getpoint "\nChon diem chen: "))
(delblock)
 (command "-Block" "vkc_temp1" "0,0" ss0 "")
 (command "-insert" "vkc_temp1" "0,0" "" "" "")
 (setq sstt1 (entlast))
 (setq sstt (ssget "l"))
(blockrectang)
 (setq re1 (entlast))
 (setq tt (entget re1)) 
 (setq tt (vl-remove-if '(lambda (x) (/= 10 (car x))) tt)) 
 (setq dinh1 (cdr (nth 0 tt)))
 (setq dinh2 (cdr (nth 1 tt)))
 (setq dinh3 (cdr (nth 2 tt)))
 (command "_.erase" "l" "")
(nhapsolieu)
 (command "_.copy" sstt1 "" "0,0" "0,0")
 (command "_.explode" "l")
 (setq ss00 (ssget "p"))
 (Command "_.Explode" sstt1)
 (command "-Block" "vkc_temp1" "y" dinh1 ss00 "")
 (command "line" dinh2 dinh1 "")
 (setq re (ssget "l"))
 (command "_.move" re "" dinh1 p01)
 (command "_.rotate" re "" p01 "45")
 (command "-insert" "vkc_temp1" "r" "45" p01 "" "")
 (setq blgoc (entlast))
 (Command "Explode" blgoc)
 (setq bl (ssget "p")) 
 (command "-Block" "vkc_temp2" P01 re "")
 (command "-Block" "vkc_temp3" P01 bl "")
 (Command "-Insert" "vkc_temp3" P01 "" hs "")  
 (setq dt1 (entlast))
 (Command "-Insert" "vkc_temp2" P01 "" hs "")  
 (Command "_.Explode" "l" "")
 (setq dt2 (entlast))
 (setq tt1 (entget dt2))
 (setq tt1 (vl-remove-if '(lambda (x) (/= 10 (car x))) tt1))
 (setq dinh11 (cdr (nth 0 tt1)))
 (command "_.align" dt1 "" p01 dinh1 dinh11 dinh2 "" "y")
 (command "_.erase" dt2 "")
 (command "_.move" dt1 "" dinh1 p01)
 (Command "_.Explode" "l")
(ketthuc)
 (princ)
)

(defun c:stb ()
(stretchblock)
)

(defun batdau ()
 (command "undo" "be")
 (setvar "cmdecho" 0)
 (while (/= (logand (getvar "cmdactive") 31) 0)(command pause))
)

(defun ketthuc ()
 (command "undo" "e")
 (setvar "cmdecho" 1)
)
(defun delblock ()
(Command "-Purge" "B" "vkc_temp1" "Y" "Y")
(Command "-Purge" "B" "vkc_temp2" "Y" "Y")
(Command "-Purge" "B" "vkc_temp3" "Y" "Y")
)

(defun blockrectang ()
(while (setq e (ssname sstt 0))
(setq sstt (ssdel e sstt)
tmp (vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p3)
p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3) 
p1 (list (car p1) (cadr p1))
p3 (list (car p3) (cadr p3))
p2 (list (car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
tmp (list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity") 
(cons 100 "AcDbPolyline") 
(cons 90 4)
(cons 70 1)
(cons 10 p1)
(cons 10 p2)
(cons 10 p3)
(cons 10 p4)
)
)
(entmake tmp)
) 
)

 

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

×