Jump to content
InfoFile
Tác giả: Tue_NV
Bài viết gốc: 159730
Tên lệnh: 1
Edit lần lượt nhiều *Text

Hôm trước có bạn quay video edit lần lượt các Text (mà hỏi viết bằng ngôn ngữ gì không nói :wacko: ), cũng có bạn yêu cầu, ketxu post cái...

>>

Hôm trước có bạn quay video edit lần lượt các Text (mà hỏi viết bằng ngôn ngữ gì không nói :wacko: ), cũng có bạn yêu cầu, ketxu post cái đơn giản viết bằng Lisp mà ketxu vẫn dùng, bác nào thiếu thì lấy về xài chơi.

Text sẽ được edit theo thứ tự từ trái sang phải, từ trên xuống dưới

 

(defun c:1 (/ selset ST:Text-Base)
(grtext -1 "Free from Cadviet.com @ketxu")
 (defun ST:Text-Base (ent)
   (if (/= (cdr (assoc 72 (entget ent))) 0)
     (cdr (assoc 11 (entget ent)))
     (cdr (assoc 10 (entget ent)))
     );_ end of if
   );_ end of defun
 (if (setq selset (ssget "_:L" '((0 . "*TEXT"))))
   (foreach txt             
              (vl-sort
                (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
                '(lambda (a B)
                   (< (car (ST:Text-Base a))(car (ST:Text-Base B)))                    
                   (> (cadr (ST:Text-Base a)) (cadr (ST:Text-Base B)))
                 );_ end of lambda
              );_ end of vl-sort
     (command "_.ddedit" txt "")
     );_ end of foreach
   );_ end of if
 )

Không áp dụng với Rtext ^^

 

Srr : ket vừa tìm thấy topic trùng chức năng, xin phép gộp lại. Lisp của bác bemove post có chức năng tương tự nhưng rộng hơn, áp dụng cả với ATT, TOL, DIM nhưng theo thứ tự chọn (hoặc thứ tự text được tạo)

1. Lisp ở bài đầu tiên không phải của bác Bemove...

2. Cả 2 Lisp đều có điểm chưa hay : Là khi chọn 1 số Text nào đó -> Muốn thoát ra khỏi vòng lặp ngay tại Text muốn sửa thì không được. Phải enter cho hết số đối tượng Text thì mói thoát được.

 

Cái chưa hay nữa là : Khi sửa nhầm Text nào đó muốn undo ngay lại vị trí lúc đó để sửa cũng không được. Đành Enter cho hết cái lệnh cái đã rồi mới sửa được

 

Hề, chắc là "Chưa xong" đâu nhỉ?? :lol:


<<

Filename: 159730_1.lsp
Tác giả: Hung_EL
Bài viết gốc: 416071
Tên lệnh: ctg
Sửa định dạng font trong MTEXT

Thachphathien sử dụng code này thử nhé :

 

(defun c:ctg(/ doc sset chuoi vitri)
;copyright by Tue_NV
(setq ss...
>>

Thachphathien sử dụng code này thử nhé :

 

(defun c:ctg(/ doc sset chuoi vitri)
;copyright by Tue_NV
(setq ss (ssget '((0 . "*TEXT"))))
(vl-load-com)
(setq doc (vla-get-activedocument(vlax-get-acad-object)))
(defun pos (sub st / l1 l2 index)
;Thank Mr Hoanh for this function
(setq index 1
l1 (strlen sub)
l2 (strlen st)
)
(while
(and (<= (+ index l1 -1) l2) (/= sub (substr st index l1)))
(setq index (1+ index))
)
(if (= sub (substr st index l1))
index
nil
)
);;;end defun POS
;;;Main function
(vlax-for x (setq sset (vla-get-activeselectionset doc))
(setq chuoi (vla-get-textstring x))
(setq vitri (1+ (pos ";" chuoi)))
(vla-put-textstring x (substr chuoi vitri (- (strlen chuoi) vitri)))
)
(vla-delete sset)
(princ)
)

Lỗi: sau khi dùng lisp chuỗi mất kỹ tự cuối cùng. mình ko biết sửa...


<<

Filename: 416071_ctg.lsp
Tác giả: namhai
Bài viết gốc: 66325
Tên lệnh: invis
Thắc mắc về Layoff, layiso?
Mạn phép bác Bemove, Tue_NV sửa lại code của bác cho phù hợp với yêu cầu của bạn NamHai

(defun c:InVis (/ SSet Count Elem dt lay entt) 
 (defun Dxf (Id Obj)
(cdr...
>>
Mạn phép bác Bemove, Tue_NV sửa lại code của bác cho phù hợp với yêu cầu của bạn NamHai

(defun c:InVis (/ SSet Count Elem dt lay entt) 
 (defun Dxf (Id Obj)
(cdr (assoc Id (entget Obj)))
 );end Dxf
(setq dt (entsel "\n Pick chon Layer an di :"))
(setq entt (car dt))
(setq lay (cdr(assoc 8 (entget entt))))
  (prompt "\n Chon vung can an di :")
 (cond
((setq SSet (ssget (list(cons 8 lay))))
 (repeat (setq Count (sslength SSet))
   (setq Count (1- COunt)
	 Elem (ssname SSet Count))
   (if (/= 4 (logand 4 (Dxf 70 (tblobjname "layer" (Dxf 8 Elem)))))
 (if (Dxf 60 Elem)
   (entmod (subst '(60 . 1) (assoc 60 (entget Elem)) (entget Elem)))
   (entmod (append (entget Elem) (list '(60 . 1))))
 )
 (prompt "\nEntity on a locked layer. Cannot hide this entity. ")
   );end if
 );end repeat
)	 	
 );end cond

 (princ)
);end c:InVis

@gp14 : Ý của NamHai là ẩn các đối tượng thuộc về 1 layer nào đó trong vùng mà ta chọn

Thanks bác Tue_NV nhiều nha!đây đúng là điều mà e cần, chúc bác ngày cuối tuần vui vẻ!!! :s_big:


<<

Filename: 66325_invis.lsp
Tác giả: namhai
Bài viết gốc: 66332
Tên lệnh: anlay
Thắc mắc về Layoff, layiso?

Lisp trên chỉ ẩn được 1 Layer trong vùng chọn

Với Lisp này thì bạn cần hơn nè :

Đây là Lisp ANLAY. Sự kết hợp Lisp của Tue_NV và bác Bemove có tính năng ẩn

>>
Lisp trên chỉ ẩn được 1 Layer trong vùng chọn

Với Lisp này thì bạn cần hơn nè :

Đây là Lisp ANLAY. Sự kết hợp Lisp của Tue_NV và bác Bemove có tính năng ẩn các Layer được user chọn nằm trong vùng chọn. Bạn chạy thử xem :

;copyright by Tue_NV and Bemove
(defun c:anlay(/ vung lstlay n dt ent enti ss ss1 i)
(setq lstlay nil)
(prompt "\n chon vung :")
(setq vung (ssget) n (sslength vung) ss (ssadd) i 0)
(setq dt (entsel"\n Pick chon Layer :"))
(if dt
(progn
(while dt 
(setq ent (car dt))

(setq lay (cdr(assoc 8 (entget ent))))
(if (= (member lay lstlay) nil)
(setq lstlay (append lstlay (list lay)))
(ALERT "Da chon layer nay roi. Moi ban chon doi tuong thuoc Layer khac :")
)
(setq dt (entsel"\n Pick chon Layer :"))
)
)
)

(while (< i n)
(setq enti (ssname vung i))
(setq elay (cdr(assoc 8 (entget enti))))
(if (/= (member elay lstlay) nil)
(setq ss (ssadd enti ss))
)
(setq i (1+ i))
)
(INVIS ss)
(princ)
)
;
;
(defun InVis (SSet / Count Elem)

 (defun Dxf (Id Obj)
   (cdr (assoc Id (entget Obj)))
 );end Dxf


 (cond
(
    (repeat (setq Count (sslength SSet))
      (setq Count (1- COunt)
     Elem (ssname SSet Count))
      (if (/= 4 (logand 4 (Dxf 70 (tblobjname "layer" (Dxf 8 Elem)))))
 (if (Dxf 60 Elem)
   (entmod (subst '(60 . 1) (assoc 60 (entget Elem)) (entget Elem)))
   (entmod (append (entget Elem) (list '(60 . 1))))
 )
 (prompt "\nEntity on a locked layer. Cannot hide this entity. ")
      );end if
    );end repeat
   )	 	
 );end cond
 (princ)
);end c:InVis

:s_big:

Bác Tue_NV ơi!có phải đây là lisp xoá các layer trong 1 vùng không?vì lúc e ẩn layer đi thì khi layon không thây hiện lên các layer mà mình đã ẩn?


<<

Filename: 66332_anlay.lsp
Tác giả: tinya1225
Bài viết gốc: 151959
Tên lệnh: %2B%2B
Lisp chỉnh sửa nội dung text

1. Lisp này thì có ngoặc hay không, vẫn chạy tốt

2. Em đã phá tan tành cái lisp của anh

>>

1. Lisp này thì có ngoặc hay không, vẫn chạy tốt

2. Em đã phá tan tành cái lisp của anh ketxu rồi :P

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=43745&st=0&gopid=149909entry149909
(defun c:++(/ num kq oldvalue str dng ddt)
(setq num (getreal "\nS\U+1ED1 c\U+1EA7n c\U+1ED9ng th\U+00EAm :"))
(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT")))))))
(setq dng (vl-string-position (ascii ")") (setq str (vlax-get-property ent 'TextString)))) 
(if (= dng nil) (setq dng (strlen str)))
(setq kq (vl-string-subst 
(strcat " " (rtos (+ num (atof (setq oldvalue (substr str
	(+ 2 (setq ddt (vl-string-position (ascii "-") str))) (- dng ddt 1)))))
 2 (- (strlen oldvalue) (cond ((vl-string-position (ascii ".") oldvalue)) (T (1- (strlen oldvalue))))  1)))
oldvalue
str
))

(vlax-put-property ent 'TextString kq)))
(vl-load-com)

Cám ơn bạn nhiều nhé. Thanks + bạn rùi đó ^^.

@Ketxu bác ơi vì hôm trc bác nói ko thích string lắm, em đợi mấy hôm ko thấy bác reply nên mới viết thêm, mà bài cũ chẳng biết viết thêm vào cái j nên mới lập thêm 2pic. lần sau e sẽ chú ý hơn :rolleyes:

Mà bác bảo nhận lỗi với e sao ko cho em cái thanks + coi như tạ lỗi nhỉ :lol:

Chúc cả nhà 1 ngày vui vẻ :))


<<

Filename: 151959_%2B%2B.lsp
Tác giả: kaka105ht
Bài viết gốc: 199560
Tên lệnh: ha
Yêu cầu lisp chọn hàng loạt đối tượng text

Đây bạn!

(defun C:HA()
(sssetfirst nil (ssget '((0 . "*TEXT") (1 ....
>>

Đây bạn!

(defun C:HA()
(sssetfirst nil (ssget '((0 . "*TEXT") (1 . "~**")))))

ÔI NGON! THANKS BÁC NHÌU NHA :D


<<

Filename: 199560_ha.lsp
Tác giả: khanh10
Bài viết gốc: 420579
Tên lệnh: fff
Cách dùng lệnh fillet trong lisp?

Nhờ mấy bạn pro sữa giúp mình cái lisp này với: Khi mình chạy đến lệnh fillet thì bị lỗi không chạy được nữa. Cám ơn nhiều!

(defun c:fff (/ p d1 d2 d3 tm1 tm2)
(setq p (getpoint "\Chon diem dat:"))
(setq d1 (polar p (/ (* pi 90) 180) 1000))
(setq d2 (polar p 0 3000))
(setq d3 (polar d2 (/ (* pi 135) 180) 1000))
(command "line" p d1 "")
(setq tm1 (entlast))
(command...
>>

Nhờ mấy bạn pro sữa giúp mình cái lisp này với: Khi mình chạy đến lệnh fillet thì bị lỗi không chạy được nữa. Cám ơn nhiều!

(defun c:fff (/ p d1 d2 d3 tm1 tm2)
(setq p (getpoint "\Chon diem dat:"))
(setq d1 (polar p (/ (* pi 90) 180) 1000))
(setq d2 (polar p 0 3000))
(setq d3 (polar d2 (/ (* pi 135) 180) 1000))
(command "line" p d1 "")
(setq tm1 (entlast))
(command "line" d2 d3 "")
(setq tm2 (entnext tm1))
(command "fillet" "r" 0 tm1 tm2 )
(princ)
)

 


<<

Filename: 420579_fff.lsp
Tác giả: Danh Cong
Bài viết gốc: 403746
Tên lệnh: lee%C2%A0
Nhờ Nâng Cấp Lisp Dải Leader Tại Giao Điểm Của Các Đoạn Thẳng.

Em cám ơn ạ :)

Em tìm tòi học lisp mấy tuần,  chưa biết cách để xử lý cơ sở dữ liệu của đối tượng được chọn.

 

ANh có thể giải thích chút ít về cú pháp : (ssget "_F" (list a b) '((0 . "*LINE"))         và      (and (Setq c (car (acet-geom-intersectwith enl tmp 0)))

 

 

>>

Em cám ơn ạ :)

Em tìm tòi học lisp mấy tuần,  chưa biết cách để xử lý cơ sở dữ liệu của đối tượng được chọn.

 

ANh có thể giải thích chút ít về cú pháp : (ssget "_F" (list a b) '((0 . "*LINE"))         và      (and (Setq c (car (acet-geom-intersectwith enl tmp 0)))

 

 

 

Cái này nên làm MLeader luôn để các Leader nó kết thành 1 đối tượng.

Lisp sửa lại của bạn:

(defun c:lee  (/ a b c cmd enl i ssl tmp)
 (setq cmd (getvar 'CMDECHO))
 (setvar 'CMDECHO 0)
 (command "undo" "be")
 (if (and (setq a (getpoint "\nChon diem Cuoi Leader"))
          (setq b (getpoint a "\nChon diem Dau ve Leader")))
  (progn
;;; (command "Leader" b a "" "" "n")
         (command "LINE" b a "")
         (setq tmp (entlast))
         (setq ssl (ssget "_F" (list a b) '((0 . "*LINE"))))
         (setq i -1)
         (while (setq enl (ssname ssl (setq i (1+ i))))
          (and (Setq c (car (acet-geom-intersectwith enl tmp 0))) (command "leader" c a "" "" "n")))
         (entdel tmp)))
 (command "undo" "end")
 (setvar 'CMDECHO cmd)
 (princ))

 


<<

Filename: 403746_lee%C2%A0.lsp
Tác giả: duy782006
Bài viết gốc: 428232
Tên lệnh: ddl
Xin lisp đo chiều dài

Cơ bản nó như này:

-Tên lệnh: DDL

-Thao tác như lệnh: DIMALIGNED

-Tồn tại là chưa lấy số lẻ như đim và cái dấu mũi tên chưa nằm trúng line.

 

 

(defun c:ddl ( )
(command "DIMALIGNED")
(while (< 0 (getvar "CMDACTIVE"))
(command pause)
) 
(setq dvt  (entlast))
(setq giatri  (cdr (assoc 42 (entget dvt))))
(setq...
>>

Cơ bản nó như này:

-Tên lệnh: DDL

-Thao tác như lệnh: DIMALIGNED

-Tồn tại là chưa lấy số lẻ như đim và cái dấu mũi tên chưa nằm trúng line.

 

 

(defun c:ddl ( )
(command "DIMALIGNED")
(while (< 0 (getvar "CMDACTIVE"))
(command pause)
) 
(setq dvt  (entlast))
(setq giatri  (cdr (assoc 42 (entget dvt))))
(setq diemm (cdr (assoc 10 (entget dvt))))
(setq diemh (cdr (assoc 11 (entget dvt))))
(command ".LEADER" diemm diemh "" (strcat "L=" (rtos giatri 2 2)) "")
(command "erase" dvt "" "")
(princ))

 


<<

Filename: 428232_ddl.lsp
Tác giả: hhhhgggg
Bài viết gốc: 116182
Tên lệnh: noisuy
Lisp copy text số, tăng theo hàm bậc nhất !

Lisp noisuy được sửa lại theo yêu cầu của bạn đây :

(defun c:noisuy(/ p1 Z1 p2 Z2 p ptg Ztg dis ang Hz m cao oldos a)
 (setq temperr *error*) 
 (setq...
>>
Lisp noisuy được sửa lại theo yêu cầu của bạn đây :

(defun c:noisuy(/ p1 Z1 p2 Z2 p ptg Ztg dis ang Hz m cao oldos a)
 (setq temperr *error*) 
 (setq *error* bloi)
 ;;;;;;;;;;;;;;;;;;;
 (setq p1 (getpoint "\n Nhap diem P1 :"))
 (setq Z1 (getreal "\n Nhap cao do Z1 :"))
 (setq p2 (getpoint p1 "\n Nhap diem P2 :"))
 (setq Z2 (getreal "\n Nhap cao do Z2 :"))
 (if (> (cadr p1) (cadr p2)) 
(progn (setq ptg p2) (setq p2 p1) (setq p1 ptg) 
       (setq Ztg Z2) (setq Z2 Z1) (setq Z1 Ztg)) 
 )
 (setq dis (distance p1 p2)
ang (angle p1 p2))
 (setq Hz (- Z1 Z2) tana (abs (/ Hz dis)))
 (setq m (getint "\n So phan tu nam giua A va B :") i 0)
 (setq cao (getdist "\n Nhap chieu cao chu :"))
 (Setq oldos (getvar "OSMODE"))
 (SETVAR "OSMODE" 0)
 (Repeat (+ m 2)
 (setq p (polar p1 ang (* i (/ dis (1+ m)))))
 (setq a (distance p p1))
(if (< Z1 Z2)
    (if (equal (+ (distance p1 p) dis) (distance p p2) 0.000001) 	     
	    	(progn (setq Z (+ Z1 (* tana (- a) ))) (in (rtos Z 2 3) p cao (angle p1 p2)) )
    	(progn (setq Z (+ Z1 (* tana a))) (in (rtos Z 2 3) p cao (angle p1 p2)) )
    )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (> Z1 Z2)
    (if (equal (+ (distance p2 p) dis) (distance p p1) 0.000001) 	     
	    	(progn (setq Z (+ Z2 (* tana (- a) ))) (in (rtos Z 2 3) p cao (angle p1 p2)) )
    	(progn (setq Z (+ Z2 (* tana a))) (in (rtos Z 2 3) p cao (angle p1 p2)) )
    )
)
(command "point" p)
(setq i (1+ i))
 );while
(COMMAND "LINE" P1 P2 "")
 	(SETVAR "OSMODE" oldos)
 (setq *error* temperr)
(princ)
)
;;;
(defun *error* (msg)
(princ "error: ")
(princ msg)
(princ)
)
;;;;;;;;;;;;;;;;
(defun bloi(errmsg)
(command "snap" "R" '(0 0 0) 0)
)
(defun in(txt p cao ang)
(while (> ang (/ pi 2))
(setq  ang (- ang pi))
)
(entmake (list(cons 0 "TEXT") (cons 1 txt) (cons 10 p) (cons 11 p) (cons 40 cao) (cons 50 ang)
	(cons 72 1) (cons 73 1)
 )
)
)

ok ! đúng rùi ! Cảm ơn bác nhìu nhìu nhé !


<<

Filename: 116182_noisuy.lsp
Tác giả: jangboko
Bài viết gốc: 409963
Tên lệnh: test
Nhờ Viết Lisp Chọn Text

 

Thử lisp này nhé. Thay dòng redraw bằng lệnh cần dùng. ^_^

(defun c:test (/ txt )
  (if (not (setq txt (car...
>>

 

Thử lisp này nhé. Thay dòng redraw bằng lệnh cần dùng. ^_^

(defun c:test (/ txt )
  (if (not (setq txt (car (entsel "\nChon text mau: "))))
    (princ "\nBan da khong chon text mau!")
    (progn
       (if (not (setq ss	(ssget (list (cons 0 "TEXT")
				     (assoc 40 (entget txt))
				     (assoc 7 (entget txt))
			       )
			)
	       )
	  )
	(princ "\Ban da khong chon text.")
	(mapcar
	  '(lambda (o)
	     (redraw o 3)
	   )
	  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
	)

      )
    )
  )
  (princ)
)

Cảm ơn bạn đã trợ giúp, Lisp dùng đúng như yêu cầu tớ đã nêu ở trên, nhưng ý mình muốn khi đã chọn được các text, mình nhấn " Ctrl+1 " để hiện bảng thuộc tính của text, mình có thể hiệu chỉnh các thông số của text trong bảng này, Lisp của bạn viết giúp thì lại chưa làm được việc này, Mong bạn sửa lại giúp mình 1 chút, Cám ơn bạn nhiều


<<

Filename: 409963_test.lsp
Tác giả: aliosa
Bài viết gốc: 214004
Tên lệnh: ha
Sửa lisp chọn đối tượng theo điều kiện


(defun C:HA ()
 (setq ss1 nil
ss2 nil
 )
 (if (setq ss1 (ssget
'((-4 . "<OR")
  (-4 . "<AND")
  (2 . "TC")
  (8 . "Ke")
  (-4 ....
>>


(defun C:HA ()
 (setq ss1 nil
ss2 nil
 )
 (if (setq ss1 (ssget
'((-4 . "<OR")
  (-4 . "<AND")
  (2 . "TC")
  (8 . "Ke")
  (-4 . "AND>")
  (8 . "1,3")
  (-4 . "OR>")
 )
)
     )
   (foreach itm (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1)))
     (if (/= (strcase (cdr (assoc 2 (entget itm)))) "TC")
(progn
(or ss2 (setq ss2 (ssadd)))
(ssadd itm ss2)
(ssdel itm ss1)
)
     )
   )
 )
 (command ".erase" ss2 "")
)

Chân thành cảm ơn bạn HA. Mình thử test lisp bạn viết bằng cách thêm dòng bổ sung thêm dòng

(command ".erase" ss2 "")

vào chương trình như trên. Khi chạy chương trình không xóa được tập SS2. Không biết có lỗi gì nữa. Nhờ bạn kiểm tra giúp mình.

P/s: Tập ss1 là các Block có tên TC ở lớp KE mình sẽ dùng vào mục đích khác


<<

Filename: 214004_ha.lsp
Tác giả: Tue_NV
Bài viết gốc: 131152
Tên lệnh: df
Nhờ viết hộ lisp chia trần siêu tốc

E bị loạn rồi ^^ Bác Tuệ gửi phần mềm quay phim e với :")

Dvx và Dvy > 305 chứ ạ...

>>

E bị loạn rồi ^^ Bác Tuệ gửi phần mềm quay phim e với :")

Dvx và Dvy > 305 chứ ạ ^^

Vì yêu cầu của bạn ý chốt tấm sàn ngoài lớn hơn 305x305 nên e k để là kcv /2

 

P/S : 3 anh em mình test khác nhau có lẽ do vài thằng biến không hợp nhau

 

(defun c:df()
 (setq e (car(entsel)))
 (setq kcv (getreal "\n Khoang cach luoi o vuong :"))
 (setq p (ACET-ENT-GEOMEXTENTS e) d1 (car p) d2 (cadr p)
 	kcx (abs (- (car d1) (car d2)))
kcy (abs (- (cadr d1) (cadr d2)))	
dvx (* (/ (- (/ kcx kcv) (fix (1- (/ kcx kcv)))) 2) kcv)
dvy (* (/ (- (/ kcy kcv) (fix (1- (/ kcy kcv)))) 2) kcv)
 )
(setq dv (mapcar '+ d1 (list dvx dvy 0.0)))
(acet-sysvar-set (list "hpname" "_USER" "HPORIGINMODE" 0 "hpdouble" 1 "HPORIGIN" dv "hpspace" kcv))
(command "-hatch" dv "")
(acet-sysvar-restore)
)

Bạn test lại xem sao

Sorry! mình viết nhầm ấy mà.

Lisp của mình và ketxu chỉnh lại đều như nhau. Ra cùng 1 kết quả đúng

Có lẽ đây là 1 nhược điểm rất lớn của hàm Command vì nó chịu sự tác động của các biến hệ thống


<<

Filename: 131152_df.lsp
Tác giả: huaductiep
Bài viết gốc: 277990
Tên lệnh: fixline hatchkin
Nhờ viết Lisp Hatch vùng kín của các đối tượng giao nhau.

 

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/...
>>

 

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)
(defun LM:IntersectionsInSet ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendnone) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun LM:IntersectionsInSetboth ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendboth) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun DDH:pointtolsppoint (pointchen lsppointchen / vitrichen ii)
  (setq iii 0)
  (repeat (- (length lsppointchen) 1)
    (if (and (> (distance pointchen (nth (+ iii 1) lsppointchen)) 0.001)
	     (> (distance pointchen (nth iii lsppointchen)) 0.001)
	     )
      (progn
	(if (<= (abs (- (distance (nth iii lsppointchen) (nth (+ iii 1) lsppointchen))
			(+ (distance pointchen (nth (+ iii 1) lsppointchen))
			   (distance pointchen (nth iii lsppointchen))
			   )
			))
		     0.001)
	  (setq vitrichen (+ iii 1))
	  )
	)
      )
    (setq iii (+ iii 1))
    )
  (setq lsppointchen (LM:InsertNth pointchen vitrichen lsppointchen))
  )
(defun LM:InsertNth ( x n l )
  ((lambda ( k )
     (apply 'append
	    (mapcar '(lambda ( a ) (if (= n (setq k (1+ k))) (list x a) (list a))) l)
	    )
     )
    -1
    )
  )
(defun LM:Uniqueline ( l )
  (if l (cons (car l)
	      (LM:Uniqueline
		(vl-remove-if '(lambda (x) (or (and (equal (car x) (car (car l)))
						    (equal (cadr x) (cadr (car l))))
					       (and (equal (car x) (cadr (car l)))
						    (equal (cadr x) (car (car l))))
					       )
				 ) (cdr l))
		))))
(defun taopolyline (lst layer mau / x )
  (entmakex
    (append (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length lst))
		  (cons 70 0)
		  (cons 66 1)
		  (cons 8 layer)
		  (cons 62 mau)
		  )
	    (mapcar (function (lambda (x) (cons 10 x))) lst)
	    )
    )  
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:fixline(/)
  (setq khoangfix (getreal "\nNhap Khang Cach Max De Xet Fix Doi Tuong <1.00>:"))
  (if (= khoangfix nil)
    (setq khoangfix 1.00)
    )		       
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn
      (setq chonpolyline (ssadd))      
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSetboth chonpolyline))
      (setq i 0)
      (repeat (sslength chonpolyline)
	(setq toado (ACET-GEOM-OBJECT-POINT-LIST (ssname chonpolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonpolyline i) (vlax-curve-getendparam (ssname chonpolyline i)))
			  10000)))      
	(foreach diemgiao lspgiaodiem
	  (if (and (<= (distance (car toado) diemgiao) khoangfix)
		   (> (distance (car toado) diemgiao) 0.001))
	    (entmakex (list '(0 . "LINE")
			(cons 10 (car toado))
			(cons 11 diemgiao)
			))
	    )
	  )
	(foreach diemgiao lspgiaodiem
	  (if (and (<= (distance (last toado) diemgiao) khoangfix)
		   (> (distance (last toado) diemgiao) 0.001))
	    (entmakex (list '(0 . "LINE")
			(cons 10 (last toado))
			(cons 11 diemgiao)
			))
	    )
	  )
	(entdel (ssname chonpolyline i))
	(setq i (+ i 1))
	)
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:hatchkin(/)
  (vl-load-com)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
						      (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
							 10000)))))
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
	  (setq i (+ i 1))
	  )
	)
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
	(entmakex (list '(0 . "LINE")
			(cons 10 (car line))
			(cons 11 (cadr line))
			))
	(ssadd (entlast) chonline)
	(setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	)
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
	(progn
	  (command "ERASE" chonline "")
	  (command "ERASE" chonpolyline "")
	  (setq lspxetbien nil)
	  (foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
	    )
	  (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  (setq dientichtong 0.00)
	  (foreach dientich (cdr lspxetbien)
	    (setq dientichtong (+ dientichtong (cadr dientich)))
	    )
	  (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
	    (entdel (car (car lspxetbien)))
	    )
	  (setq mau 1)
	  (foreach xetpl (cdr lspxetbien)
	    (if (>= mau 255)
	      (setq mau 1)
	      )
	    (command "hatch" "" "" "" (car xetpl) "")
	    (entdel (car xetpl))
	    (command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )	  
	  )
	)
      )
    )
  )

thực hiện lệnh fixline để đóng những khoảng hở trước

test2.gif

Ý tưởng cải tiến này của bác tuyệt quá . Em cám ơn bác Hưng ah :)


<<

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

Viết giúp chú theo PA2 của anh Gia_bach (PA1 anh Gia_bach xét thiếu các đỉnh).

Không biết số ent màu hồng có nhiều không, chứ dùng PA command hơi ì ạch nếu số lượng đủ lớn.


(defun C:HA(/ old ent lst ds1 ds2)
 (command "undo" "be")
 (setq old (entlast))
 (setq ent (car (entsel "\nChon Pline mau trang: ")))
 (princ "\nChon tat ca o vuong mau hong: ")
 (setq lst (#SS->List...
>>

Viết giúp chú theo PA2 của anh Gia_bach (PA1 anh Gia_bach xét thiếu các đỉnh).

Không biết số ent màu hồng có nhiều không, chứ dùng PA command hơi ì ạch nếu số lượng đủ lớn.


(defun C:HA(/ old ent lst ds1 ds2)
 (command "undo" "be")
 (setq old (entlast))
 (setq ent (car (entsel "\nChon Pline mau trang: ")))
 (princ "\nChon tat ca o vuong mau hong: ")
 (setq lst (#SS->List  (ssget)))
 (mapcar '(lambda(e) (command "copy" e "" "none" '(0 0) "none" '(0 0)) (command "region" (entlast) "")) lst)
 (setq ds1 (GetNewEnts old) old (entlast)) 
 (repeat (length lst) (command "copy" ent "" "none" '(0 0) "none" '(0 0)) (command "region" (entlast) ""))
 (setq ds2 (GetNewEnts old) i -1)
 (repeat (length ds1)
  (command "INTERSECT" (nth (setq i (1+ i)) ds1) (nth i ds2) ""))
 (command "undo" "e") (princ))
(defun GetNewEnts (ename / new) (while (setq ename (entnext ename)) (if (entget ename) (setq new (cons ename new)))) new)        ; list ename
(defun #SS->List (ss / i lst) (repeat (setq i (sslength ss)) (setq lst (cons (ssname ss (setq i (1- i))) lst))))


<<

Filename: 428314_ha.lsp
Tác giả: proconeng86
Bài viết gốc: 241855
Tên lệnh: sv
Nhờ viết lisp chia màn hình (VPort)

 

Chắc các cao thủ bận thi đại học, ý nhầm: các cao thủ bận chấm thi và tuyển sinh rồi,

 

Sửa lại lisp...

>>

 

Chắc các cao thủ bận thi đại học, ý nhầm: các cao thủ bận chấm thi và tuyển sinh rồi,

 

Sửa lại lisp của Thaistreetz cho bạn nè :

;;; Copyright 2011 Thaistreetz from cadviet.com
;;; Edit by Gia_Bach - Ngay 19/7/2013
(defun C:sv (/ dxf10 dxf11 phuong pt pt1 pt2 tl);Split View
  (vl-load-com)
  (defun get-coordinate-screen (coner / Y1 X1)
    (cond ((= (strcase coner) "TL")
	   (polar(polar(getvar "viewctr")(* 0.5 pi) (setq Y1 (* 0.5 (getvar"viewsize")))) pi (/(* Y1 (car(setq X1 (getvar"screensize"))))(cadr X1))))
	  ((= (strcase coner) "BR")
	   (polar(polar(getvar "viewctr")(* -0.5 pi)(setq Y1 (* 0.5 (getvar"viewsize")))) 0 (/(* Y1 (car(setq X1 (getvar"screensize"))))(cadr X1))))))
  (defun TS:zoom (pt1 pt2) (vlax-invoke (vlax-get-acad-object) 'zoomwindow pt1 pt2))
  ;(command "propertiesclose")  
  (if (= (length (vports)) 1)
    (progn
      (setq pt (getpoint "\nChon diem chia :"))
      (setq PT1 (get-coordinate-screen "TL") PT2 (get-coordinate-screen "BR"))
      (initget 1 "Ngang Doc")
      (setq phuong (getkword "\nChia theo phuong ? (Ngang/Doc) "))
      (if (= phuong "Doc")
	(setq tl (/ (- (car pt) (car pt1)) (- (car pt2)(car pt1)))
	      dxf11 (cons 11 (list  tl 1.0))
	      dxf10 (cons 10 (list  tl 0.0 0.0)) )
	(setq tl (/ (- (cadr pt) (cadr pt2)) (- (cadr pt1)(cadr pt2)))
	      dxf11 (cons 11 (list 1.0 tl))
	      dxf10 (cons 10 (list 0.0 tl 0.0)) ) )
      (if (not(tblsearch "vport" "ThaistreetzView"))
	(progn
	  (entmakex (append '((0 . "VPORT")(100 . "AcDbSymbolTableRecord")(100 . "AcDbViewportTableRecord")(2 . "ThaistreetzView")(70 . 0)(10 0.0 0.0) )
			    (list dxf11)))
	  (entmakex (append '((0 . "VPORT")(100 . "AcDbSymbolTableRecord")(100 . "AcDbViewportTableRecord")(2 . "ThaistreetzView")(70 . 0)(11 1.0 1.0 0.0) )
			    (list dxf10) ))))
      (vl-cmdf "vports" "r" "ThaistreetzView")
      (ts:zoom pt1 pt2)
      (setvar "cvport" 3)
      (ts:zoom pt1 pt2))
    (progn
      (vl-cmdf "vports" "si")
      (if (tblsearch "vport" "ThaistreetzView") (vl-cmdf "vports" "d" "ThaistreetzView"))
      (vlax-invoke (vlax-get-acad-object) 'zoomall) ) )
  (princ))

quá hay, ngoài mong đợi của mình. lúc đầu mình chỉ muốn thêm lisp chia ngang nhưng bạn gia_bach còn làm hơn thế, đưa ra 1 lựa chọn để chọn chia ngang hay chia dọc, quá tuyệt vời. cám ơn bạn gia_bach nhé

bạn đúng là đại cao thủ rồi  :)


<<

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

PÁ này hôm qua viết rồi, nhưng chạy chậm và phụ thuộc mức độ vi phân (trong lisp lấy n=20), bù lại là tránh tạo Region dính cặp.


(defun C:HA1(/ ds)
 (command "undo" "be")
 (setq ent (car (entsel "\nChon Pline mau trang: ")))
 (princ "\nChon tat ca o vuong mau hong: ")
 (foreach e (setq lst (#SS->List  (ssget)))
  (setq lstpt (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget e))))
  (setq...
>>

PÁ này hôm qua viết rồi, nhưng chạy chậm và phụ thuộc mức độ vi phân (trong lisp lấy n=20), bù lại là tránh tạo Region dính cặp.


(defun C:HA1(/ ds)
 (command "undo" "be")
 (setq ent (car (entsel "\nChon Pline mau trang: ")))
 (princ "\nChon tat ca o vuong mau hong: ")
 (foreach e (setq lst (#SS->List  (ssget)))
  (setq lstpt (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget e))))
  (setq ll (list (apply 'min (mapcar 'car lstpt)) (apply 'min (mapcar 'cadr lstpt))) ur (list (apply 'max (mapcar 'car lstpt)) (apply 'max (mapcar 'cadr lstpt))))
  (setq n 20 dta (/ (- (car ur) (car ll)) n) x (- (car ll) dta) en (entlast) ds nil)
  (repeat n
   (setq x (+ x dta) y (- (cadr ll) dta))
   (repeat n
    (setq y (+ y dta))
    (setq p (list x y))
    (if (and (HA:Insidep1 p ent) (HA:Insidep2 p ds))  (progn (command "BOUNDARY" p "") (setq ds (GetNewEnts en)))))))
 (command "undo" "e") (princ))
;; KiÓm tra ®iÓm Pt lµ n»m trong/ngoµi Polygon. Tr¶ vª T/nil nªu Pt n»m trong/ngoµi Ent. Modify by HA - 07/09/2013.
(defun HA:Insidep1 (pt ent / obj1 obj2 obj3 big small flag)
 (vl-load-com)
 (setq obj1 (vlax-ename->vla-object ent))
 (setq obj2 (car (vlax-invoke obj1 'Offset 1E-3)))
 (setq obj3 (car (vlax-invoke obj1 'Offset -1E-3)))
 (if (> (vla-get-Area obj2)(vla-get-Area obj3))
  (setq big obj2 small obj3)
  (setq big obj3 small obj2))
 (setq flag (> (distance pt (vlax-curve-getClosestPointTo big pt)) (distance pt (vlax-curve-getClosestPointTo small pt))))
 (mapcar '(lambda(x) (progn (vla-Delete x) (vlax-release-object x))) (list big small))
 flag)
(defun HA:Insidep2 (pt ds / ent flag1)
 (setq flag1 T)
 (while (and ds flag1)
  (setq ent (car ds) ds (cdr ds)) 
  (if (HA:Insidep1 pt ent) (setq flag1 nil)))
 flag1)
(defun GetNewEnts (ename / new) (while (setq ename (entnext ename)) (if (entget ename) (setq new (cons ename new)))) new)        ; list ename
(defun #SS->List (ss / i lst) (repeat (setq i (sslength ss)) (setq lst (cons (ssname ss (setq i (1- i))) lst))))


<<

Filename: 428350_ha1.lsp
Tác giả: ndtnv
Bài viết gốc: 428349
Tên lệnh: testregion
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Muốn kết quả là PLINE

(defun C:TestRegion (/ s r o i k ssa t0)
    (setq s (vlax-ename->vla-object(car (entsel))))
    (setq r (mapcar 'vlax-ename->vla-object
                                    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "REGION")(8 . "LUOI"))))))))
    (setq t0 (getvar "MilliSecs"))
    (foreach e r
        (setq o (vla-copy s))
        (vla-boolean e...
>>

Muốn kết quả là PLINE

(defun C:TestRegion (/ s r o i k ssa t0)
    (setq s (vlax-ename->vla-object(car (entsel))))
    (setq r (mapcar 'vlax-ename->vla-object
                                    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "REGION")(8 . "LUOI"))))))))
    (setq t0 (getvar "MilliSecs"))
    (foreach e r
        (setq o (vla-copy s))
        (vla-boolean e acIntersection o)
        (if (> (vla-get-Area e) 0)
            (progn
                (setq i (vlax-vla-object->ename e))
                (vl-cmdf "._EXPLODE" i "")
                (if (setq ss (ssget "P" '((0 . "REGION"))))
                    (progn
                        (setq k 0)
                        (repeat (sslength ss)
                            (vl-cmdf "._EXPLODE" (ssname ss k) "" "")
                            (vl-cmdf "._PEDIT" "M" "P" "" "J" "" "" )
                            (setq k (1+ k))
                            )
                        )
                    (vl-cmdf "._PEDIT" "M" "P" "" "J" "" "" )
                )
            )
        )
    )
    (-(getvar "MilliSecs") t0)
)

 

Chạy bài 540 REGION mất 10s

Nếu vẫn muốn kq là REGION :

ss <> nil : không thực hiện các lệnh trong if

ss = nil: undo bước (vl-cmdf "._EXPLODE" i "")

 

P/s: Biến PEDITACCEPT = 1

 


<<

Filename: 428349_testregion.lsp
Tác giả: Tue_NV
Bài viết gốc: 89969
Tên lệnh: chonnguyen
Chọn text là số
Các lisp trên có nhược điểm là sau khi chọn text rồi mới kiểm tra xem text đó là số hay không. Lisp dưới đây chỉ chọn text số luôn mà không cần mã lệnh kiểm...
>>
Các lisp trên có nhược điểm là sau khi chọn text rồi mới kiểm tra xem text đó là số hay không. Lisp dưới đây chỉ chọn text số luôn mà không cần mã lệnh kiểm tra.

 

Lisp chọn số thực:

(defun c:chonthuc()
 (setq ss (ssget '((0 . "TEXT") (1 . "~*,`.*~`.*"))))
)

 

Lisp chọn số nguyên:

(defun c:chonnguyen()
 (setq ss (ssget '((0 . "TEXT") (1 . "~**"))))
)

Chào bác Hoành

Lisp chọn số nguyên chạy OK.

 

Lisp chọn số thực có vấn đề

-> chọn số thực, chọn số nguyên và cả string nữa :D


<<

Filename: 89969_chonnguyen.lsp
Tác giả: binhtl88
Bài viết gốc: 210396
Tên lệnh: ha1
Nhờ viết lisp tạo nhanh wipeout

Quick code

;Doan Van Ha - CADViet.com - Ngay 04/4/2012
;Muc dich: Convert cac Lwpolyline duoc chon thanh cac Wipeout.
(defun...
>>

Quick code

;Doan Van Ha - CADViet.com - Ngay 04/4/2012
;Muc dich: Convert cac Lwpolyline duoc chon thanh cac Wipeout.
(defun C:HA1( / cmd entlst xoa)
(command "undo" "be")
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LWPOLYLINE")))))))
(initget "X K") (setq xoa (getkword "\n pline cu <X>: "))
(if (= xoa "K") (setq xoa "N") (setq xoa "Y"))
(foreach ent entlst
 (setq lst (acet-geom-vertex-list ent))
 (cond
  ((= 1 (cdr (assoc 70 (entget ent))))
(command "wipeout" "p" ent xoa))
  ((and (= 0 (cdr (assoc 70 (entget ent)))) (equal (car lst) (last lst) 1E-8))
(entmod (subst (cons 70 1) (assoc 70 (entget ent)) (entget ent)))
(command "wipeout" "p" ent xoa))))
(setvar "cmdecho" cmd)
(command "undo" "end")
(princ))

P/S (17h15' ngày 05/4/2012): Hiệu chỉnh để wipeout được với cả Lwpolyline kín nhưng open.

Anh ơi nhưng dùng lệnh này như thế nào ạ? e load lisp xòn ko biết thế nào nữa


<<

Filename: 210396_ha1.lsp

Trang 273/303

273