Jump to content
InfoFile
Tác giả: Tue_NV
Bài viết gốc: 278552
Tên lệnh: fbn
Đố vui với LISP

Xin Khai bút đầu năm:

(defun c:fbn(/ n f)
(setq n (1+ (getint "Nhap thang thu :")))
(setq f (/ (1+ (sqrt 5)) 2))
(rtos (/ (- (expt f n) (expt (1- f) n)) (sqrt 5)) 2 0)
)
(defun c:fbn(/ n f)
(setq n (1+ (getint "Nhap thang thu :")))
(setq f (/ (1+ (sqrt 5)) 2))
(rtos (/ (- (expt f n) (expt (1- f) n)) (sqrt 5)) 2 0)
)
(defun c:fbn(/ n f)
(setq n (1+ (getint...
>>

Xin Khai bút đầu năm:

(defun c:fbn(/ n f)
(setq n (1+ (getint "Nhap thang thu :")))
(setq f (/ (1+ (sqrt 5)) 2))
(rtos (/ (- (expt f n) (expt (1- f) n)) (sqrt 5)) 2 0)
)
(defun c:fbn(/ n f)
(setq n (1+ (getint "Nhap thang thu :")))
(setq f (/ (1+ (sqrt 5)) 2))
(rtos (/ (- (expt f n) (expt (1- f) n)) (sqrt 5)) 2 0)
)
(defun c:fbn(/ n f)
(setq n (1+ (getint "Nhap thang thu :")))
(setq f (/ (1+ (sqrt 5)) 2))
(rtos (/ (- (expt f n) (expt (1- f) n)) (sqrt 5)) 2 0)
)

<<

Filename: 278552_fbn.lsp
Tác giả: ketxu
Bài viết gốc: 133856
Tên lệnh: dc
Cách thống kê số lượng circle

Lisp bác Tuệ sửa cho bạn chuẩn rồi mà.Mình sửa lại 1 chút để k ghi ra file nữa giúp bạn đây..COpy y nguyên thuật toán đếm của bác Hoành ^^


Qua kết quả thì thấy bản vẽ có đúng 10 loại, thao tác thủ công cũng k chậm lắm đâu bạn hiền ^^

Filename: 133856_dc.lsp
Tác giả: phamthe
Bài viết gốc: 278750
Tên lệnh: ce
Nhờ các bác kiểm tra giúp đoạn code này bị lỗi gì vậy!

oh, bây giờ chức năng upload mới thấy xuất hiện. em gửi lại mong các anh coi giúp với nhé!

;; Continuous Erase - Lee Mac

(defun c:ce ( / *error* flg lst mod pt1 pt2 sel )

(defun *error* ( m ) (redraw) (princ))

(princ "\nSelect objects to erase: ")
(while (and (not flg) (= 3 (car (setq pt1 (grread nil 12 2)))))
(if (setq sel (ssget (setq pt1 (cadr pt1))))
(command "_.erase" sel "")
(progn
(princ "\nSpecify opposite corner:...
>>

oh, bây giờ chức năng upload mới thấy xuất hiện. em gửi lại mong các anh coi giúp với nhé!

;; Continuous Erase - Lee Mac

(defun c:ce ( / *error* flg lst mod pt1 pt2 sel )

(defun *error* ( m ) (redraw) (princ))

(princ "\nSelect objects to erase: ")
(while (and (not flg) (= 3 (car (setq pt1 (grread nil 12 2)))))
(if (setq sel (ssget (setq pt1 (cadr pt1))))
(command "_.erase" sel "")
(progn
(princ "\nSpecify opposite corner: ")
(while (= 5 (car (setq pt2 (grread t 13 0))))
(redraw)
(setq pt2 (cadr pt2)
lst (list pt1 (list (car pt2) (cadr pt1)) pt2 (list (car pt1) (cadr pt2)))
mod (if (< (car pt1) (car pt2)) 0 1)
)
(mapcar '(lambda ( a b ) (grdraw a b -1 mod)) (cons (last lst) lst) lst)
)
(if (listp (setq pt2 (cadr pt2)))
(if (setq sel (ssget (if (< (car pt1) (car pt2)) "_WP" "_CP") lst))
(command "_.erase" sel "")
)
(setq flg t)
)
(redraw)
(princ "\nSelect objects to erase: ")
)
)
)
(princ)
)

<<

Filename: 278750_ce.lsp
Tác giả: ndtnv
Bài viết gốc: 279213
Tên lệnh: ce
Nhờ các bác kiểm tra giúp đoạn code này bị lỗi gì vậy!

Vì không có Cad 2004 nên tôi chỉ test với DYNMODE = 0

 

;; Continuous Erase - Lee Mac
;; Fix - ndtnv (Dynmode <= 0 or nil)
(defun c:ce ( / *error* flg fl2 k lst mod pt1 pt2 sel)
    (defun *error* ( m ) (redraw) (princ))
    (princ "\nSelect objects to erase: ")
    (while (and (not flg) (or (= 3 (setq k (car (setq pt1 (grread nil 12 2))))) (not fl2) ))
        (if (/= 3 k)
            (setq fl2 t)
  ...
>>

Vì không có Cad 2004 nên tôi chỉ test với DYNMODE = 0

 

;; Continuous Erase - Lee Mac
;; Fix - ndtnv (Dynmode <= 0 or nil)
(defun c:ce ( / *error* flg fl2 k lst mod pt1 pt2 sel)
    (defun *error* ( m ) (redraw) (princ))
    (princ "\nSelect objects to erase: ")
    (while (and (not flg) (or (= 3 (setq k (car (setq pt1 (grread nil 12 2))))) (not fl2) ))
        (if (/= 3 k)
            (setq fl2 t)
        (if (setq sel (ssget (setq pt1 (cadr pt1))))
            (command "_.erase" sel "")
            (progn
                (princ "\nSpecify opposite corner: ")
                (while (= 5 (car (setq pt2 (grread t 13 0))))
                    (redraw)
                    (setq pt2 (cadr pt2)
                    lst (list pt1 (list (car pt2) (cadr pt1)) pt2 (list (car pt1) (cadr pt2)))
                    mod (if (< (car pt1) (car pt2)) 0 1)
                    )
                    (mapcar '(lambda ( a b ) (grdraw a b -1 mod)) (cons (last lst) lst) lst)
                )
                (if (listp (setq pt2 (cadr pt2)))
                (if (setq sel (ssget (if (< (car pt1) (car pt2)) "_WP" "_CP") lst))
                (command "_.erase" sel "")
                )
                (setq flg t)
                )
                (redraw)
                (princ "\nSelect objects to erase: ")
            )
        )
    ))
    (princ)
)
 

<<

Filename: 279213_ce.lsp
Tác giả: conghoa
Bài viết gốc: 279807
Tên lệnh: oo
Chỉnh sửa lisp offset

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os msg1 p1 msg2)
        (setq   os (getvar "Osmode")
	 lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (if msg1 (getreal msg1) kc)
                msg2 (strcat "Chon vat...
>>
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os msg1 p1 msg2)
        (setq   os (getvar "Osmode")
	 lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (if msg1 (getreal msg1) kc)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
)

Mình đã chỉnh sửa như trên nhưng khi dùng lệnh nó vẫn bắt nhập khoảng cách mới.

;***********
(defun C:OO (/ lay lt os msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (if msg1 (getreal msg1) kc)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
)

<<

Filename: 279807_oo.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 279878
Tên lệnh: ha
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Nhờ bác Hoanh (hoặc ai đó) sửa giúp lisp này giúp với. Hình như thuật toán nó bị tệ chỗ nào đó nên khi đem vào áp dụng cho bài toán cụ thể thì chạy chậm. Trên cơ sở đó tôi sẽ biến tấu cho bài toán của mình.

;;----- Ham de Test voi vi du don gian. 
(defun C:HA( / vcl ee vv sta end )
 (setq vcl 100 vv '(0 1 2 3 4 5) ee (list
 (list (list 0 0 00) (list 0 1 07) (list 0 2 09) (list...
>>

Nhờ bác Hoanh (hoặc ai đó) sửa giúp lisp này giúp với. Hình như thuật toán nó bị tệ chỗ nào đó nên khi đem vào áp dụng cho bài toán cụ thể thì chạy chậm. Trên cơ sở đó tôi sẽ biến tấu cho bài toán của mình.

;;----- Ham de Test voi vi du don gian. 
(defun C:HA( / vcl ee vv sta end )
 (setq vcl 100 vv '(0 1 2 3 4 5) ee (list
 (list (list 0 0 00) (list 0 1 07) (list 0 2 09) (list 0 3 vcl) (list 0 4 vcl) (list 0 5 14))
 (list (list 1 0 07) (list 1 1 00) (list 1 2 10) (list 1 3 15) (list 1 4 vcl) (list 1 5 vcl))
 (list (list 2 0 09) (list 2 1 10) (list 2 2 00) (list 2 3 11) (list 2 4 vcl) (list 2 5 02))
 (list (list 3 0 vcl) (list 3 1 15) (list 3 2 11) (list 3 3 00) (list 3 4 06) (list 3 5 vcl))
 (list (list 4 0 vcl) (list 4 1 vcl) (list 4 2 vcl) (list 4 3 06) (list 4 4 00) (list 4 5 09))
 (list (list 5 0 14) (list 5 1 vcl) (list 5 2 02) (list 5 3 vcl) (list 5 4 09) (list 5 5 00))))
 (setq sta (getint "\nNhap dinh khoi dau: ")) ; VD nhËp sè ®Çu tiªn lµ: 0
 (setq end (getint "\nNhap dinh ket thuc: ")) ; VD nhËp sè cuèi cïng lµ: 4
 (HA sta end vcl ee vv))
;;----- Ham tong quat.
(defun HA(sta end vcl ee vv / Canh Dinh lst lst1 u n i uv sum q1 vet)
 (defun Canh(u v ee) (caddr (nth v (nth u ee))))
 (defun Dinh(x lst) (cdr (assoc x lst)))
 (setq u sta)
 (setq lst (mapcar '(lambda(x) (cons x (if (= x u) 0 vcl))) vv)) ; G¸n gi¸ trÞ ®Ønh khëi ®Çu lµ 0, cßn l¹i lµ vcl. VD: ((0 . 0) (1 . 100) (2 . 100) (3 . 100) (4 . 100) (5 . 100))
 (while (/= u end) ; Co the thay bang "(while vv", neu tim All Path.
  (setq vv (vl-remove u vv) lst1 lst) ; Lo¹i dÇn tõng ®Ønh ®· xÐt khái vv, VD: (0 1 2 3 4 5) -> (1 2 3 4 5)
  (foreach v vv ; DuyÖt qua tõng ®Ønh cña vv.
   (if (< (setq uv (Canh u v ee)) vcl) ; Chi xet neu canh < vcl.
    (if (< (setq sum (+ (Dinh u lst) uv)) (Dinh v lst)) ; So s¸nh ®Ønh ®· cã víi tæng ®Ønh+c¹nh míi.
     (setq lst (subst (cons v sum) (assoc v lst) lst))))) ; Thay tÊt c¶ tæng cña ®Ønh v liÒn kÒ víi u, nÕu nhá h¬n.
  (if (not (equal lst lst1 1E-8)) ; So sanh, neu lst_old va lst_new khac nhau thi moi sort.
   (setq lst (vl-sort lst '(lambda(x y) (< (cdr x) (cdr y)))) ; Sort lst ®Ó s¾p xÕp l¹i vv.
         q1 (mapcar 'car lst)
         vv (vl-sort vv '(lambda(x y) (< (vl-position x q1) (vl-position y q1)))))) ; Sort vv.
  (setq u (car vv)))
 (setq lst (reverse lst)) ; Bat dau cac buoc do tim vet duong dan tu lst.
 (while (/= (caar lst) end)
  (setq lst (cdr lst)))
 (setq vet (list (car lst)))
 (foreach x (cdr lst)
  (if (equal (Canh (car x) (caar vet) ee) (- (cdar vet) (cdr x)) 1E-8)
   (setq vet (cons x vet))))
 vet)
 


<<

Filename: 279878_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 279888
Tên lệnh: oo
[Giúp đỡ] Chỉnh sửa lisp offset

Ri nè!

(defun C:OO (/ lay lt os p1 msg2)
 (setq os (getvar "Osmode")
  lt (getvar "celtype")
       lay (getvar "Clayer"))
 (or kc (setq kc 100))
 (setq kc (cond ((getdist (strcat "\nVao khoang cach offset <" (rtos kc 2 2) ">: "))) (kc)))
 (setq msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*"))
 (setvar "OSMODE" 512)
 (setq p1 (getpoint msg2))
 (while...
>>

Ri nè!

(defun C:OO (/ lay lt os p1 msg2)
 (setq os (getvar "Osmode")
  lt (getvar "celtype")
       lay (getvar "Clayer"))
 (or kc (setq kc 100))
 (setq kc (cond ((getdist (strcat "\nVao khoang cach offset <" (rtos kc 2 2) ">: "))) (kc)))
 (setq msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*"))
 (setvar "OSMODE" 512)
 (setq p1 (getpoint msg2))
 (while p1
  (command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
  (setq p1 (getpoint msg2)))
 (setvar "OSMODE" os))
 


<<

Filename: 279888_oo.lsp
Tác giả: conghoa
Bài viết gốc: 279761
Tên lệnh: oo
[Giúp đỡ] Chỉnh sửa lisp offset
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
	 lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon...
>>
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
	 lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
)

 

- Mình có cái lisp offset này nhưng mỗi lần chạy lisp lại phải nhập khoảng cách để offset. Mình nhờ các bạn chỉnh giúp mình lisp này có thể lưu lại thông số đã nhập cho lần thực hiện sau (nếu mình không nhập khoảng cách mới thì nó sẽ lấy số được nhập lần trước)

 

Cảm ơn các bạn nhiều!

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)

 

)
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
 
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)

 

)
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
 
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)

 

)
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
 
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
 
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
 
;****************************************************************************
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)

 

)
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
 
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
)
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)

 

)
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
 
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)

 

)
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
 
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)

 

)
;****************************************************************************
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
 
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os kc msg1 p1 msg2)
        (setq   os (getvar "Osmode")
lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (getreal msg1)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
)

<<

Filename: 279761_oo.lsp
Tác giả: ketxu
Bài viết gốc: 280445
Tên lệnh: cpi
[Nhờ chỉnh sửa] lisp copy text tăng dần

Không can thiệp nội dung

(defun c:CPI (/ Block ent Numtext Blk Symbol sym ans pt1 pt2 gr code data NewObj end)
;;; pBe 23 June 2012 ;;;
;;;http://forums.autode.../3507198/page/2	;;;

(setvar 'cmdecho 0)
(prompt "\rSelect Block/Text:")
(cond
	((and
		(setq Block (ssget "_+.:S:L" '((0 . "INSERT,*TEXT"))))
		(setq Block (ssname Block 0))
		(setq NumText
			(if 
				(and 
					(eq (cdr (assoc 0(entget Block)))"INSERT")
					(setq Blk (member '(66 . 1)(entget...
>>

Không can thiệp nội dung

(defun c:CPI (/ Block ent Numtext Blk Symbol sym ans pt1 pt2 gr code data NewObj end)
;;; pBe 23 June 2012 ;;;
;;;http://forums.autode.../3507198/page/2	;;;

(setvar 'cmdecho 0)
(prompt "\rSelect Block/Text:")
(cond
	((and
		(setq Block (ssget "_+.:S:L" '((0 . "INSERT,*TEXT"))))
		(setq Block (ssname Block 0))
		(setq NumText
			(if 
				(and 
					(eq (cdr (assoc 0(entget Block)))"INSERT")
					(setq Blk (member '(66 . 1)(entget Block)))
				)
				(cdr (assoc 1 (entget (entnext Block))))
				(cdr (assoc 1 (entget Block)))
			)
		)
(progn
	(if (not Symbol)(setq Symbol "+"))
	(initget "+ -")
	(setq Symbol
		(cond	((getkword	(strcat "\nChoose : <" Symbol ">: ")))
		(Symbol))
	)
	(initget "Y N")
	(setq ans (cond ( (getkword "\nPrefix  <No>: ") ) ( "N" )))
)
(setq sym (eval (read symbol)))
(setq ent (vlax-ename->vla-object Block))
(setq end nil pt1 (vlax-get ent 'insertionpoint))
(setq NewObj (vla-copy ent))
(while (null end)
(while
(progn
	(prompt "\rPick Next Point/Press  / Right Click to Increase / Any key to Exit")
	(setq gr (grread t 15 0)
	code (car gr)
	data (cadr gr)
)
(cond
((= 5 code)
(vlax-invoke NewObj 'Move pt1 (setq pt2 data))
(setq pt1 pt2))
((= 2 code)
(setq sym (cond
((= data 43) +)
((= data 45) -)
((= data 61) *)
((setq end T) (entdel (entlast)))))
nil)
((= 3 code)
(vlax-invoke NewObj 'Move pt1 (setq pt2 data))
(vla-put-textstring
(if (not Blk)
NewObj
(car (vlax-invoke
NewObj
'GetAttributes))
)
(progn
(setq NumText
(itoa (eval (sym (atoi Numtext) 1
))))
(if (and (< (strlen NumText) 2)
(eq ans "Y"))
(strcat "0" NumText)
Numtext)
)
)
(setq ent NewObj)
(setq NewObj (vla-copy ent))

nil)
((= 25 code)(setq NumText (itoa (1+ (atoi NumText)))))
)
)
)
)
)
)
)
(princ)
)

 


<<

Filename: 280445_cpi.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 278374
Tên lệnh: ve
Until August womenra sildenafil Altogether, employment rose in 37 states in June from May, decreased in 12 states and the District of Columbia and was unchan

Filename: 278374_ve.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 280446
Tên lệnh: cpi
[Nhờ chỉnh sửa] lisp copy text tăng dần

Hề hề hề,

 

Không can thiệp nội dung

(defun c:CPI (/ Block ent Numtext Blk Symbol sym ans pt1 pt2 gr code data NewObj end)
;;; pBe 23 June 2012 ;;;
;;;http://forums.autode.../3507198/page/2	;;;

(setvar 'cmdecho 0)
(prompt "\rSelect Block/Text:")
(cond
	((and
		(setq Block (ssget "_+.:S:L" '((0 . "INSERT,*TEXT"))))
		(setq Block (ssname Block 0))
		(setq NumText
			(if 
				(and 
					(eq (cdr (assoc 0(entget...
>>

Hề hề hề,

 

Không can thiệp nội dung

(defun c:CPI (/ Block ent Numtext Blk Symbol sym ans pt1 pt2 gr code data NewObj end)
;;; pBe 23 June 2012 ;;;
;;;http://forums.autode.../3507198/page/2	;;;

(setvar 'cmdecho 0)
(prompt "\rSelect Block/Text:")
(cond
	((and
		(setq Block (ssget "_+.:S:L" '((0 . "INSERT,*TEXT"))))
		(setq Block (ssname Block 0))
		(setq NumText
			(if 
				(and 
					(eq (cdr (assoc 0(entget Block)))"INSERT")
					(setq Blk (member '(66 . 1)(entget Block)))
				)
				(cdr (assoc 1 (entget (entnext Block))))
				(cdr (assoc 1 (entget Block)))
			)
		)
(progn
	(if (not Symbol)(setq Symbol "+"))
	(initget "+ -")
	(setq Symbol
		(cond	((getkword	(strcat "\nChoose : <" Symbol ">: ")))
		(Symbol))
	)
	(initget "Y N")
	(setq ans (cond ( (getkword "\nPrefix  <No>: ") ) ( "N" )))
)
(setq sym (eval (read symbol)))
(setq ent (vlax-ename->vla-object Block))
(setq end nil pt1 (vlax-get ent 'insertionpoint))
(setq NewObj (vla-copy ent))
(while (null end)
(while
(progn
	(prompt "\rPick Next Point/Press  / Right Click to Increase / Any key to Exit")
	(setq gr (grread t 15 0)
	code (car gr)
	data (cadr gr)
)
(cond
((= 5 code)
(vlax-invoke NewObj 'Move pt1 (setq pt2 data))
(setq pt1 pt2))
((= 2 code)
(setq sym (cond
((= data 43) +)
((= data 45) -)
((= data 61) *)
((setq end T) (entdel (entlast)))))
nil)
((= 3 code)
(vlax-invoke NewObj 'Move pt1 (setq pt2 data))
(vla-put-textstring
(if (not Blk)
NewObj
(car (vlax-invoke
NewObj
'GetAttributes))
)
(progn
(setq NumText
(itoa (eval (sym (atoi Numtext) 1
))))
(if (and (< (strlen NumText) 2)
(eq ans "Y"))
(strcat "0" NumText)
Numtext)
)
)
(setq ent NewObj)
(setq NewObj (vla-copy ent))

nil)
((= 25 code)(setq NumText (itoa (1+ (atoi NumText)))))
)
)
)
)
)
)
)
(princ)
)

Thank Ketxu về điều kiện  ((= 25 code) .... ). Mình có tham khảo trong help nhưng không biết giá trị của code là 25 khi pick chuột phải. Các giá trị này có thể tham khảo ở đâu cho rõ ràng bác Két hè???


<<

Filename: 280446_cpi.lsp
Tác giả: thienha.haui
Bài viết gốc: 280744
Tên lệnh: test
Nhờ viết lisp chèn text số lượng lớn vào tâm đối tượng.

Trong tr­ường hợp này nên dùng FIELD

(defun c:test(/ ss tmau mid p1 p2)
  (setq i -1)
  (if (setq ss (ssget '((0 . "*LINE"))))
    (progn
      (setq tmau (vla-copy (vlax-ename->vla-object (car (entsel "Chon Text mau :")))))
      (vlax-for e (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-getboundingbox e 'p1 'p2)
(vla-move (setq tmau (vla-copy tmau))
   (vla-get-insertionpoint tmau)
  ...
>>

Trong tr­ường hợp này nên dùng FIELD

(defun c:test(/ ss tmau mid p1 p2)
  (setq i -1)
  (if (setq ss (ssget '((0 . "*LINE"))))
    (progn
      (setq tmau (vla-copy (vlax-ename->vla-object (car (entsel "Chon Text mau :")))))
      (vlax-for e (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-getboundingbox e 'p1 'p2)
(vla-move (setq tmau (vla-copy tmau))
   (vla-get-insertionpoint tmau)
    (vlax-3d-point (mapcar  '(lambda (a <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' /> (* 0.5 (+ a <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' />)) (vlax-safearray->list p1) (vlax-safearray->list p2)))
)      
(vla-put-textstring  tmau (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(itoa (vla-get-objectid e) ) ">%)."
(if (vlax-property-available-p e 'area) "Area" "Length")
" \\f \"%lu2%pr0\">%"))
 
 	)
    )
  )
)

lisp của anh rất hay.a có thể sửa các số hạng trong kết quả dc làm tròn thanh m ko ạ

vd  8344=4111+4233  ==> 8.5= 4.2+4.3

mong a giúp


<<

Filename: 280744_test.lsp
Tác giả: hiepttr
Bài viết gốc: 281108
Tên lệnh: tgll
[Nhờ chỉnh sửa] Lisp tính tổng pline ed vào đuôi text

Là "tân binh" nên tạm sửa cho bạn thế này :D :D :D

Có gì thì từ từ sửa tiếp

p/s: Chữ "L" trong text của bạn phải luôn là chữ in hoa đó, tạm thế đã

;; free lisp from cadviet.com
;;;--------------------------------------------------------------------
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun...
>>

Là "tân binh" nên tạm sửa cho bạn thế này :D :D :D

Có gì thì từ từ sửa tiếp

p/s: Chữ "L" trong text của bạn phải luôn là chữ in hoa đó, tạm thế đã

;; free lisp from cadviet.com
;;;--------------------------------------------------------------------
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:TGLL( / ss L e)
(setq
ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
L 0.0
)
(vl-load-com)
(while (setq e (ssname ss 0))
(setq L (+ L (length1 e)))
(ssdel e ss)
)


(setq te (entget(car(entsel"\n Chon Text de gan ket qua :")))
te (subst (cons 1 (strcat (CAT (cdr (assoc 1 te)) "L") (rtos L 2 0))) (assoc 1 te) te))
(entmod te)
)
;;;--------------------------------------------------------------------
;Ham lay ki tu thu n cua chuoi:
(defun TIM(str n)
(substr str n 1)
)
;-------------------
;Ham cat chuoi co 1 ky tu "x" tu dau den ky tu "x"
(defun CAT(str x / i)
(setq i 0)
(while (/= (TIM str (setq i (1+ i))) x)
(substr str 1 (1+ i))
)
)

<<

Filename: 281108_tgll.lsp
Tác giả: vantuan18nd
Bài viết gốc: 281151
Tên lệnh: h1
[NHỜ CHỈNH SỬA] lisp tính cao độ (cho kết quả sai khi số ở dạng 0,00)

http://www.cadviet.com/upfiles/3/103675_tinh_cao_do__h1.lspNhờ các Member của Cadviet.com giúp mình Lisp tính cao độ
(Vui lòng xem file đính kèm)
- Mô tả Lisp
1. Gõ lệnh : h1
2. Pick Chọn điểm đã biết cao độ
3. Pick chọn giá trị cho điểm vừa chọn
4. Pick chọn điểm cần tìm cao độ
5. Kết quả :
 
Nếu...

>>

http://www.cadviet.com/upfiles/3/103675_tinh_cao_do__h1.lspNhờ các Member của Cadviet.com giúp mình Lisp tính cao độ
(Vui lòng xem file đính kèm)
- Mô tả Lisp
1. Gõ lệnh : h1
2. Pick Chọn điểm đã biết cao độ
3. Pick chọn giá trị cho điểm vừa chọn
4. Pick chọn điểm cần tìm cao độ
5. Kết quả :
 
Nếu ở bước (3), Số được chọn ở dạng 0.00 thì kết quả trả về là hoàn toàn chính xác.
Nhưng nếu số được chọn ở dạng 0,00 thì kết quả không chính xác
khác nhau ở dấu Chấm (.) và dấu Phảy (,)
 
6. Đã tìm cách thay đổi đấu Chấm(.) dấu Phảy (,) Trong Control Panel của Windows nhưng không khắc phục được
? Nhờ các member khắc phục giùm !
Thanks !
 
File ví dụ : http://www.cadviet.com/upfiles/3/103675_vi_du__tbv.dwg
File LISP (Lâu rồi mình mới quay trở lại cadviet.com, mình chưa tìm ra cách upload file lisp, có gì sai mong BQT thông cảm giùm, Thanks !)

(defun c:h1 ( / pt p1 p01 ent ecopy elev elev1 offset etype txth)
(setvar "osmode" 1) (command "ucs" "w")
(setq pt (getpoint "\nChon diem da biet cao do: ")
ent (entget (car (entsel "\nChon gia tri cao do cho diem vua xong: ")))
etype (cdr (assoc 0 ent))
txth (cdr (assoc 40 ent)))
(if (/= etype "TEXT")
(progn
(princ "\nGia tri ban chon khong phai la so")
(exit))
(setq elev (atof (cdr (assoc 1 ent)))))
(command "layer" "m" "UNSUITABLE" "")
(while (setq p1(getpoint "\nChon diem can tim cao do"))
(setq elev1 (+ elev (- (cadr p1) (cadr pt)))
offset (abs(- (car p1) (car pt)))
p01 (polar p1 (* 3.0 (/ pi 2)) txth)
p01 (polar p01 pi (* 0.9 txth))
ecopy (list (assoc 0 ent) (cons 100 "AcDbEntity") (cons 8 "UNSUITABLE") (cons 100 "AcDbText") (assoc 10 ent) (assoc 40 ent)
(cons 1 (strcat "" (rtos elev1 2 2))) (assoc 50 ent) (assoc 41 ent) (assoc 51 ent) (assoc 7 ent) (cons 71 0) (cons 72 1)
(cons 11 p1) (list 210 0.0 0.0 1.0) (cons 100 "AcDbText") (cons 73 2)))
(entmake ecopy)
(princ "\nNhan ESC hoac SPACE bar de huy lenh"))
(end_task))

 


<<

Filename: 281151_h1.lsp
Tác giả: trumlenmang
Bài viết gốc: 280773
Tên lệnh: slop
Giúp hoàn thiện lisp tính độ dốc nước thoát
Chào các bác!
Em mới tập tành viết lisp được mấy hôm nay. Nền tảng em chưa vững nên còn nhiều lỗi mong các bác thông cảm. Nhờ bác nào giúp em vấn đề này với.
Cái lisp em viết xong chạy thì tạm ổn theo ý tưởng của em rồi. Nhưng kết thúc lệnh kết quả không hiện ở cuối cùng mà là hiện dòng Command:. Mong các bác giúp đỡ.
Lisp của em đây:

(princ "\nslop-Copyright by...
>>
Chào các bác!
Em mới tập tành viết lisp được mấy hôm nay. Nền tảng em chưa vững nên còn nhiều lỗi mong các bác thông cảm. Nhờ bác nào giúp em vấn đề này với.
Cái lisp em viết xong chạy thì tạm ổn theo ý tưởng của em rồi. Nhưng kết thúc lệnh kết quả không hiện ở cuối cùng mà là hiện dòng Command:. Mong các bác giúp đỡ.
Lisp của em đây:

(princ "\nslop-Copyright by Duc-Ree")
(princ)
(defun c:slop(/ b1 b11 b2 b3 b4 b5 b6 b7 b8)
(princ "\nCopyright by Duc-Ree")
(princ)
(setq b4 0)
(setq b1 (getpoint "\nPick first point"))
(while (and
(setq b2 (getpoint "\nPick next point "))
(setq b11 (Distance b1 b2))
(setq b4 (+ b4 b11))
(setq b1 b2)
(/= b2 "")))
(setq b3 (getreal "\nNhap do doc %: "))
(setq b5 (* b3 0.01 b4))
(initget 1 "Dau Cuoi") (setq b8 (getkword "\nChon cao do diem Dau/Cuoi: "))
(if (= b8 "Dau")
(progn
(setq b6 (getreal "\nNhap cao do diem dau: "))
(setq b7 (- b6 b5))
(prompt (strcat "\nCao do diem dau: " (rtos b6 2 1)))
(prompt (strcat "\tTong chieu dai: " (rtos b4 2 1)))
(prompt (strcat "\tCao do diem cuoi: " (rtos b7 2 1)))
(princ))
(progn
(setq b6 (getreal "\nNhap cao do diem cuoi: "))
(setq b7 (+ b6 b5))
(prompt (strcat "\nCao do diem cuoi: " (rtos b6 2 1)))
(prompt (strcat "\tTong chieu dai: " (rtos b4 2 1)))
(prompt (strcat "\tCao do diem dau: " (rtos b7 2 1)))
(princ))))

<<

Filename: 280773_slop.lsp
Tác giả: haduythanh
Bài viết gốc: 281287
Tên lệnh: 4p
Group các đối tượng bằng lisp

Không có N++ code chả quen tí nào ^^

Sửa cho bạn đây :

 

(Defun c:4p (/ point_1 point_2 point_3 point_4 e ss)
(or *i* (setq *i* 1))
(setq e (entlast) ss (ssadd))

  (setq point_1 (getpoint "\nCho diem thu nhat :"))

  (setq point_2 (getpoint point_1 "\nCho diem thu 2 :"))

  (setq point_3 (getpoint point_2 "\nCho diem thu 2 :"))

  (setq point_4 (getpoint point_3 "\nCho diem thu 2 :"))

 

  (command "line" "_non" point_1 "_non"...
>>

Không có N++ code chả quen tí nào ^^

Sửa cho bạn đây :

 

(Defun c:4p (/ point_1 point_2 point_3 point_4 e ss)
(or *i* (setq *i* 1))
(setq e (entlast) ss (ssadd))

  (setq point_1 (getpoint "\nCho diem thu nhat :"))

  (setq point_2 (getpoint point_1 "\nCho diem thu 2 :"))

  (setq point_3 (getpoint point_2 "\nCho diem thu 2 :"))

  (setq point_4 (getpoint point_3 "\nCho diem thu 2 :"))

 

  (command "line" "_non" point_1 "_non" point_2 "")

  (command "line" "_non" point_2 "_non" point_3 "")

  (command "line" "_non" point_3 "_non" point_4 "")

  (command "line" "_non" point_1 "_non"point_4 "")
(while (setq e (entnext e))
	(setq ss (ssadd e ss))
)
(command "-group" "c" (itoa (setq *i* (1+ *i*))) "" ss "")

  (princ)

)




<<

Filename: 281287_4p.lsp
Tác giả: namnhim
Bài viết gốc: 281312
Tên lệnh: per
Nhờ viết lisp vẽ đường thẳng vuông góc với Pline

Chắc em chưa biết cách diễn đat. Em có một đường Pline và một đường thẳng vuông góc với đường Pline đó, và một giá trị khoảng cách cho trước. Em muốn vẽ một đường thẳng mới : vuông góc với đường Pline, khoảng cách giữa chân hai đường vuông góc theo Pline là giá trị khỏa

>>

Chắc em chưa biết cách diễn đat. Em có một đường Pline và một đường thẳng vuông góc với đường Pline đó, và một giá trị khoảng cách cho trước. Em muốn vẽ một đường thẳng mới : vuông góc với đường Pline, khoảng cách giữa chân hai đường vuông góc theo Pline là giá trị khỏa125447_cad1_1.pngng cách cho trước trên. Em xin cảm ơn

Mình có cái này để vẽ được đường vuông góc với đối tượng mẫu là Line, bạn có thể nhờ các bác sửa giúp để có thể dùng được cả với Pline!  (oh, nhầm không nhìn kỹ hình  :) )

(defun c:Per (/ #Obj #Point #Ang)
   (and (setq #Obj (entsel "\nSelect line: "))
        (eq "LINE" (cdr (assoc 0 (entget (car #Obj)))))
        (or (setq #Point (getpoint "\nSpecify first point <At Selection>: "))
            (setq #Point (vlax-curve-GetClosestPointTo (car #Obj) (cadr #Obj)))
        ) ;_ or
        (setq #Ang (angtos (+ (* 0.5 pi) (vla-get-angle (vlax-ename->vla-object (car #Obj)))) 0 4))
        (vl-cmdf "_.line" "_non" #Point (strcat "<" #Ang) PAUSE "")
   ) ;_ and
   (princ)
 ) ;_ defun 

<<

Filename: 281312_per.lsp
Tác giả: tientracdia
Bài viết gốc: 228349
Tên lệnh: swb
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Mình có sưu tầm lisp trên Cadviet  là SWB_1 : Copy đối đượng trong vùng ( Hình chữ nhật )

Làm thế nào sao khi lisp chọn các đối tượng đó xong, Lisp copy , save as đặt tên mới trong cùng thư mục file chọn để copy trước đó.

File lisp :

(defun c:SWB (/ ov vl bit ss cur ssInside ssOutside ssN ssT ssAll curT plSet) ;SWB -> Sellect With Boundary
  (defun *error* (msg)   ...
>>

Mình có sưu tầm lisp trên Cadviet  là SWB_1 : Copy đối đượng trong vùng ( Hình chữ nhật )

Làm thế nào sao khi lisp chọn các đối tượng đó xong, Lisp copy , save as đặt tên mới trong cùng thư mục file chọn để copy trước đó.

File lisp :

(defun c:SWB (/ ov vl bit ss cur ssInside ssOutside ssN ssT ssAll curT plSet) ;SWB -> Sellect With Boundary
  (defun *error* (msg)    
    (if ov (mapcar 'setvar vl ov)) ; reset Sys vars
    (princ (strcat "\n<< Error: " msg " >>")) ; Print Error Message
    (princ) ; Exit Cleanly
    )
  (setq vl '("CMDECHO" "OSMODE" "ORTHOMODE") ; Sys Var list
        ov (mapcar 'getvar vl)) ; Get Old values  
  (mapcar 'setvar vl '(0 0 0)) ; Turn off CMDECHO, OSMODE, ORTHOMODE
  (command "_.undo" "_m")
  (initget "T N G")
  (setq	bit (getkword "\nBan muon chon Trong hay Ngoai duong bao, hay Giua 2 duong bao <T/N/G>: " ) )
  (cond
    ((= bit "T") ;chon Trong duong bao
     (princ"\n<<< Chon duong bao >>> ")
     (if (and (setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))
	      (setq ssInside (GetssInside ss))
	      (> (sslength ssInside) 0))
       (sssetfirst ssInside ssInside)
       )
     )
    
    ((= bit "G") ;chon giua 2 duong bao
     (princ"\n<<< Chon duong bao ngoai >>> ")
     (setq ssN (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))
     (princ"\n<<< Chon duong bao trong >>> ")
     (setq ssT (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))
	   curT (ssname ssT 0)
	   ssT (GetssInside ssT)
	   ssN (GetssInside ssN))
     (if (and ssT (> (sslength ssT) 0) ssN (> (sslength ssN) 0) )
       (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssT)))
	 (if (ssmemb e ssN) (ssdel e ssN)))
       )
     (if (ssmemb curT ssN) (ssdel curT ssN))
     (sssetfirst ssN ssN)
     )

    ((= bit "N") ;chon Ngoai duong bao
     (initget "T G")
     (setq bit (getkword "\nChon Tat ca doi tuong ngoai duong bao, hay chi doi tuong Giao voi duong bao <T/G>: " ) )
     (princ"\n<<< Chon duong bao >>> ")
     (setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))
	   cur (ssname ss 0))
     (if (= bit "T")
       (progn ;chon Tat ca doi tuong ngoai duong bao
	 (setq ssInside (GetssInside ss)
	       ssAll (ssget "x" (list (cons 410 (getvar "ctab")))) )
	 (if (and ssInside (> (sslength ssInside) 0) )
	   (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside)))
	     (if (ssmemb e ssAll) (ssdel e ssAll)))
	   )
	 (if (ssmemb cur ssAll) (ssdel cur ssAll))
	 (sssetfirst ssAll ssAll)
	 )
       ;chi chon doi tuong Giao voi duong bao
       (if (and (setq ssOutside (GetssOutside ss))
		(> (sslength ssOutside) 0))
	 (sssetfirst ssOutside ssOutside)
	 )
       );if
     );;chon Ngoai duong bao
    );cond

  (mapcar 'setvar vl ov) ; reset Sys Vars
  ;(command "zoom" "e")
  ;(command ".copy" "");_copyclip
  ;_pasteorig dan theo toa do
  ;(setq savefile (getfiled "Chon file .dwg:" "" "dwg" 1))
  ;(c:vca1)
  (princ)
)
;;-----------------------------

(defun GetssOutside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)  
  (if (and (setq lstss1 (gettouching ss2))
	   (setq ss1 (ssadd))
	   (mapcar '(lambda (x) (ssadd x ss1)) lstss1)
	   )
    (progn ; co ssTouching 
      (break_with ss1 ss2 nil 0)
      (setq cur (ssname ss2 0)
	    ssTouching (ssadd)
	    ssOutside (ssadd))
      (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))
      ;loc ssTouching -> ssOutside
      (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))
	(if
	  (or
	    (not(insidep (vlax-curve-getStartPoint e) cur))
	    (not(insidep (vlax-curve-getEndPoint e) cur))
	    (not(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur))
	    );or
	  (ssadd e ssOutside)
	  );if
	);foreach
      );progn
    );if
  (if (ssmemb cur ssOutside) (ssdel cur ssOutside))
  ssOutside
  )

(defun GetssInside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)
  (setq ptLst (GetPtLst (setq cur (ssname ss2 0)))
	ssInside (ssget "_WP" ptLst ) )  
  (if (and (setq lstss1 (gettouching ss2))
	   (setq ss1 (ssadd))
	   (mapcar '(lambda (x) (ssadd x ss1)) lstss1)
	   )
    (progn ; co ssTouching
      (break_with ss1 ss2 nil 0)
      (setq ssTouching (ssadd))
      (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))
      ;loc ssTouching -> ssInside
      (or ssInside (setq ssInside (ssadd)) )
      (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))
	(if
	  (and (insidep (vlax-curve-getStartPoint e) cur)
	       (insidep (vlax-curve-getEndPoint e) cur)
	       (insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2))  cur)
	       )
	  (ssadd e ssInside)
	  );if
	);foreach
      );progn
    );if
  (if (ssmemb cur ssInside) (ssdel cur ssInside))
  ssInside
  )
 
(defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)
  (defun ZClosed (lst)
    (if (and (vlax-curve-isClosed obj)
       (not(equal (car lst)(last lst) 1e-6)))
      (append lst (list (car lst)))
      lst))
  
  (or (eq (type obj) 'VLA-OBJECT)
    (setq obj (vlax-ename->vla-object obj)))
  (setq typ (vlax-get obj 'ObjectName))
  (if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
    (progn
      (setq param 0)
      (while (< param (* pi 2))
	(setq pt (vlax-curve-getPointAtParam obj param)
	      ptlst (cons pt ptlst)
	      param (+ (/ (* pi 2) 72) param))
	)
      (reverse ptlst)
      )
    (progn ;Pline (eq typ "AcDbPolyline")
      (setq param (vlax-curve-getStartParam obj)
	    endparam (vlax-curve-getEndParam obj)
	    anginc (* pi (/ 7.5 180.0)))
      (setq tparam param)
      (while (<= param endparam)
	(setq pt (vlax-curve-getPointAtParam obj param))
	(if (not (equal pt (car ptlst) 1e-12))
	  (setq ptlst (cons pt ptlst)))
	(if  (and (/= param endparam)
		  (setq blg (abs (vlax-invoke obj 'GetBulge param)))
		  (/= 0 blg))
	  (progn
	    (setq delta (* 4 (atan blg)) ;included angle
		  inc (/ 1.0 (1+ (fix (/ delta anginc))))
                  arcparam (+ param inc))
	    (while (< arcparam (1+ param))
	      (setq pt (vlax-curve-getPointAtParam obj arcparam)
                    ptlst (cons pt ptlst)
                    arcparam (+ inc arcparam))))
	  )
	(setq param (1+ param))
	)
      (if (and (apply 'and ptlst)
	       (> (length ptlst) 1))
	(ZClosed (reverse ptlst))
	)
      )
    )
  )



;;  Copyright (c) 2009, Lee McDonnell
;;  (Contact Lee Mac, CADTutor.net)
(defun insidep  (pt Obj / Obj Tol ang doc spc flag int lin xV yV)
  (defun vlax-list->3D-point (lst flag)
  (if lst
    (cons ((if flag car cadr) lst)
          (vlax-list->3D-point (cdddr lst) flag))))
  (or (eq 'VLA-OBJECT (type Obj))
      (setq Obj (vlax-ename->vla-object Obj)))
  (if (not(vlax-curve-getParamAtPoint Obj pt))
    (progn
  (setq Tol  (/ pi 6) ; Uncertainty
        ang  0.0 flag T)
  (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
        spc (if (zerop (vla-get-activespace doc))
              (if (= (vla-get-mspace doc) :vlax-true)
                (vla-get-modelspace doc)
                (vla-get-paperspace doc))
              (vla-get-modelspace doc)))
  (while (and (< ang (* 2 pi)) flag)
    (setq flag (and
                 (setq int
                   (vlax-invoke
                     (setq lin
                       (vla-addLine spc
                         (vlax-3D-point pt)
                           (vlax-3D-point
                             (polar pt ang
                               (if (vlax-property-available-p Obj 'length)
                                 (vla-get-length Obj) 1.0)))))
                                  'IntersectWith Obj
                                    acExtendThisEntity))
                 (<= 6 (length int))
                 (setq xV (vl-sort (vlax-list->3D-point int T) '<)
                       yV (vl-sort (vlax-list->3D-point int nil) '<))
                 (or (<= (car xV) (car pt) (last xV))
                     (<= (car yV) (cadr pt) (last yV))))
          ang  (+ ang Tol))
    (vla-delete lin))
  flag
  )
    T
    ))


;;; Author: CopyrightŽ© 2006-2008 Charles Alan Butler 
;;; Contact @  www.TheSwamp.org
;;===========================================================================
  ;;  get all objects touching entities in the sscross                         
  ;;  limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
  ;;  returns a list of enames
  ;;===========================================================================
 (defun gettouching (sscros / ss lst lstb lstc objl)
    (and
      (setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
            objl (mapcar 'vlax-ename->vla-object lstb)
      )
      (setq ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
				 (cons 410 (getvar "ctab"))))
      )
      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (setq lst (mapcar 'vlax-ename->vla-object lst))
      (mapcar
        '(lambda (x)
           (mapcar
             '(lambda (y)
                (if (not
                      (vl-catch-all-error-p
                        (vl-catch-all-apply
                          '(lambda ()
                             (vlax-safearray->list
                               (vlax-variant-value
                                 (vla-intersectwith y x acextendnone)
                               ))))))
                  (setq lstc (cons (vlax-vla-object->ename x) lstc))
                )
              ) objl)
         ) lst)
    )
    lstc
  )
;;; Author: CopyrightŽ© 2006-2008 Charles Alan Butler 
;;; Contact @  www.TheSwamp.org
(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
                   onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
                   get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
                  )
  ;; ss2brk     selection set to break
  ;; ss2brkwith selection set to use as break points
  ;; self       when true will allow an object to break itself
  ;;            note that plined will break at each vertex
  ;;
  ;; return list of enames of new objects  
  (vl-load-com)  
  (princ "\nCalculating Break Points, Please Wait.\n")
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;                S U B   F U N C T I O N S                      
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  ;;  return T if entity is on a locked layer
  (defun onlockedlayer (ename / entlst)
    (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
    (= 4 (logand 4 (cdr (assoc 70 entlst))))
  )

  ;;  return a list of objects from a selection set
;|  (defun ssget->vla-list (ss)
    (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
  )|;
  (defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
       (setq i -1)
       (while (setq  ename (ssname ss (setq i (1+ i))))
         (setq allobj (cons (vlax-ename->vla-object ename) allobj))
       )
       allobj
  )
  
  ;;  return a list of lists grouped by 3 from a flat list
  (defun list->3pair (old / new)
    (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
                 old (cdddr old)))
    (reverse new)
  )
  
;;=====================================
;;  return a list of intersect points  
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
  (if (not (vl-catch-all-error-p
             (setq iplist (vl-catch-all-apply
                            'vlax-safearray->list
                            (list
                              (vlax-variant-value
                                (vla-intersectwith obj1 obj2 acextendnone)
                              ))))))
    iplist
  )
)

;;========================================
;;  Break entity at break points in list  
;;========================================
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
                  minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
                  brkptE brkpt result GapFlg result ignore dist tmppt
                  #ofpts 2gap enddist lastent obj2break stdist
                 )
  (or BrkGap (setq BrkGap 0.0)) ; default to 0
  (setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point
  
  (setq obj2break ent
        brkobjlst (list ent)
        enttype   (cdr (assoc 0 (entget ent)))
        GapFlg    (not (zerop BrkGap)) ; gap > 0
        closedobj (vlax-curve-isclosed obj2break)
  )
  ;; when zero gap no need to break at end points
  (if (zerop Brkgap)
    (setq spt (vlax-curve-getstartpoint ent)
          ept (vlax-curve-getendpoint ent)
          brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
                                                 (< (distance x ept) 0.0001)))
                                 brkptlst)
    )
  )
  (if brkptlst
    (progn
  ;;  sort break points based on the distance along the break object
  ;;  get distance to break point, catch error if pt is off end
  ;; ver 2.0 fix - added COND to fix break point is at the end of a
  ;; line which is not a valid break but does no harm
  (setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
                                               ;; ver 2.0 fix
                                               (cond ((vlax-curve-getparamatpoint obj2break x))
                                                   ((vlax-curve-getparamatpoint obj2break
                                                     (vlax-curve-getclosestpointto obj2break x))))))
                            ) brkptlst))
  ;; sort primary list on distance
  (setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))
  
  (if GapFlg ; gap > 0
    ;; Brkptlst starts as the break point and then a list of pairs of points
    ;;  is creates as the break points
    (progn
      ;;  create a list of list of break points
      ;;  ((idx# stpoint distance)(idx# endpoint distance)...)
      (setq idx 0)
      (foreach brkpt brkptlst
        
        ;; ----------------------------------------------------------
        ;;  create start break point, then create end break point    
        ;;  ((idx# startpoint distance)(idx# endpoint distance)...)  
        ;; ----------------------------------------------------------
        (setq dist (cadr brkpt)) ; distance to center of gap
        ;;  subtract gap to get start point of break gap
        (cond
          ((and (minusp (setq stDist (- dist BrkGap))) closedobj )
           (setq stdist (+ (vlax-curve-getdistatparam obj2break
                             (vlax-curve-getendparam obj2break)) stDist))
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
           )
          ((minusp stDist) ; off start of object so get startpoint
           (setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
           )
          (t
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
          )
        )
        ;;  add gap to get end point of break gap
        (cond
          ((and (> (setq stDist (+ dist BrkGap))
                   (setq endDist (vlax-curve-getdistatparam obj2break
                                     (vlax-curve-getendparam obj2break)))) closedobj )
           (setq stdist (- stDist endDist))
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
           )
          ((> stDist endDist) ; off end of object so get endpoint
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                        (vlax-curve-getendparam obj2break))
                                  endDist) dlst))
           )
          (t
           (setq dlst (cons (list idx
                                  (vlax-curve-getpointatparam obj2break
                                         (vlax-curve-getparamatdist obj2break stDist))
                                  stDist) dlst))
          )
        )
        ;; -------------------------------------------------------
        (setq idx (1+ IDX))
      ) ; foreach brkpt brkptlst
      

      (setq dlst (reverse dlst))
      ;;  remove the points of the gap segments that overlap
      (setq idx -1
            2gap (* BrkGap 2)
            #ofPts (length Brkptlst)
      )
      (while (<= (setq idx (1+ idx)) #ofPts)
        (cond
          ((null result) ; 1st time through
           (setq result (list (car dlst)) ; get first start point
                 result (cons (nth (1+(* idx 2)) dlst) result))
          )
          ((= idx #ofPts) ; last pass, check for wrap
           (if (and closedobj (> #ofPts 1)
                    (<= (+(- (vlax-curve-getdistatparam obj2break
                            (vlax-curve-getendparam obj2break))
                          (cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
             (progn
               (if (zerop (rem (length result) 2))
                 (setq result (cdr result)) ; remove the last end point
               )
               ;;  ignore previous endpoint and present start point
               (setq result (cons (cadr (reverse result)) result) ; get last end point
                     result (cdr (reverse result))
                     result (reverse (cdr result)))
             )
           )
          )
          ;; Break Gap Overlaps
          ((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
           (if (zerop (rem (length result) 2))
             (setq result (cdr result)) ; remove the last end point
           )
           ;;  ignore previous endpoint and present start point
           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
           )
          ;; Break Gap does Not Overlap previous point 
          (t
           (setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
           (setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
          )
        ) ; end cond stmt
      ) ; while
      
      (setq dlst     (reverse result)
            brkptlst nil)
      (while dlst ; grab the points only
        (setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
              dlst   (cddr dlst))
      )
    )
  )
  ;;   -----------------------------------------------------

  ;; (if (equal  a ent) (princ)) ; debug CAB  -------------
 
  (foreach brkpt (reverse brkptlst)
    (if GapFlg ; gap > 0
      (setq brkptS (car brkpt)
            brkptE (cadr brkpt))
      (setq brkptS (car brkpt)
            brkptE brkptS)
    )
    ;;  get last entity created via break in case multiple breaks
    (if brkobjlst
      (progn
        (setq tmppt brkptS) ; use only one of the pair of breakpoints
        ;;  if pt not on object x, switch objects
        (if (not (numberp (vl-catch-all-apply
                            'vlax-curve-getdistatpoint (list obj2break tmppt))))
          (progn ; find the one that pt is on
            (setq idx (length brkobjlst))
            (while (and (not (minusp (setq idx (1- idx))))
                        (setq obj (nth idx brkobjlst))
                        (if (numberp (vl-catch-all-apply
                                       'vlax-curve-getdistatpoint (list obj tmppt)))
                          (null (setq obj2break obj)) ; switch objects, null causes exit
                          t
                        )
                   )
            )
          )
        )
      )
    )

    (setq closedobj (vlax-curve-isclosed obj2break))
    (if GapFlg ; gap > 0
      (if closedobj
        (progn ; need to break a closed object
          (setq brkpt2 (vlax-curve-getPointAtDist obj2break
                     (- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
          (command "._break" obj2break "_non" (trans brkpt2 0 1)
                   "_non" (trans brkptE 0 1))
          (and (= "CIRCLE" enttype) (setq enttype "ARC"))
          (setq BrkptE brkpt2)
        )
      )

      (if (and closedobj 
               (not (setq brkptE (vlax-curve-getPointAtDist obj2break
                       (+ (vlax-curve-getdistatparam obj2break
                            ;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
                            ;; ver 2.0 fix
                            (cond ((vlax-curve-getparamatpoint obj2break brkpts))
                                  ((vlax-curve-getparamatpoint obj2break
                                      (vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
        (setq brkptE (vlax-curve-getPointAtDist obj2break
                       (- (vlax-curve-getdistatparam obj2break
                            ;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
                            ;; ver 2.0 fix
                            (cond ((vlax-curve-getparamatpoint obj2break brkpts))
                                  ((vlax-curve-getparamatpoint obj2break
                                      (vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
       )
    ) ; endif
    
    ;; (if (null brkptE) (princ)) ; debug
    
    (setq LastEnt (GetLastEnt))
    (command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
    (and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
    (and (= "CIRCLE" enttype) (setq enttype "ARC"))
    (if (and (not closedobj) ; new object was created
             (not (equal LastEnt (entlast))))
        (setq brkobjlst (cons (entlast) brkobjlst))
    )
  )
  )
  ) ; endif brkptlst
  
) ; defun break_obj

;;====================================
;;  CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
  (if (setq result (entlast))
    (while (setq ename (entnext result))
      (setq result ename)
    )
  )
  result
)
;;===================================
;;  CAB - return a list of new enames
(defun GetNewEntities (ename / new)
  (cond
    ((null ename) (alert "Ename nil"))
    ((eq 'ENAME (type ename))
      (while (setq ename (entnext ename))
        (if (entget ename) (setq new (cons ename new)))
      )
    )
    ((alert "Ename wrong type."))
  )
  new
)
  
  ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  ;;         S T A R T  S U B R O U T I N E   H E R E              
  ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   
    (setq LastEntInDatabase (GetLastEnt))
    (if (and ss2brk ss2brkwith)
    (progn
      (setq oc 0
            ss2brkwithList (ssget->vla-list ss2brkwith))
      (if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)
        (setq *BrkVerbose* t)
      )
      (and *BrkVerbose*
           (princ (strcat "Objects to be Checked: "
            (itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))
      ;;  CREATE a list of entity & it's break points
      (foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
        (if (not (onlockedlayer (vlax-vla-object->ename obj)))
          (progn
            (setq lst nil)
            ;; check for break pts with other objects in ss2brkwith
            (foreach intobj  ss2brkwithList
              (if (and (or self (not (equal obj intobj)))
                       (setq intpts (get_interpts obj intobj))
                  )
                (setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
              )
              (and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))
            )
            (if lst
              (setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
            )
          )
        )
      )    
      (and *BrkVerbose* (princ "\nBreaking Objects.\n"))
      (setq *brkcnt* 0) ; break counter
      ;;  masterlist = ((ent brkpts)(ent brkpts)...)
      (if masterlist
        (foreach obj2brk masterlist
          (break_obj (car obj2brk) (cdr obj2brk) Gap)
        )
      )
      )
  )
;;==============================================================
   (and (zerop *brkcnt*) (princ "\nNone to be broken."))
   (setq *BrkVerbose* nil)
  (GetNewEntities LastEntInDatabase) ; return list of enames of new objects
)

Rất mong được các bạn giúp


<<

Filename: 228349_swb.lsp
Tác giả: conghoa
Bài viết gốc: 279886
Tên lệnh: oo
Chỉnh sửa lisp offset
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os msg1 p1 msg2)
        (setq   os (getvar "Osmode")
	 lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 (getreal  "\nVao khoang cach offset: ")
		kc (if msg1 msg1 kc)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1...
>>
;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os msg1 p1 msg2)
        (setq   os (getvar "Osmode")
	 lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 (getreal  "\nVao khoang cach offset: ")
		kc (if msg1 msg1 kc)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
)

Bác phambinhminh xem lại giúp, :D lisp vẫn bắt nhập khoảng cách


<<

Filename: 279886_oo.lsp
Tác giả: quansla
Bài viết gốc: 268483
Tên lệnh: thu22
Có cách nào ẩn block or biến block thành layer để ẩn đi không?
Dùng lisp được không bạn.
Với cad đời cao có thể dùng Code này, với Cad đời thấp chưa có hàm, lệnh ẩn hiện đối  tượng thì cm lại mình cóp nhặt topic khác về sửa lại cho, cái này là tận dùng hàm có sẵn trong Cad 2012

(defun c:thu22(/ ls x fl  )
  (vl-load-com)  
  (setq ls(mapcar '(lambda(x)
    (assoc 2 (entget x)))
 (acet-ss-to-list(ssget '((0 . "INsert"))))))
  ;(setq ss (ssget (list (append...
>>
Dùng lisp được không bạn.
Với cad đời cao có thể dùng Code này, với Cad đời thấp chưa có hàm, lệnh ẩn hiện đối  tượng thì cm lại mình cóp nhặt topic khác về sửa lại cho, cái này là tận dùng hàm có sẵn trong Cad 2012

(defun c:thu22(/ ls x fl  )
  (vl-load-com)  
  (setq ls(mapcar '(lambda(x)
    (assoc 2 (entget x)))
 (acet-ss-to-list(ssget '((0 . "INsert"))))))
  ;(setq ss (ssget (list (append (cons -4  "<or") ls ( cons -4  "or>")))))
  (setq fl (append '(( -4 . "<and")(0 . "INsert")( -4 . "<or")) ls '(( -4 . "or>")( -4 . "and>"))))
  (command "HIDEOBJECTS" (ssget "_x" fl) "")
  (princ)
  )


Sử dụng: Gọi lệnh : Thu222(Thử 222) quét chọn Các Insert (block)
Lisp lọc toạn bộ Block cùng tên trong tập chọn và cho ẩn hết đi. Để hiện lại gõ lệnh :"UNISOLATEOBJECTS"
Chúc vui
<<

Filename: 268483_thu22.lsp

Trang 151/315

151