Jump to content
InfoFile
Tác giả: nhantony
Bài viết gốc: 322148
Tên lệnh: ha
Sửa lisp ghi cao độ và xin lisp tính khoảng cách trên mặt cắt ngang

Lang thang diễn đàn trên thấy lisp rất hay và đúng cái mình muốn tìm nhưng nhờ các pro trong forum sửa lại và thêm một số chức năng nữa:
- Xuất cao độ theo thỉ lệ bản vẽ
- Thêm dấu "+" - " theo mốc
Lisp cần sửa ở link bên dưới

Nhân tiện anh em có lisp tính khoảng cách và khoảng cách cộng dồn trên mặt cắt ngang cho mình xin

P /...

>>

Lang thang diễn đàn trên thấy lisp rất hay và đúng cái mình muốn tìm nhưng nhờ các pro trong forum sửa lại và thêm một số chức năng nữa:
- Xuất cao độ theo thỉ lệ bản vẽ
- Thêm dấu "+" - " theo mốc
Lisp cần sửa ở link bên dưới

Nhân tiện anh em có lisp tính khoảng cách và khoảng cách cộng dồn trên mặt cắt ngang cho mình xin

P / s: Đây là bài post đầu tiên mong Mod thông cảm 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/62667-nho-anh-em-giup-lisp-ghi-cao-do-mat-cat-ngang/
(defun C:HA( / y0 y1 ent)
(command "ucs" "w")
(setq y0 (cadr (cdr (assoc 10 (entget (car (entsel "\nChon Line de lam duong chuan: ")))))))
(while
  (and
   (setq y1 (cadr (getpoint "\nPick diem de lay cao do: ")))
   (setq ent (car (entsel "\nChon Text de sua cao do: ")))
   (entmod (subst (cons 1 (rtos (- y1 y0) 2 2)) (assoc 1 (entget ent)) (entget ent)))))
(princ))

 

;; free lisp from cadviet.com
(defun C:HA( / y0 y1 ent)
 (command "ucs" "w")
 (setq y0 (cadr (cdr (assoc 10 (entget (car (entsel "\nChon Line de lam duong chuan: ")))))))
 (while
  (and
   (setq y1 (cadr (getpoint "\nPick diem de lay cao do: ")))
   (setq ent (car (entsel "\nChon Text de sua cao do: ")))
   (entmod (subst (cons 1 (rtos (- y1 y0) 2 2)) (assoc 1 (entget ent)) (entget ent)))))
 (princ))
 
;; free lisp from cadviet.com
(defun C:HA( / y0 y1 ent)
 (command "ucs" "w")
 (setq y0 (cadr (cdr (assoc 10 (entget (car (entsel "\nChon Line de lam duong chuan: ")))))))
 (while
  (and
   (setq y1 (cadr (getpoint "\nPick diem de lay cao do: ")))
   (setq ent (car (entsel "\nChon Text de sua cao do: ")))
   (entmod (subst (cons 1 (rtos (- y1 y0) 2 2)) (assoc 1 (entget ent)) (entget ent)))))
 (princ))
 
;; free lisp from cadviet.com
(defun C:HA( / y0 y1 ent)
 (command "ucs" "w")
 (setq y0 (cadr (cdr (assoc 10 (entget (car (entsel "\nChon Line de lam duong chuan: ")))))))
 (while
  (and
   (setq y1 (cadr (getpoint "\nPick diem de lay cao do: ")))
   (setq ent (car (entsel "\nChon Text de sua cao do: ")))
   (entmod (subst (cons 1 (rtos (- y1 y0) 2 2)) (assoc 1 (entget ent)) (entget ent)))))
 (princ))
 

<<

Filename: 322148_ha.lsp
Tác giả: Tot77
Bài viết gốc: 322556
Tên lệnh: nha
Di chuyển các điểm node của đường Pline

Bạn thử cái này, nhấp chọn pline màu vàng, chọn điểm đầu và cuối của pline cần di chuyển , sau đó chọn pline màu xanh.

(defun c:nha (/ os a b pt1 pt2 ad bg cg sg l1 l2 pt3 pt4 en)
  (vl-load-com)
  (defun dxf (id v) (cdr (assoc id (entget...
>>

Bạn thử cái này, nhấp chọn pline màu vàng, chọn điểm đầu và cuối của pline cần di chuyển , sau đó chọn pline màu xanh.

(defun c:nha (/ os a b pt1 pt2 ad bg cg sg l1 l2 pt3 pt4 en)
  (vl-load-com)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun ints (o1 o2 mo)
    (defun get3(l) (if (cdddr l) (cons (list (car l) (cadr l) (caddr l)) (get3 (cdddr l))) (list l)))
    (get3 (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) mo))
  )
  (defun getvertex (pl d1 d2 / lst p1 p2 p3 p4)
    (setq lst nil
 p1 (if d1 (vlax-curve-getParamatPoint pl (vlax-curve-getclosestpointto pl d1)) 1)
 p2 (if d2 (vlax-curve-getParamatPoint pl (vlax-curve-getclosestpointto pl d2))
          (1- (vlax-curve-getEndParam pl)))
 p3 (1- (min p1 p2))
 p4 (1+ (max p1 p2))
    )
    (while (<= p3 p4) 
      (setq lst (cons (vlax-curve-getpointatParam pl p3) lst)
   p3 (1+ p3))
    )
    (reverse lst)
  )
  
  (setq os (getvar 'osmode))
  (vl-cmdf "ucs" "w" "undo" "be") (setvar 'osmode 1)
  (setq a (car (entsel "\nChon Pline can di chuyen: "))
pt1 (getpoint "\nTu diem: ") 
pt2 (getpoint "\nDen diem: ") 
b (car (entsel "\nDen Pline: "))
ag (getvertex a pt1 pt2)
bg (getvertex b nil nil)
cg (getvertex a nil nil))
  (setvar 'osmode 0)
  (setq l1 (entmakex (list '(0 . "LINE") (cons 10 (car ag)) (cons 11 (cadr ag))))
l2 (entmakex (list '(0 . "LINE") (cons 10 (last ag)) (cons 11 (cadr (reverse ag)))))
ag (vl-remove (last ag) (cdr ag))
pt3 (ints l1 b acextendboth)
pt3 (car (vl-sort pt3 '(lambda (x y) (< (distance (car ag) x) (distance (car ag) y)))))
pt4 (ints l2 b acextendboth)
pt4 (car (vl-sort pt4 '(lambda (x y) (< (distance (last ag) x) (distance (last ag) y)))))
sg (mapcar '(lambda (x) (list x (nth (vl-position x cg) bg))) (vl-remove (last ag) (cdr ag)))
sg (append (cons (list (car ag) pt3) sg) (list (list (last ag) pt4)))
  )
  (setq en a)
  (while (not (equal (dxf 0 (setq en (entnext en))) "SEQEND"))
    (if (setq tm (assoc (dxf 10 en) sg))
       (entmod (subst (cons 10 (last tm)) (cons 10 (car tm)) (entget en))))
  )
  (entdel l1) (entdel l2) (vl-cmdf "regen" "ucs" "p" "undo" "e") (setvar 'osmode os) (princ)
)
 
 

<<

Filename: 322556_nha.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 322634
Tên lệnh: cbl
nhờ viết lisp tạo mới một block và chèn vào bản vẽ

 bác ketxu ơi. có lisp nào làm được yêu cầu này không a. em có 1 file bản vẽ A đã tạo sẵn trong đó có nhiêu  block. bây giờ mở 1 bản vẽ mới lên và chèn từng block mình chọn( trong bản vẽ A) để rỏ ràng em xin up bản vẽ minh hoạ duới. ví dụ 2 block có tên 1 và 2

 bác ketxu ơi. có lisp nào làm được yêu cầu này không a. em có 1 file bản vẽ A đã tạo sẵn trong đó có nhiêu  block. bây giờ mở 1 bản vẽ mới lên và chèn từng block mình chọn( trong bản vẽ A) để rỏ ràng em xin up bản vẽ minh hoạ duới. ví dụ 2 block có tên 1 và 2http://www.cadviet.com/upfiles/4/122369_a.rar

Của bạn đây:

(defun c:cbl(/ tt diem )
(setq tt  (getfiled "\n Chon Blog: (.dwg)" "C:\\Program Files\\AutoCAD 2007\\Support\\Block\\" "dwg" 2))

(or *tyle* (setq *tyle* 1))
(setq tyle (getreal (strcat "\n Nhap Ty Le <"
			  (rtos *tyle* 2 2)
			 "> :"
		  )
	 )
)
(if (not tyle) (setq tyle *tyle*) (setq *tyle* tyle))	
(While 
(setq diem (getpoint "\n Chon Diem Insert Block :"))   
(command "insert" tt "s" tyle diem "")
))

Đầu tiên lập một thư mục Block theo đường dẫn :  C:\\Program Files\\AutoCAD 2007\\Support\\Block. Nếu bạn dùng bản cad nào khác thì thay thế Autocad 2007 thành tương ứng.

Sau đó bạn tạo block bằng cách trên dòng lệnh comand gõ: Wblock và lưu vào thư mục Block ở trên (Nếu banh chưa rành về wblock thì có thể hỏi Mr. Google. :D)

Khi cần dùng bạn gõ lệnh cbl trên comand line và insert block vào điểm mình cần. Có thể dùng cách này với mọi bản vẽ cả mới lẫn cũ. Chúc bạn thành công


<<

Filename: 322634_cbl.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 322625
Tên lệnh: ha
Em nhờ các anh chị em viết giúp lisp scan block thuộc tính !

Nhớ là cái này đã có nhiều rồi mà.

; Chuc nang: Scale Blocks at Center.
(defun C:HA (/ ss ent obj i)
 (vl-load-com)
 (if (not *tl*) (setq *tl* 1.0))
 (initget 6)
 (setq tl (getreal (strcat "\nHe so Scale <" (rtos *tl* 2) ">: ")))
 (if (not tl) (setq tl *tl*) (setq *tl* tl))
 (princ "\nChon cac Block can Scale...")
 (setq ss (ssget '((0 . "INSERT"))) i -1)
 (while (< (setq i (1+ i)) (sslength ss))
  (setq ent...
>>

Nhớ là cái này đã có nhiều rồi mà.

; Chuc nang: Scale Blocks at Center.
(defun C:HA (/ ss ent obj i)
 (vl-load-com)
 (if (not *tl*) (setq *tl* 1.0))
 (initget 6)
 (setq tl (getreal (strcat "\nHe so Scale <" (rtos *tl* 2) ">: ")))
 (if (not tl) (setq tl *tl*) (setq *tl* tl))
 (princ "\nChon cac Block can Scale...")
 (setq ss (ssget '((0 . "INSERT"))) i -1)
 (while (< (setq i (1+ i)) (sslength ss))
  (setq ent (ssname ss i))
  (command "scale" ent "" "non" (cdr (assoc 10 (entget ent))) tl)))
 

<<

Filename: 322625_ha.lsp
Tác giả: duy782006
Bài viết gốc: 297832
Tên lệnh: them%3Cspan+clas
Hỏi cách thêm kí tự bất kỳ vào text
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:THEMTEXT (/ c e ss txt cmde ttdangs ttdangt)
  (command "undo" "be")
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq ttdangt (getstring 5"\nChuoi muon them phia truoc:")) 
  (setq ttdangs (getstring 5"\nChuoi muon them phia sau:")) 
  (if (null ttdangt)(setq ttdangt ""))
  (if (null...
>>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:THEMTEXT (/ c e ss txt cmde ttdangs ttdangt)
  (command "undo" "be")
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq ttdangt (getstring 5"\nChuoi muon them phia truoc:")) 
  (setq ttdangs (getstring 5"\nChuoi muon them phia sau:")) 
  (if (null ttdangt)(setq ttdangt ""))
  (if (null ttdangs)(setq ttdangs ""))
 (prompt "\nChon chu muon chinh.")
  (setq ss (ssget))
  (setq c 0)
  (if ss (setq e (ssname ss c)))
  (while e
    (setq e (entget e))
    ; Ensure entity is text
    (if (= (cdr (assoc 0 e)) "TEXT")
        (progn
                 (setq txt (strcat ttdangt (cdr (assoc 1 e)) ttdangs))
           (setq e (subst (cons 1 txt) (assoc 1 e) e))
           (entmod e)
        )
    )
    (setq c (1+ c)) ; Increment counter.
    (setq e (ssname ss c))  ; Obtain next entity.
   )
   (setvar "CMDECHO" cmde)
   (command "undo" "end")
      (Prin1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:BOTTEXT (/ c e ss txt cmde tbdangs tbdangt)
  (command "undo" "be")
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq tbdangt (getreal "\nSo ky tu muon bot phia truoc:")) 
  (setq tbdangs (getreal "\nSo ky tu muon bot phia sau:")) 
  (if (null tbdangt)(setq tbdangt 0))
  (if (null tbdangs)(setq tbdangs 0))
  (setq sotru (+ tbdangt tbdangs))
 (prompt "\nChon chu muon chinh.")
  (setq ss (ssget))
  (setq c 0)
  (if ss (setq e (ssname ss c)))
  (while e
    (setq e (entget e))
    ; Ensure entity is text
    (if (= (cdr (assoc 0 e)) "TEXT")
        (progn
(setq sochu (strlen (cdr (assoc 1 e))))
(if (> sochu sotru)
(progn
(setq txt (substr (cdr (assoc 1 e)) (fix (+ 1 tbdangt)) (fix (- sochu tbdangt tbdangs))))
           (setq e (subst (cons 1 txt) (assoc 1 e) e))
           (entmod e)
)
)

        )
    )
    (setq c (1+ c)) ; Increment counter.
    (setq e (ssname ss c))  ; Obtain next entity.
   )
   (setvar "CMDECHO" cmde)
   (command "undo" "end")
      (Prin1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Lệnh là  THEMTEXT và  BOTTEXT


<<

Filename: 297832_them%3Cspan+clas.lsp
Tác giả: ductrunggtvt
Bài viết gốc: 323214
Tên lệnh: trb
đặt layer và màu khi vẽ lệnh

Mình search trên diễn đàn và tìm được lisp về tô bóng, trong lệnh này khi vẽ các đường bóng thì layer và màu mặc định là cái hiện tại. mình muốn khi nó vẽ thì đường bóng layer là "danhbong" và màu mặc định là "8", sau khi hết thúc lệnh trả về layer và màu ban đầu. Mình không chuyên lập trình lisp nên nhờ anh em sửa giúp tí. cảm ơn nhiều!
(defun...
>>
Mình search trên diễn đàn và tìm được lisp về tô bóng, trong lệnh này khi vẽ các đường bóng thì layer và màu mặc định là cái hiện tại. mình muốn khi nó vẽ thì đường bóng layer là "danhbong" và màu mặc định là "8", sau khi hết thúc lệnh trả về layer và màu ban đầu. Mình không chuyên lập trình lisp nên nhờ anh em sửa giúp tí. cảm ơn nhiều!
(defun c:trb(/ p1 p11 p2 p22 n1 x1 x2 dis1 dis2 i oldOs oldCmd)
(grtext -1 "@S\U+01A1n T\U+00F9ng - ketxu - Cadviet")
(if (= n nil)(setq n 10))
(setq p1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m 1") 
p2 (getpoint p1 "\nCh\U+1ECDn \U+0111i\U+1EC3m 2") 
p11 (getpoint  "\nCh\U+1ECDn \U+0111i\U+1EC3m 3") 
p22 (getpoint p11 "\nCh\U+1ECDn \U+0111i\U+1EC3m 4") i 0
n1 (getint (strcat "\nS\U+1ED1 kho\U+1ea3ng chia < " (rtos n 2 0) " > : "))
	dis1 (distance p1 p11)
	dis2 (distance p2 p22)
)
(if n1 (setq n n1))
(setq
x1 (/ dis1  (/ (* n (+ n 1)) 2))
x2 (/ dis2  (/ (* n (+ n 1)) 2))
oldOs (getvar "osmode")
oldCmd (getvar "cmdecho"))

(setvar "osmode" 0)
(setvar "cmdecho" 0)
(repeat n
	(command ".Line" (setq p1 (polar p1 (angle p1 p11) (+ x1 (* i x1)))) (setq p2(polar p2 (angle p2 p22) (+ x2 (* i x2)))) "")
	(setq i (1+ i))
)
(setvar "osmode" oldOs)
(setvar "cmdecho" oldCmd)
)

<<

Filename: 323214_trb.lsp
Tác giả: nhoclangbat
Bài viết gốc: 323228
Tên lệnh: trb
đặt layer và màu khi vẽ lệnh

- hàng này của thầy Ket đây mà ^^, nhoc nghịch tí ^^

;;--------------------------------------
(defun _layer2 ( name colour )
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
   ...
>>

- hàng này của thầy Ket đây mà ^^, nhoc nghịch tí ^^

;;--------------------------------------
(defun _layer2 ( name colour )
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)
;================================
(defun c:trb(/ p1 p11 p2 p22 n1 x1 x2 dis1 dis2 i oldOs oldCmd oldclay)
(grtext -1 "@S\U+01A1n T\U+00F9ng - ketxu - Cadviet")
(if (null (tblsearch "layer" "danhbong")) (_layer2 "danhbong" 8)) 
(if (= n nil)(setq n 10))
(setq p1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m 1") 
p2 (getpoint p1 "\nCh\U+1ECDn \U+0111i\U+1EC3m 2") 
p11 (getpoint  "\nCh\U+1ECDn \U+0111i\U+1EC3m 3") 
p22 (getpoint p11 "\nCh\U+1ECDn \U+0111i\U+1EC3m 4") i 0
n1 (getint (strcat "\nS\U+1ED1 kho\U+1ea3ng chia < " (rtos n 2 0) " > : "))
	dis1 (distance p1 p11)
	dis2 (distance p2 p22)
)
(if n1 (setq n n1))
(setq
x1 (/ dis1  (/ (* n (+ n 1)) 2))
x2 (/ dis2  (/ (* n (+ n 1)) 2))
oldOs (getvar "osmode")
oldCmd (getvar "cmdecho")
oldclay (getvar 'clayer))

(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setvar 'clayer "danhbong")
(repeat n
	(command ".Line" (setq p1 (polar p1 (angle p1 p11) (+ x1 (* i x1)))) (setq p2(polar p2 (angle p2 p22) (+ x2 (* i x2)))) "")
	(setq i (1+ i))
)
(setvar "osmode" oldOs)
(setvar "cmdecho" oldCmd)
(setvar 'clayer oldclay)
(princ)
)

<<

Filename: 323228_trb.lsp
Tác giả: Tot77
Bài viết gốc: 323254
Tên lệnh: test
Lisp lọc đối tượng đường thẳng song song

Bạn thử cái này.

(defun c:test (/ ss coroi a ang tm)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget))))
coroi nil
rt nil)
  (while (and ss (not coroi))
    (setq a (car ss)
 ang (angle (dxf 10 a) (dxf 11 a))
 ss (cdr ss))
    (if (setq tm (vl-remove-if-not '(lambda (x) (or (= ang (angle (dxf 10 x) (dxf 11 x)))
                   (= ang (angle (dxf 11 x)...
>>

Bạn thử cái này.

(defun c:test (/ ss coroi a ang tm)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget))))
coroi nil
rt nil)
  (while (and ss (not coroi))
    (setq a (car ss)
 ang (angle (dxf 10 a) (dxf 11 a))
 ss (cdr ss))
    (if (setq tm (vl-remove-if-not '(lambda (x) (or (= ang (angle (dxf 10 x) (dxf 11 x)))
                   (= ang (angle (dxf 11 x) (dxf 10 x))))) ss))
      (setq rt (list a (car tm))
   coroi t)
    )
  )
  (if rt (sssetfirst nil (ssadd (last rt) (ssadd (car rt)))))
)

<<

Filename: 323254_test.lsp
Tác giả: hiepttr
Bài viết gốc: 313631
Tên lệnh: circlebox grc cb2 grc2
Chương 10.3 : Grdraw, Grvecs, Grtext

Trau chuốt tí sau khi "được ném đá" :D

 

;Bai tap chuong 10.3
;;Bai 1:
(defun c:CIRCLEBOX( / ss i ename info cen r xc yc Rve BL BR TL TR)
(prompt "\nChon duong tron: ")
(setq ss (ssget '((0 . "CIRCLE"))))
(if ss
	(progn
		(or #offset (setq #offset 0.0))
		(setq #offset 
			(cond
				((getreal (strcat "\nKhoang offset <" (rtos #offset) ">:")))
				(#offset)
			)
		)
		(or #col (setq #col 1))
		(setq #col 
			(cond
				((getint (strcat...
>>

Trau chuốt tí sau khi "được ném đá" :D

 

;Bai tap chuong 10.3
;;Bai 1:
(defun c:CIRCLEBOX( / ss i ename info cen r xc yc Rve BL BR TL TR)
(prompt "\nChon duong tron: ")
(setq ss (ssget '((0 . "CIRCLE"))))
(if ss
	(progn
		(or #offset (setq #offset 0.0))
		(setq #offset 
			(cond
				((getreal (strcat "\nKhoang offset <" (rtos #offset) ">:")))
				(#offset)
			)
		)
		(or #col (setq #col 1))
		(setq #col 
			(cond
				((getint (strcat "\nMau bounding box <" (itoa #col) ">:")))
				(#col)
			)
		)
		(setq i -1)
		(repeat (sslength ss)
			(setq ename (ssname ss (setq i (1+ i)))
				  info (entget ename)
				  cen (cdr (assoc 10 info))
				  r (cdr (assoc 40 info))
				  xc (car cen)
				  yc (cadr cen)
				  Rve (+ r #offset)
				  BL (list (- xc Rve) (- yc Rve))
				  BR (list (+ xc Rve) (- yc Rve))
				  TL (list (- xc Rve) (+ yc Rve))
				  TR (list (+ xc Rve) (+ yc Rve))
			)
			(grdraw BL BR #col 1)
			(grdraw BL TL #col 1)
			(grdraw TR TL #col 1)
			(grdraw TR BR #col 1)
		)	;repeat
	)
)
(princ)
)
;==========================================================================================
;;Bai 2:
(defun c:GRC( / cen r i j pt lst_pt pt1 pt2)
(setq
	cen (getpoint "\nChon tam: ")
	r (getdist "\nNhap ban kinh: ")
	)
(if (and cen r)
	(progn
		(setq i 0)
		(repeat 361
			(setq pt (polar cen (* pi (/ i 180.0)) r)
				  lst_pt (cons pt lst_pt)
				  i (1+ i)
			)
		)	;repeat
		(setq j 0)
		(repeat 360
			(setq pt1 (nth j lst_pt)
				  pt2 (nth (setq j (1+ j)) lst_pt)
			)
			(grdraw pt1 pt2 200 1)
		)
		(princ)
	)
)
)
;==============================================================================================
;;Bai 3:
;3_1:
(defun c:CB2( / ss i ename info cen r xc yc Rve BL BR TL TR)
(prompt "\nChon duong tron: ")
(setq ss (ssget '((0 . "CIRCLE"))))
(if ss
	(progn
		(or #offset (setq #offset 0.0))
		(setq #offset 
			(cond
				((getreal (strcat "\nKhoang offset <" (rtos #offset) ">:")))
				(#offset)
			)
		)
		(or #col (setq #col 2))
		(setq #col 
			(cond
				((getint (strcat "\nMau bounding box <" (itoa #col) ">:")))
				(#col)
			)
		)
		(setq i -1)
		(repeat (sslength ss)
			(setq ename (ssname ss (setq i (1+ i)))
				  info (entget ename)
				  cen (cdr (assoc 10 info))
				  r (cdr (assoc 40 info))
				  xc (car cen)
				  yc (cadr cen)
				  Rve (+ r #offset)
				  BL (list (- xc Rve) (- yc Rve))
				  BR (list (+ xc Rve) (- yc Rve))
				  TL (list (- xc Rve) (+ yc Rve))
				  TR (list (+ xc Rve) (+ yc Rve))
			)
			(grvecs (list #col BL BR BR TR TR TL TL BL))
		)	;repeat
	)
)
(princ)
)
;==============================
;3_2:
(defun c:GRC2( / cen r i pt lst_pt lst)
(setq
	cen (getpoint "\nChon tam: ")
	r (getdist "\nNhap ban kinh: ")
	)
(if (and cen r)
	(progn
		(setq i 0)
		(repeat 361
			(setq pt (polar cen (* pi (/ i 180.0)) r)
				  lst_pt (cons pt lst_pt)
				  i (1+ i)
			)
		)	;repeat
		(setq lst (cdr (reverse (cdr (apply 'append (mapcar '(lambda (x) (cons x (list x))) lst_pt))))))
		(grvecs (cons 3 lst))
		(princ)
	)
)
)
;=========================================================================================================
;;Bai 4:
(grtext -1 (strcat "Hello " (getvar 'loginname) " !"))

<<

Filename: 313631_circlebox_grc_cb2_grc2.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 323694
Tên lệnh: ha3
nhờ viết lisp vẽ đồ thị trên cad số liệu được lấy từ file excel

Tặng chủ topic cái này, mới viết xong. Hy vọng hài lòng.

;Doan Van Ha - CADViet.com - Ngay 24/11/2014
;Muc dich: Ve Spline qua cac diem duoc ghi trong file txt (moi hang la 1 diem, X va Y cach nhau boi 1 ky tu tab; ve duong dong; ghi text cao do duong duoi am tren).
(defun C:HA3( / fn ss pr rl txt pt pd lst)
 (command "ucs" "w") (command "undo" "be")
 (setq fn (getfiled "Chon file de lay so lieu" "" "txt" 8))
 (or (and tlx...
>>

Tặng chủ topic cái này, mới viết xong. Hy vọng hài lòng.

;Doan Van Ha - CADViet.com - Ngay 24/11/2014
;Muc dich: Ve Spline qua cac diem duoc ghi trong file txt (moi hang la 1 diem, X va Y cach nhau boi 1 ky tu tab; ve duong dong; ghi text cao do duong duoi am tren).
(defun C:HA3( / fn ss pr rl txt pt pd lst)
 (command "ucs" "w") (command "undo" "be")
 (setq fn (getfiled "Chon file de lay so lieu" "" "txt" 8))
 (or (and tlx (or (= (type tlx) 'int) (= (type tlx) 'real))) (setq tlx 200))
 (setq tlx (cond ((getreal (strcat "\nTi le theo phuong X <" (rtos tlx 2 0) ">: "))) (tlx)))
 (or (and tly (or (= (type tly) 'int) (= (type tly) 'real))) (setq tly 5000))
 (setq tly (cond ((getreal (strcat "\nTi le theo phuong Y <" (rtos tly 2 0) ">: "))) (tly)))
 (or (and hei (or (= (type hei) 'int) (= (type hei) 'real))) (setq hei 0.10))
 (setq hei (cond ((getreal (strcat "\nChieu cao chu <" (rtos hei 2 2) ">: "))) (hei)))
 (setq ss (ssadd))
 (setq pr (open fn "r"))
 (while (setq rl (read-line pr))
  (setq txt (HA:str->lst rl (chr 9)))
  (setq pt (list (/ (car txt) tlx) (/ (cadr txt) tly)))
  (setq pd (list (/ (car txt) tlx) 0))
  (MakeLine pd pt 5)
  (ssadd (entlast) ss)
  (if (>= (cadr txt) 0)
   (MakeText (polar pd (/ pi -2) hei) (rtos (cadr txt) 2 0) hei 2 "MR")
   (MakeText (polar pd (/ pi 2) hei) (rtos (cadr txt) 2 0) hei 2 "ML"))
  (ssadd (entlast) ss)
  (setq lst (cons pt lst)))
 (close pr)
 (MakeSpline (reverse lst) 1)
 (ssadd (entlast) ss)
 (MakeLine (list (cadr (last lst)) 0) (list (caar lst) 0) 3)
 (ssadd (entlast) ss)
 (command "move" ss "" (list (cadr (last lst)) 0) pause)
 (command "undo" "e") (princ))
;----- String to List, EX: (HA:str->lst "1,2,3,4,5" ",") => (1 2 3 4 5)
(defun HA:str->lst ( str del / pos )
 (if (setq pos (vl-string-search del str))
  (cons (atof (substr str 1 pos)) (HA:str->lst (substr str (+ pos 1 (strlen del))) del)) 
  (list (atof str))))
(defun MakeSpline (lst col)
 (entmake (append (list '(0 . "SPLINE") '(100 . "AcDbEntity") (cons 62 col) '(100 . "AcDbSpline") (cons 71 3) (cons 74 (length lst))) (mapcar '(lambda (p) (cons 11 p)) lst))))
(defun MakeLine (p1 p2 col)
 (entmake (list (cons 0 "LINE") (cons 62 col) (cons 10 p1) (cons 11 p2))))
(defun MakeText (pt str hei col jus / lst)
 (setq lst (list '(0 . "TEXT") (cons 62 col) (cons 10 pt) (cons 40 hei) (cons 1 str) (cons 50 (/ pi 2))))
 (cond
  ((= jus "ML") (setq lst (append lst (list (cons 72 0) (cons 11 pt) (cons 73 2)))))
  ((= jus "MR") (setq lst (append lst (list (cons 72 2) (cons 11 pt) (cons 73 2))))))
 (entmake lst))
 

<<

Filename: 323694_ha3.lsp
Tác giả: thehost31
Bài viết gốc: 323905
Tên lệnh: wt
{Cần giúp đỡ} Lisp nối text cao độ, giữ nguyên tọa độ điểm chèn cũ là circle

Bạn dùng thử Lisp sau nhé. Không cần phá, để nguyên Att Block.

Lệnh: wt

 

 

 

(defun Read_bl-pt(bl / sslist eni enlist ih dh)
(setq sslist (entget bl))
(if (= (cdr (assoc 66 sslist)) 1)
(progn
(setq eni (entnext bl))
(setq enlist (entget eni))
(while (/= (cdr (assoc 0 enlist)) "SEQEND")
(if (AND (= (cdr (assoc 0 enlist)) "ATTRIB") (= (cdr (assoc 2 enlist)) "IH"))
(setq ht (cdr (assoc 40 enlist))
ih (cdr...

>>

Bạn dùng thử Lisp sau nhé. Không cần phá, để nguyên Att Block.

Lệnh: wt

 

 

 

(defun Read_bl-pt(bl / sslist eni enlist ih dh)
(setq sslist (entget bl))
(if (= (cdr (assoc 66 sslist)) 1)
(progn
(setq eni (entnext bl))
(setq enlist (entget eni))
(while (/= (cdr (assoc 0 enlist)) "SEQEND")
(if (AND (= (cdr (assoc 0 enlist)) "ATTRIB") (= (cdr (assoc 2 enlist)) "IH"))
(setq ht (cdr (assoc 40 enlist))
ih (cdr (assoc 1 enlist))
)
)
(if (AND (= (cdr (assoc 0 enlist)) "ATTRIB") (= (cdr (assoc 2 enlist)) "DH"))
(setq dh (cdr (assoc 1 enlist)))
)
(setq eni (entnext eni))
(setq enlist (entget eni))
)
)
)
(list ih dh)
)

(defun AddText(string point height / mspace text)
(vl-load-com)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq text (vla-AddText mspace string (vlax-3d-point point) height))
)

(defun Join_List(li)
(if (and (car li) (cadr li))
(strcat (car li) "." (cadr li))
(strcat (car li) ".00")
)
)

(defun c:wt(/ ssx si ssi str_out)
(command ".undo" "be")
(setq ssx (ssget '((0 . "INSERT") (2 . "bl-pt"))))
(setq si 0)
(while (< si (sslength ssx))
(setq ssi (ssname ssx si))
(setq str_out (JOIN_LIST (READ_BL-PT ssi)))
(ADDTEXT str_out (cdr (assoc 10 (entget ssi))) ht)
(vla-delete (vlax-ename->vla-object ssi))
(setq si (1+ si))
)
(command ".undo" "e")
(princ)
(princ)
)


<<

Filename: 323905_wt.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 324121
Tên lệnh: roo
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
(defun c:roo(/ doigoc start end dt db dh dg goc tt ent lst px pg)
;====================================================
(defun start()
(setq osmodeold (getvar "osmode")
      cmdechoold (getvar "cmdecho")
	  angdirold (getvar "angdir")
	  angbaseold (getvar "angbase")
	  )
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setvar "angbase" (/ pi 2.0))
(setvar "angdir" 1)

)
;=======================================================
(defun end()
(setvar "osmode"...
>>
(defun c:roo(/ doigoc start end dt db dh dg goc tt ent lst px pg)
;====================================================
(defun start()
(setq osmodeold (getvar "osmode")
      cmdechoold (getvar "cmdecho")
	  angdirold (getvar "angdir")
	  angbaseold (getvar "angbase")
	  )
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setvar "angbase" (/ pi 2.0))
(setvar "angdir" 1)

)
;=======================================================
(defun end()
(setvar "osmode" osmodeold)
(setvar "cmdecho" cmdechoold)
(setvar "angdir" angdirold)
(setvar "angbase" angbaseold)
(setq osmodeold nil
      cmdechoold nil
	  angdirold nil
	  angbaseold nil
	  )
)
;=======================================================	  
 (vl-load-com)                                                    
	                         (princ "Chon Doi Tuong Can Quay: ")							 
                             (setq dt (ssget)
							       db (getpoint "\nChon BasePoint:")
							       tt (entsel "\nChon doi duong tam tau: ")
                                  ent (car tt)
                                  lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (or (= (car x) 10) (= (car x) 11))) (entget ent))))
							 (start )
                             (if (< (distance db (setq px (car lst))) (distance db (setq pg (cadr lst))))					 
							 (command ".rotate" dt "" db "r" px pg )  							 
                             (command ".rotate" dt "" db "r" pg px ) 							 
							 );end if			 
(end )
)	  

Các bác ơi em viết lại đoạn code để quay như trên, mục đích của em là đặt biến hệ thống lại để quay theo ý mình (angbase và angdir). Có chút rắc rối ở đây là khi viết hàm con (end ) ngay sau lệnh "rotate"  thì nó thực hiện hàm end này trước khi mình nhập góc vào, làm cho hàm (start ) viết ở trên trở nên công cốc. Em mày mò mãi mà chưa giải quyết được vấn đề này, các bác cho em chút ý kiến được không.


<<

Filename: 324121_roo.lsp
Tác giả: hiepttr
Bài viết gốc: 324162
Tên lệnh: roo
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

:D :D :D

Tất cả là của bạn !

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/14210-hoi-ve-lisp-thuat-toan-y-tuong-coding/page-111
(defun c:roo(/ doigoc start end dt db dh dg goc tt ent lst px pg)
;====================================================
(defun start()
(setq osmodeold (getvar "osmode")
      cmdechoold (getvar "cmdecho")
	  angdirold (getvar "angdir")
	  angbaseold (getvar...
>>

:D :D :D

Tất cả là của bạn !

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/14210-hoi-ve-lisp-thuat-toan-y-tuong-coding/page-111
(defun c:roo(/ doigoc start end dt db dh dg goc tt ent lst px pg)
;====================================================
(defun start()
(setq osmodeold (getvar "osmode")
      cmdechoold (getvar "cmdecho")
	  angdirold (getvar "angdir")
	  angbaseold (getvar "angbase")
	  )
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setvar "angbase" (/ pi 2.0))
(setvar "angdir" 1)

)
;=======================================================
(defun end()
(setvar "osmode" osmodeold)
(setvar "cmdecho" cmdechoold)
(setvar "angdir" angdirold)
(setvar "angbase" angbaseold)
(setq osmodeold nil
      cmdechoold nil
	  angdirold nil
	  angbaseold nil
	  )
)
;=======================================================	  
 (vl-load-com)                                                    
	                         (princ "Chon Doi Tuong Can Quay: ")							 
                             (setq dt (ssget)
							       db (getpoint "\nChon BasePoint:")
							       tt (entsel "\nChon doi duong tam tau: ")
                                  ent (car tt)
                                  lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (or (= (car x) 10) (= (car x) 11))) (entget ent))))
							 (start )
                             (if (< (distance db (setq px (car lst))) (distance db (setq pg (cadr lst))))					 
							 (command ".rotate" dt "" db "r" px pg pause)  							 
                             (command ".rotate" dt "" db "r" pg px pause) 							 
							 );end if			 
(end)
) 

<<

Filename: 324162_roo.lsp
Tác giả: nhoclangbat
Bài viết gốc: 324242
Tên lệnh: ckc
LISP tự động cộng liên tiếp khoảng cách giữa các điểm bất kỳ

- oh vậy là hơi giống bên nhoc ^^, 2 điểm = 100 bạn đó nói chắc đc phóng lên theo tile 1/500 rùi tương đương 2lần , giờ bạn ấy mún đo lấy kích thước thật = 50 tương đương tile 1/1000, nhoc nghĩ vậy ko biết đúg ko ^^

- bạn thử xem

(defun c:ckc(/ po1 po2 oldim tp S te ent x)
(setq oldim (getvar "DIMZIN"))
(setvar "DIMZIN" 0)
(setq ttl (getvalueK ttl 500.0 "Nhap ti le ban ve 1 / "))
(setq...
>>

- oh vậy là hơi giống bên nhoc ^^, 2 điểm = 100 bạn đó nói chắc đc phóng lên theo tile 1/500 rùi tương đương 2lần , giờ bạn ấy mún đo lấy kích thước thật = 50 tương đương tile 1/1000, nhoc nghĩ vậy ko biết đúg ko ^^

- bạn thử xem

(defun c:ckc(/ po1 po2 oldim tp S te ent x)
(setq oldim (getvar "DIMZIN"))
(setvar "DIMZIN" 0)
(setq ttl (getvalueK ttl 500.0 "Nhap ti le ban ve 1 / "))
(setq x (/ 1000.0 ttl))
(if (not tpo) (setq tpo 0))
(setq tp (getint (strcat "\n So chu so thap phan <" (rtos tpo 2 0) ">:")))
(if (not tp) (setq tp tpo) (setq tpo tp))
(setq po1 (getpoint "\n Pick diem dau :"))

(while
(setq po2
(getpoint po1 "\n Pick diem tiep theo de tinh khoang cach/ Enter de ket thuc :"))
(setq S (/ (distance po1 po2) x) po1 po2)
(while (null (setq ent (entsel "\n Pick vao TEXT :")))
(setq ent (entsel "\n Pick lai vao TEXT :"))
)
(setq te (entget (car ent)))
(setq te (entmod(subst(cons 1 (rtos S 2 tp)) (assoc 1 te) te)))
)
(setvar "DIMZIN" oldim)
(princ)
)
;===
;; ham luu gia tri
(defun getvalueK ( a giatri dongnhac / astr) 
(or a (setq a giatri))
(cond
	((= (type a) 'INT) (setq a (cond ((getint (strcat "\n" dongnhac "(" (itoa a) ") :")))(a))))
	((= (type a) 'REAL) (setq a (cond ((getreal (strcat "\n" dongnhac "(" (rtos a 2 1) ") :")))(a))))
	((= (type a) 'STR) (setq a (cond ((= "" (setq astr (getstring T (strcat "\n" dongnhac " (" a "): ")))) a) (astr))))
))
;;;;

<<

Filename: 324242_ckc.lsp
Tác giả: ketxu
Bài viết gốc: 323736
Tên lệnh: test
Bài tập chương 4.1

Thì phải bẫy lỗi ở hàm *error*

Bạn thích tìm hiểu trước thì có thể tìm từ khóa này ở diễn đàn

Mình để 1 ví dụ nhỏ khi thay đổi biến hệ thống, người dùng cố tình Esc trước khi hàm end được gọi

(defun c:test(/ *error* start end ov vars)
	(setq vars '(osmode pickbox cursorsize))
	(defun start()
		(setq ov (mapcar 'getvar vars))
		(mapcar 'setvar vars '(0 7 10))
	)
	(defun...
>>

Thì phải bẫy lỗi ở hàm *error*

Bạn thích tìm hiểu trước thì có thể tìm từ khóa này ở diễn đàn

Mình để 1 ví dụ nhỏ khi thay đổi biến hệ thống, người dùng cố tình Esc trước khi hàm end được gọi

(defun c:test(/ *error* start end ov vars)
	(setq vars '(osmode pickbox cursorsize))
	(defun start()
		(setq ov (mapcar 'getvar vars))
		(mapcar 'setvar vars '(0 7 10))
	)
	(defun end()(and ov (mapcar 'setvar vars ov)))	
	(defun *error* (msg)
		(end)
		(princ msg)(alert "WTF. Tai sao k pick ma lai an Esc >'<")		
	)
	
	(start)
	(getpoint "\nPick di, dung an Esc :")
	(end)
)

<<

Filename: 323736_test.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 324486
Tên lệnh: ha
Lisp vẽ trục trọng tâm của chi tiết đột cắt hình

Lisp vẽ trọng tâm của hình rỗng (hình khoét lỗ).

; Doan Van Ha - CadViet.com - ngay 29/11/2014
; Chuc nang: lay trong tam cua 1 hinh rong (hinh rong bao gom 1 duong bien ngoai va cac duong ben trong, duoc tao boi cac "Polyline,Lwpolyline,Spline,Circle,Ellipse,Line,Arc").
; Ve 2 duong truc X va Y.
(defun C:HA(/ GetNewEnts ss ent lst emax smax ll ur ssum xtt ytt)
 (vl-load-com) (command "undo" "be")
 (defun GetNewEnts (ent /...
>>

Lisp vẽ trọng tâm của hình rỗng (hình khoét lỗ).

; Doan Van Ha - CadViet.com - ngay 29/11/2014
; Chuc nang: lay trong tam cua 1 hinh rong (hinh rong bao gom 1 duong bien ngoai va cac duong ben trong, duoc tao boi cac "Polyline,Lwpolyline,Spline,Circle,Ellipse,Line,Arc").
; Ve 2 duong truc X va Y.
(defun C:HA(/ GetNewEnts ss ent lst emax smax ll ur ssum xtt ytt)
 (vl-load-com) (command "undo" "be")
 (defun GetNewEnts (ent / obj tt new)
  (while (setq ent (entnext ent))
   (setq obj (vlax-ename->vla-object ent) tt (vlax-get obj 'Centroid) new (cons (list obj (vlax-get obj 'Area) (car tt) (cadr tt)) new)))
  new)
 (princ "\nChon nhom doi tuong tao thanh hinh can lay trong tam: ")
 (setq ss (ssget '((0 . "Polyline,Lwpolyline,Spline,Circle,Ellipse,Line,Arc"))))
 (setq ent (entlast))
 (command "region" ss "")
 (setq lst (vl-sort (GetNewEnts ent) '(lambda(e1 e2) (> (cadr e1) (cadr e2)))))
 (setq emax (caar lst) smax (cadar lst)) 
 (vla-getboundingbox emax 'll 'ur)
 (setq ll (vlax-safearray->list ll) ur (vlax-safearray->list ur))
 (setq ssum (apply '+ (mapcar '(lambda(x) (if (equal (cadr x) smax 1E-8) (cadr x) (* -1 (cadr x)))) lst)))
 (setq xtt (/ (apply '+ (mapcar '(lambda(x) (* (if (equal (cadr x) smax 1E-8) (cadr x) (* -1 (cadr x))) (caddr x))) lst)) ssum))
 (setq ytt (/ (apply '+ (mapcar '(lambda(x) (* (if (equal (cadr x) smax 1E-8) (cadr x) (* -1 (cadr x))) (cadddr x))) lst)) ssum))
 (command "u")
 (entmake (list '(0 . "Line") (cons 8 "HA_Truc") (cons 62 1) (cons 10 (list (car ll) ytt)) (cons 11 (list (car ur) ytt))))
 (entmake (list '(0 . "Line") (cons 8 "HA_Truc") (cons 62 1) (cons 10 (list xtt (cadr ll))) (cons 11 (list xtt (cadr ur)))))
 (command "undo" "e") (princ))
 

<<

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

Chẳng hạn bạn sửa lại như thế này:

(defun c:roo(/ doigoc start end *error* vars ovars nvars dt db dh dg tt ent lst px pg)
 (defun doigoc(goc)
  (rem (- 450.0 goc) 360.0))
 (defun start()
  (setq vars '("osmode" "cmdecho" "angdir" "angbase"))
  (setq ovars (mapcar 'getvar vars)
        nvars (mapcar 'setvar vars (list 0 0 1 (/ pi 2)))))
 (defun end()
  (and ovars (mapcar 'setvar vars ovars)))
 (defun *error* (ABC)
 ...
>>

Chẳng hạn bạn sửa lại như thế này:

(defun c:roo(/ doigoc start end *error* vars ovars nvars dt db dh dg tt ent lst px pg)
 (defun doigoc(goc)
  (rem (- 450.0 goc) 360.0))
 (defun start()
  (setq vars '("osmode" "cmdecho" "angdir" "angbase"))
  (setq ovars (mapcar 'getvar vars)
        nvars (mapcar 'setvar vars (list 0 0 1 (/ pi 2)))))
 (defun end()
  (and ovars (mapcar 'setvar vars ovars)))
 (defun *error* (ABC)
  (end))
 (vl-load-com) 
 (princ "Chon Doi Tuong Can Quay: ") 
 (setq dt (ssget)
       db (getpoint "\nChon BasePoint:")
       tt (entsel "\nChon doi duong tam tau: ")
       ent (car tt)
       lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (or (= (car x) 10) (= (car x) 11))) (entget ent))))
 (command "undo" "be")    
 (start)
 (if (< (distance db (setq px (car lst))) (distance db (setq pg (cadr lst))))
  (progn 
   (princ (strcat "\nNhap Phuong Vi <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle px pg))) 2 2) ">:")) 
   (command ".rotate" dt "" db "r" px pg pause))
  (progn 
   (princ (strcat "\nNhap Phuong Vi <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle pg px))) 2 2) ">:")) 
   (command ".rotate" dt "" db "r" pg px pause)))
 (end)
 (command "undo" "e")) 
 

<<

Filename: 324510_roo.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 287641
Tên lệnh: ha
Lisp nối Line thành Pline ?

Cái này đổi UCS mọi đối tượng có DXF 210 là (210 0 0 -1):

(defun C:HA ( / ss)
 (if (setq ss (ssget (list '(210 0 0 -1))))
  (command "ucs" "3p" (trans '(0 0 0) 0 1) (trans '(0 1 0) 0 1) (trans '(0 0 1) 0 1) "mirror" ss "" '(0 0 0) '(1 0 0) "y" "ucs" "p")))
 


Filename: 287641_ha.lsp
Tác giả: nhoclangbat
Bài viết gốc: 324563
Tên lệnh: roo
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

- hi Chạy trước nhọc chưa hì ^^, khống chế giá trị nhập để đưa vào command nhoc thì chưa nghĩ ra cách nào khác ngoài cách đưa thêm biến phụ nhập góc vào ^^, còn pick điểm thì initget khống chế đc, initget theo nhoc biết thì chưa không chế đc khoảng nhập vào nên dùng vòng lặp tới khi nào thỏa thì ok, Hieu thử xem ^^

(defun c:roo(/ doigoc start end *error* vars ovars nvars dt...
>>

- hi Chạy trước nhọc chưa hì ^^, khống chế giá trị nhập để đưa vào command nhoc thì chưa nghĩ ra cách nào khác ngoài cách đưa thêm biến phụ nhập góc vào ^^, còn pick điểm thì initget khống chế đc, initget theo nhoc biết thì chưa không chế đc khoảng nhập vào nên dùng vòng lặp tới khi nào thỏa thì ok, Hieu thử xem ^^

(defun c:roo(/ doigoc start end *error* vars ovars nvars dt db dh dg tt ent lst px pg p_vii)
 (defun doigoc(goc)
  (rem (- 450.0 goc) 360.0))
 (defun start()
  (setq vars '("osmode" "cmdecho" "angdir" "angbase"))
  (setq ovars (mapcar 'getvar vars)
        nvars (mapcar 'setvar vars (list 0 0 1 (/ pi 2)))))
 (defun end()
  (and ovars (mapcar 'setvar vars ovars)))
 (defun *error* (ABC)
  (end))
 (vl-load-com) 
 (princ "Chon Doi Tuong Can Quay: ") 
 (setq dt (ssget)
       db (getpoint "\nChon BasePoint:")
       tt (entsel "\nChon doi duong tam tau: ")
       ent (car tt)
       lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (or (= (car x) 10) (= (car x) 11))) (entget ent))))
 (command "undo" "be")    
 (start)
 (if (< (distance db (setq px (car lst))) (distance db (setq pg (cadr lst))))
  (progn 
   (princ (strcat "\nGoc Phuong Vi hien tai <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle px pg))) 2 2) ">"))
   (setq p_vii (getreal "\nNhap goc phuong vi:"))
   (while (> p_vii 180.0)
   (setq p_vii (getreal "\nNhap goc phuong vi:")))
   (command ".rotate" dt "" db "r" px pg p_vii)
   )
  (progn 
   (princ (strcat "\nGoc Phuong Vi hien tai <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle pg px))) 2 2) ">"))
    (setq p_vii (getreal "\nNhap goc phuong vi:"))
   (while (> p_vii 180.0)
   (setq p_vii (getreal "\nNhap goc phuong vi:")))   
   (command ".rotate" dt "" db "r" pg px p_vii)
   )
   )
 (end)
 (command "undo" "e"))

- nhoc quên chưa chỉnh khống chế cho thằng db Hieu tự xử hen ^^

-p/s:nhoc chưa hiểu cái biến tt là gì ^^


<<

Filename: 324563_roo.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 324602
Tên lệnh: roo
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

E đã thử delete theo ý bác Hà mà không thành công, chắc tại không hiểu ý. Mà em muốn chọn phương cần quay chỉ pick vào 2 điểm chứ không phải pick vào đường thẳng ạ, vì nhiêu khi phương cần quay không phải là đường thẳng mà chỉ là 2 điểm thôi ạ. Bác Hà chỉ rõ hơn cho em với, em không biết nhiều về lisp ạ!...

>>

E đã thử delete theo ý bác Hà mà không thành công, chắc tại không hiểu ý. Mà em muốn chọn phương cần quay chỉ pick vào 2 điểm chứ không phải pick vào đường thẳng ạ, vì nhiêu khi phương cần quay không phải là đường thẳng mà chỉ là 2 điểm thôi ạ. Bác Hà chỉ rõ hơn cho em với, em không biết nhiều về lisp ạ! Thank bác. 

(defun c:roo(/ dt db tt )
 (princ "Chon Doi Tuong Can Quay: ") 
 (setq dt (ssget)
       db (getpoint "\nChon BasePoint:")
       tt (getpoint "\nChon Diem Dinh Huong: ") )
   (command ".rotate" dt "" "non" db "r" "non" db "non" tt pause)
) 

Của bạn đây. 


<<

Filename: 324602_roo.lsp

Trang 183/330

183