Jump to content
InfoFile
Tác giả: Bee
Bài viết gốc: 414685
Tên lệnh: test
Xin Lisp Lọc Test Có Một Số Chữ Giống Nhau.

Xa rời () cũng hơn 10 năm rồi. Giờ đầu óc toàn bỉm sữa tã thôi bác ạ. Giờ đụng chuyện mới cần triển khai Lisp cho nó nhanh.

Chậc chậc đối xử lisp thế là ko đc rồi. Bth thì bỏ rơi nó, đến lúc cần mới chạy long sòng sọc. Heizz. Kiểu này khi làm tướng là đối xử với quân ko công...

>>

Xa rời () cũng hơn 10 năm rồi. Giờ đầu óc toàn bỉm sữa tã thôi bác ạ. Giờ đụng chuyện mới cần triển khai Lisp cho nó nhanh.

Chậc chậc đối xử lisp thế là ko đc rồi. Bth thì bỏ rơi nó, đến lúc cần mới chạy long sòng sọc. Heizz. Kiểu này khi làm tướng là đối xử với quân ko công bằng roài. Thi thoảng vào free vài cái lisp cho bọn trẻ con dùng để nhớ nó tí.

Dầu sao cũng quick tí đỡ bùn vậy

(defun c:test ()
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
	(setq value (cdr (assoc 1 (entget (ssname ss n)))))
	(setq char (substr value 1 2))
	(cond
	  ((or (= char "L=") (= char "l="))
	   (entmod (subst (cons 8 "Length") (assoc 8 (entget (ssname ss n)))))
	   )
	  ((or (= char "Q=") (= char "q="))
	   (entmod (subst (cons 8 "Flow") (assoc 8 (entget (ssname ss n)))))
	   )
	  ((or (= char "H=") (= char "h="))
	   (entmod (subst (cons 8 "Elevation") (assoc 8 (entget (ssname ss n)))))
	   )
	  );cond
	(setq n (1+ n))
	);repeat
      )
    )
  (princ)
  )

^_^


<<

Filename: 414685_test.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 111082
Tên lệnh: tdd
Viết lisp theo yêu cầu [phần 2]

Chào bác phamngoctukts,
Cái lisp này cải biên từ cái lisp trước, lần này nó không chon point có sẵn nữa mà chọn các đối tượng giao với boundary để xác định point. Sau đó thì làm y như cụ bác ạ.
Một vấn đề mà mình chưa gỡ được chính là việc chọn các đối tượng. Mình đã thử dùng hàm ssget với tùy chọn là "CP" nhưng nó chọn không hết các đối tượng giao với boundary. Vì...
>>

Chào bác phamngoctukts,
Cái lisp này cải biên từ cái lisp trước, lần này nó không chon point có sẵn nữa mà chọn các đối tượng giao với boundary để xác định point. Sau đó thì làm y như cụ bác ạ.
Một vấn đề mà mình chưa gỡ được chính là việc chọn các đối tượng. Mình đã thử dùng hàm ssget với tùy chọn là "CP" nhưng nó chọn không hết các đối tượng giao với boundary. Vì sao thì mình chưa rõ. Vậy nên lại chơi bài củ chuối là pick chọn đối tượng thì nó lại chạy rất chuẩn. cách pick chọn này mà vớ phải dăm chục anh loằng ngoằng thì cũng mệt, xong mình chưa tìm ra cách chọn nào để có thể chọn tất cả các đối tượng giao với boundary cả bác ạ. (Bác xem trên cái líp của mình sẽ rõ)
Hy vọng bác tìm ra cách chọn có hiệu quả hơn cách của mình.
Chúc bác vui.
Lísp đây ạ

<<

Filename: 111082_tdd.lsp
Tác giả: phamngoctukts
Bài viết gốc: 111184
Tên lệnh: tdd
Viết lisp theo yêu cầu [phần 2]

Hề hề chào bác Bình hôm qua kiểm tra code của bác thấy lỗi đó mà em cũng không biết khắc phục thế nào. sử dụng ở bản vẽ khác thì OK nhưng sử dụng trong bản vẽ do bạn hdt4151 up lên thì bị lỗi (không giải thích được) kể cả dùng select với tuỳ chọn "f" quét qua các đỉnh đa giác cũng không select hết các cạnh được. Vì vậy em đã tiếp tục phát triển lisp trên theo hướng add point...
>>

Hề hề chào bác Bình hôm qua kiểm tra code của bác thấy lỗi đó mà em cũng không biết khắc phục thế nào. sử dụng ở bản vẽ khác thì OK nhưng sử dụng trong bản vẽ do bạn hdt4151 up lên thì bị lỗi (không giải thích được) kể cả dùng select với tuỳ chọn "f" quét qua các đỉnh đa giác cũng không select hết các cạnh được. Vì vậy em đã tiếp tục phát triển lisp trên theo hướng add point vào các đỉnh và được code như thế này. Nghe có vẻ ngắn hơn của bác nhưng thời gian thì khỏi phải bàn. Với thế hệ máy tính bây giờ thì có lẽ không thành vấn đề với lisp này mà dùng với thế hệ máy ngày xua p1, p2 với số lượng obj nhiều nhiều một chút chắc là đơ luôn.
Bạn hdt4151 dùng thử 2 lisp xem có thấy sự khác biệt gì không nhé.

<<

Filename: 111184_tdd.lsp
Tác giả: Tue_NV
Bài viết gốc: 414791
Tên lệnh: test1
Gán Biến Trong Vòng Lặp

Chào các bác, em đang có một rắc rối nhỏ. ví dụ như em cho chạy một vòng lặp i chạy từ 1 đến 10, trong đó có gán biến ssi, làm sao để có thể gán lần lượt các biến ss1, ss2, ss3... trong vòng lặp ạ. Như bên C+ thì có ss, bên Lisp em chưa rành về mảng lắm.
Cám ơn mọi người...

>>

Chào các bác, em đang có một rắc rối nhỏ. ví dụ như em cho chạy một vòng lặp i chạy từ 1 đến 10, trong đó có gán biến ssi, làm sao để có thể gán lần lượt các biến ss1, ss2, ss3... trong vòng lặp ạ. Như bên C+ thì có ss, bên Lisp em chưa rành về mảng lắm.
Cám ơn mọi người ạ.
 

Bạn test thử code

(defun c:test1 ()
  (setq i 0 )
  (Repeat 10
       (mapcar 'set (read (strcat "(" "ss" (itoa (setq i (1+ i))) ")")) (list i))
  )
)
(defun c:test2 ()
  (setq i 0 ssi "(" Lbi '())
  (Repeat 10
    (setq ssi (strcat ssi "ss" (itoa (setq i (1+ i))) " "))
    (setq Lbi (append Lbi (list i)))
  )
  (mapcar 'set (read (strcat ssi ")")) Lbi)
)

<<

Filename: 414791_test1.lsp
Tác giả: Tue_NV
Bài viết gốc: 414791
Tên lệnh: test2
Gán Biến Trong Vòng Lặp

Chào các bác, em đang có một rắc rối nhỏ. ví dụ như em cho chạy một vòng lặp i chạy từ 1 đến 10, trong đó có gán biến ssi, làm sao để có thể gán lần lượt các biến ss1, ss2, ss3... trong vòng lặp ạ. Như bên C+ thì có ss, bên Lisp em chưa rành về mảng lắm.
Cám ơn mọi người...

>>

Chào các bác, em đang có một rắc rối nhỏ. ví dụ như em cho chạy một vòng lặp i chạy từ 1 đến 10, trong đó có gán biến ssi, làm sao để có thể gán lần lượt các biến ss1, ss2, ss3... trong vòng lặp ạ. Như bên C+ thì có ss, bên Lisp em chưa rành về mảng lắm.
Cám ơn mọi người ạ.
 

Bạn test thử code

(defun c:test1 ()
  (setq i 0 )
  (Repeat 10
       (mapcar 'set (read (strcat "(" "ss" (itoa (setq i (1+ i))) ")")) (list i))
  )
)
(defun c:test2 ()
  (setq i 0 ssi "(" Lbi '())
  (Repeat 10
    (setq ssi (strcat ssi "ss" (itoa (setq i (1+ i))) " "))
    (setq Lbi (append Lbi (list i)))
  )
  (mapcar 'set (read (strcat ssi ")")) Lbi)
)

<<

Filename: 414791_test2.lsp
Tác giả: vietanh2108
Bài viết gốc: 414808
Tên lệnh: selblkbyattval
Chọn Block Theo Giá Trị Attribute

Em tìm được lisp này trên mạng của thánh Lêmác cơ mà bị cái kẹt nó đang chọn tất cả các block trên Model. Em muốn nhờ các bác sửa tí xíu thôi, mong ai đi ngang qua giúp cho.
- Lọc các Block ở vùng chọn selectonscreen thay vì toàn model
Em xin cám ơn các bác đã quan tâm chủ đề trên! :D
 
;; Select Blocks by Attribute Value - Lee Mac

;; Selects all attributed...
>>
Em tìm được lisp này trên mạng của thánh Lêmác cơ mà bị cái kẹt nó đang chọn tất cả các block trên Model. Em muốn nhờ các bác sửa tí xíu thôi, mong ai đi ngang qua giúp cho.
- Lọc các Block ở vùng chọn selectonscreen thay vì toàn model
Em xin cám ơn các bác đã quan tâm chủ đề trên! :D
 
;; Select Blocks by Attribute Value - Lee Mac

;; Selects all attributed blocks in the current layout which contain a specified attribute value.

(defun c:selblkbyattval ( / att atx ent idx sel str )

(if (/= "" (setq str (strcase (getstring t "\nSpecify attribute value: "))))

(if (and

(setq sel

(ssget "_X"

(list '(0 . "INSERT") '(66 . 1)

(if (= 1 (getvar 'cvport))

(cons 410 (getvar 'ctab))

'(410 . "Model")

)

)

)

)

(progn

(repeat (setq idx (sslength sel))

(setq ent (ssname sel (setq idx (1- idx)))

att (entnext ent)

atx (entget att)

)

(while

(and (= "ATTRIB" (cdr (assoc 0 atx)))

(not (wcmatch (strcase (cdr (assoc 1 atx))) str))

)

(setq att (entnext att)

atx (entget att)

)

)

(if (= "SEQEND" (cdr (assoc 0 atx)))

(ssdel ent sel)

)

)

(< 0 (sslength sel))

)

)

(sssetfirst nil sel)

(princ (strcat "\nNo blocks found with attribute value matching \"" str "\"."))

)

)

(princ)

)

<<

Filename: 414808_selblkbyattval.lsp
Tác giả: Tue_NV
Bài viết gốc: 414853
Tên lệnh: bao
Viết Lisp Tạo Đường Bao

Ý mình là như vậy này: pick vào các hình A, B, C rồi tạo đường bao cho cho cả 3 hình ấy.

http://www.cadviet.com/upfiles/7/159384_duong_bao.dwg

Quick code

(defun c:bao()
  (setq p...
>>

Ý mình là như vậy này: pick vào các hình A, B, C rồi tạo đường bao cho cho cả 3 hình ấy.

http://www.cadviet.com/upfiles/7/159384_duong_bao.dwg

Quick code

(defun c:bao()
  (setq p (getpoint "pick diem :"))
  (command "._boundary" "A" "O" "R" "" p "")
  (Command "._region" "L" "")
  (setq el (entlast)) (redraw el 3)
  (while (setq p (getpoint "pick diem :"))
      (command "._boundary" p "")
      (Command "._region" "L" "")
    (command "._union" el "L" "")
    (setq el (entlast))
    (redraw el 3)
  )
)

<<

Filename: 414853_bao.lsp
Tác giả: Tue_NV
Bài viết gốc: 414894
Tên lệnh: bao
Viết Lisp Tạo Đường Bao

Anh có thể bỏ bắt điểm được không. Vì ở đây mình chỉ cần pick vào vùng kín.

Với lại sau khi xong region nó cứ như là được chọn vậy anh, mặc dù nó có được đâu ạ.

Mục đích mình hiện sáng đối tượng để dễ quan sát. Nếu bạn thích thì trong lisp bỏ dòng (redraw el...

>>

Anh có thể bỏ bắt điểm được không. Vì ở đây mình chỉ cần pick vào vùng kín.

Với lại sau khi xong region nó cứ như là được chọn vậy anh, mặc dù nó có được đâu ạ.

Mục đích mình hiện sáng đối tượng để dễ quan sát. Nếu bạn thích thì trong lisp bỏ dòng (redraw el 3)

Bổ sung thêm cái bỏ chế độ bắt điểm

Quick code

(defun c:bao(/ p os)
  (setq os (getvar "osmode"))
  (setvar "osmode" 0)
  (setq p (getpoint "pick diem :"))
   
  (command "._boundary" "A" "O" "R" "" p "")
  (Command "._region" "L" "")
  (setq el (entlast))
 (redraw el 3)
  (while (setq p (getpoint "pick diem :"))
      (command "._boundary" p "")
      (Command "._region" "L" "")
    (command "._union" el "L" "")
    (setq el (entlast))
    (redraw el 3)
  )
  (setvar "osmode" os)
)

<<

Filename: 414894_bao.lsp
Tác giả: gia_bach
Bài viết gốc: 70475
Tên lệnh: test
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)


Bạn tham khảo Lisp sau :

Filename: 70475_test.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 415030
Tên lệnh: mtc
Nhờ Chỉnh Sửa File Lisp Copy Text Vào Tâm Đường Tròn

rãnh rỗi viết tí cho vui

(defun c:MTC (/ )
(vl-load-com)
(command "undo" "be")
(setvar "CMDECHO" 0)
(setq oldOS (getvar "osmode"))
(setq dttext (car (LM:SelectIf "\nSelect a Text: " (lambda ( x ) (eq "TEXT" (cdr (assoc 0 (entget (car x)))))) entsel nil)))
(setq ddtext (cdr (assoc 10 (entget dttext))))
(prompt "\nChon duong tron de copy text.")
(setq ss (acet-ss-to-list (ssget (list (cons 0 "CIRCLE")))))
(foreach ent ss
(setq tam (cdr (assoc 10...
>>

rãnh rỗi viết tí cho vui

(defun c:MTC (/ )
(vl-load-com)
(command "undo" "be")
(setvar "CMDECHO" 0)
(setq oldOS (getvar "osmode"))
(setq dttext (car (LM:SelectIf "\nSelect a Text: " (lambda ( x ) (eq "TEXT" (cdr (assoc 0 (entget (car x)))))) entsel nil)))
(setq ddtext (cdr (assoc 10 (entget dttext))))
(prompt "\nChon duong tron de copy text.")
(setq ss (acet-ss-to-list (ssget (list (cons 0 "CIRCLE")))))
(foreach ent ss
(setq tam (cdr (assoc 10 (entget ent))))
(command ".COPY"  dttext "" ddtext tam)
)
(command "undo" "end")
(setvar "CMDECHO" 1)
(setvar "osmode" oldOs)
)
(defun LM:SelectIf ( msg pred func keyw / sel )
 (setq pred (eval pred))
 (while
  (progn
   (setvar 'ERRNO 0)
   (if keyw (apply 'initget keyw))
   (setq sel (func msg))
   (cond
   ((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
   ((eq 'STR (type sel))  nil)
   ((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
 sel)

<<

Filename: 415030_mtc.lsp
Tác giả: quang_lac
Bài viết gốc: 415073
Tên lệnh: leglengthmod splitdims
Nhờ Viết Lisp Chia Dim Và Gộp Dim.

Lisp chia dim cho bạn

(defun c:LegLengthMod ( / ss dimobjs)
;; codehimbelonga KerryBrown@theSwamp 2010.05.28
(vl-load-com)
(if (and (setq ss (ssget '((0 . "DIMENSION"))))
(setq dimobjs (mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
)
(foreach dim dimobjs
(vla-put-extlinefixedlensuppress dim :vlax-true)
(vla-put-extlinefixedlen dim (* 2 (vla-get-textheight dim)))
)
)
(princ)
)
(defun c:SplitDims (/ sel newpt...
>>

Lisp chia dim cho bạn

(defun c:LegLengthMod ( / ss dimobjs)
;; codehimbelonga KerryBrown@theSwamp 2010.05.28
(vl-load-com)
(if (and (setq ss (ssget '((0 . "DIMENSION"))))
(setq dimobjs (mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
)
(foreach dim dimobjs
(vla-put-extlinefixedlensuppress dim :vlax-true)
(vla-put-extlinefixedlen dim (* 2 (vla-get-textheight dim)))
)
)
(princ)
)
(defun c:SplitDims (/ sel newpt ent edata elist)
;; codehimbelonga KerryBrown@theSwamp 2010.05.28
(if (and (setq sel (entsel "\nSelect Dimension to Split."))
(setq newpt (getpoint "\Select new Dim Point"))
)
(progn (setq ent (car sel)
edata (entget ent)
elist (vl-remove-if
'(lambda (pair)
(member (car pair)
(list -1 2 5 102 310 300 330 331 340 350 360 410)
)
)
edata
)
)
(entmod (subst (cons 14 newpt) (assoc 14 elist) edata))
(entmakex (subst (cons 13 newpt) (assoc 13 elist) elist))
)
)
(princ)
)

<<

Filename: 415073_leglengthmod_splitdims.lsp
Tác giả: snowman.hms
Bài viết gốc: 415138
Tên lệnh: tt
Generate Non-Overlapping Polygons From A Set Of [Lwpoly]Lines
(defun _getedges (lst / e enx l typ 3d->2d dxf t0)
  (defun 3d->2d (3dpt) (list (car 3dpt) (cadr 3dpt)))
  (defun dxf (i el) (cdr (assoc i el)))
  (setq t0 (getvar "MilliSecs"))
  (foreach e lst
    (setq enx (entget e))
    (cond ((= (setq typ (dxf 0 enx)) "LINE")
	   (setq l (cons (list (list (3d->2d (dxf 10 enx)) (3d->2d (dxf 11 enx)))) l))
	  )
	  ((= typ "LWPOLYLINE") (setq l (cons (_Lw2Params enx) l)))
    )
  )
  (princ (strcat "\n\tTime to...
>>
(defun _getedges (lst / e enx l typ 3d->2d dxf t0)
  (defun 3d->2d (3dpt) (list (car 3dpt) (cadr 3dpt)))
  (defun dxf (i el) (cdr (assoc i el)))
  (setq t0 (getvar "MilliSecs"))
  (foreach e lst
    (setq enx (entget e))
    (cond ((= (setq typ (dxf 0 enx)) "LINE")
	   (setq l (cons (list (list (3d->2d (dxf 10 enx)) (3d->2d (dxf 11 enx)))) l))
	  )
	  ((= typ "LWPOLYLINE") (setq l (cons (_Lw2Params enx) l)))
    )
  )
  (princ (strcat "\n\tTime to Get Edges : " (rtos (- (getvar "MilliSecs") t0) 2 2) " ms."))
  (apply (function append) l)
)
(defun _Lw2Params (el / caaddddr cdaddddr rtn cls)
  (defun caaddddr (l) (caar (cddddr l)))
  (defun cdaddddr (l) (cdar (cddddr l)))
  (if (= 1 (cdr (assoc 70 el)))
    (setq cls t)
  )
  (setq el (member (assoc 10 el) el))
  (while (= 10 (caaddddr el))
    (setq rtn (cons (list (cdar el) (cdaddddr el)) rtn)
	  el  (cddddr el)
    )
  )
  (if cls
    (setq rtn (cons (list (cdar el) (car (last rtn))) rtn))
  )
  (reverse rtn)
)
(defun _sortxy (l)
  (vl-sort l
	   (function (lambda (a b)
		       (if (equal (car a) (car b) 1e-3)
			 (<= (cadr a) (cadr b))
			 (< (car a) (car b))
		       )
		     )
	   )
  )
)
(defun LM:Unique ( l / x r )
    (while l
        (setq x (car l)
              l (vl-remove x (cdr l))
              r (cons x r)
        )
    )
    (reverse r)
)
(defun ff1 (l fuz / e e1 l1 l2 t0 p a)
  (setq	t0 (getvar "MilliSecs")
	a  (/ 1 fuz)
  )
  (foreach e l (setq l1 (cons (_sortxy e) l1)))
  (setq	l  (vl-sort l1 (function (lambda (a b) (<= (caar a) (caar b)))))
	l1 nil
  )
  (while (setq e (car l))
    (setq l (cdr l))
    (while (and (setq e1 (car l)) (>= (car (last e)) (caar e1)))
      (setq l (cdr l))
      (if (setq p (inters (car e) (last e) (car e1) (last e1)))
	(setq e	 (vl-list* (car e) p (cdr e))
	      e1 (vl-list* (car e1) p (cdr e1))
	)
      )
      (setq l1 (cons e1 l1))
    )
    (if	l1
      (progn (foreach a l1 (setq l (cons a l)))
	     (setq l2 (cons (_UniqueFuzz (_sortxy e) fuz) l2)
		   l1 nil
	     )
      )
      (setq l2 (cons (_UniqueFuzz (_sortxy e) fuz) l2))
    )
  )
  (setq	l2 (apply (function append) (mapcar (function _grouppair) l2))
	l2 (vl-sort l2 (function (lambda (a b) (<= (caar a) (caar b)))))
	l1 nil
  )
  (setq	l2 (mapcar (function
		     (lambda (x)
		       (mapcar (function (lambda (p) (list (/ (fix (* (car p) a)) a) (/ (fix (* (cadr p) a)) a)))) x)
		     )
		   )
		   l2
	   )
  )
  (setq l2 (_UniqueFuzz l2 fuz))
  (princ "\n\tTime to calculate edges : ")
  (princ (- (getvar "MilliSecs") t0))
  (princ " ms\n")
  l2
)
(defun _grouppair (l / r)
  (if (cdr l)
    (cons (list (car l) (cadr l)) (_grouppair (cdr l)))
  )
)
(defun _UniqueFuzz (l f / x r)
  ;; l - list of "sorted" edges
  (while (setq x (car l))
    (setq l (cdr l))
    (while (and l (equal x (car l) fuz)) (setq l (cdr l)))
    (cond ((equal (car x) (cadr x) fuz))
	  ((setq r (cons x r)))
    )
  )
  (reverse r)
)
(defun sort_adj-ccw (p l lp / ang<2pi pi/2)
  (defun ang<2pi (a) (rem (+ pi pi a) (+ pi pi)))
  (setq	p    (nth p lp)
	l    (mapcar '(lambda (x) (cons x (nth x lp))) l)
	pi/2 (/ pi 2.)
  )
  (mapcar 'car
	  (vl-sort l
		   (function
		     (lambda (x y) (< (ang<2pi (+ pi/2 (angle p (cdr x)))) (ang<2pi (+ pi/2 (angle p (cdr y))))))
		   )
	  )
  )
)
(defun safearray-get (ar i) (read (vlax-safearray-get-element ar i)))
(defun safearray-put (ar i v) (vlax-safearray-put-element ar i (vl-prin1-to-string v)))
(defun get-neighbors (p GB) (safearray-get GB p))
(defun remove-neighbor (p n GB) (safearray-put GB p (vl-remove n (safearray-get GB p))))
(defun remove-chain (l GB / a b)
  (if (setq a (car l))
    (progn (foreach b (get-neighbors a GB)
	     (remove-neighbor a b GB)
	     (remove-neighbor b a GB)
	     (if (not (cadr (vl-remove a (get-neighbors b GB))))
	       (remove-chain (cons b (cdr l)) GB)
	       (remove-chain (cdr l) GB)
	     )
	   )
    )
  )
)
(defun nth- (a l)
  (if (= a (car l))
    (last l)
    (nth (1- (vl-position a l)) l)
  )
)
(defun f1 (a GB / a1 c c1 l1 l2 CC)
  (if (and (setq l1 (get-neighbors a GB)) (cadr l1))
    (progn (setq a1 a
		 l2 l1
	   )
	   (while (cadr l1)
	     (setq b  (car l1)
		   a  a1
		   c1 (list b a)
		   l1 (cdr l1)
	     )
	     (while (and (setq c (get-neighbors b GB)) (setq c (nth- a c)) (/= c (car l1)) (not (vl-position c c1)))
	       (setq c1	(cons c c1)
		     a	b
		     b	c
	       )
	     )
	     (if (and (>= (length c1) 2) (= (car l1) c))
	       (setq c1	(cons (car l1) c1)
		     cc	(cons c1 cc)
	       )
	     )
	   )
	   (mapcar '(lambda (x)
		      (remove-neighbor x a1 GB) ;(remove-neighbor a1 x GB)
		    )
		   l2
	   )
    )
  )
  cc
)
(defun f2 (le / lp lpi l1 l2 l3 l4 p t0)
  (setq t0 (getvar "MilliSecs"))
  (setq le (vl-sort le
                    (function (lambda (x y)
                                (if (equal (caar x) (caar y) 1e-3)
                                  (<= (cadar x) (cadar y))
                                  (< (caar x) (caar y))
                                )
                              )
                    )
           )
        lp  (apply (function append) le)
        lp  (vl-sort lp
                     (function (lambda (x y)
                                 (if (= (car x) (car y))
                                   (<= (cadr x) (cadr y))
                                   (< (car x) (car y))
                                 )
                               )
                     )
            )
        l1  nil
  )
  (while (setq p (car lp))    
    (if	(equal p (car l1) 1e-3)
      (setq lp (cdr lp))
      (setq l1 (cons p l1)
	    lp (cdr lp)
      )
    )
  )
  (setq lp  (reverse l1)
        lpi (vl-sort-i lp
                       (function (lambda (x y)
                                   (if (= (car x) (car y) )
                                     (<= (cadr x) (cadr y))
                                     (< (car x) (car y))
                                   )
                                 )
                       )
            )
        l4  lp
        l1  (mapcar (function car) le)
        l2  (mapcar (function cadr) le)
        l1 (f3 l1 lp)
        l2 (f3 l2 lp)
        le (mapcar (function list) l1 l2)
  )
  (princ (strcat "\n\tTime to process edges : "
                 (rtos (- (getvar "MilliSecs") t0))
                 " ms\n"
         )
  )
  (list lp lpi le)
)
(defun f3 (l1 l2 / p i j l3 li)
  (setq li (vl-sort-i l1
                       (function (lambda (x y)
                                   (if (= (car x) (car y) )
                                     (<= (cadr x) (cadr y))
                                     (< (car x) (car y))
                                   )
                                 )
                       )
            )
        l1 (vl-sort l1
                       (function (lambda (x y)
                                   (if (= (car x) (car y) )
                                     (<= (cadr x) (cadr y))
                                     (< (car x) (car y))
                                   )
                                 )
                       )
            )
        i  0
        l3 nil
  )
  (while (setq j 0
               p (car l1)
         )
    (while (and (equal (car p) (caar l1) 1e-3)
                (equal (cadr p) (cadar l1) 1e-3)
           )
      (setq j  (1+ j)
            l1 (cdr l1)
      )
    )
    (while (if (equal (car p) (caar l2) 1e-2)
             (not (equal (cadr p) (cadar l2) 1e-2))
             t
           )
      (setq i  (1+ i)
            l2 (cdr l2)
      )
    )
    (repeat j (setq l3 (cons i l3)))
  )
  (mapcar (function cdr)
          (vl-sort (mapcar (function cons) li (reverse l3))
                   (function (lambda (a b) (<= (car a) (car b))))
          )
  )
)
(defun _Lwpoly (lr lst cl)
  (entmakex (apply 'append
		   (list (list '(0 . "LWPOLYLINE")
			       (cons 100 "AcDbEntity")
			       (cons 8 lr)
			       (cons 62 cl)
			       (cons 100 "AcDbPolyline")
			       (cons 90 (length lst))
			       (cons 38 (caddr (trans '(0 0 0) 1 (trans '(0. 0. 1.) 1 0))))
			       (cons 70 1)
			 )
			 (mapcar '(lambda (x) (list 10 (car x) (cadr x))) lst)
			 (list (cons 210 (trans '(0. 0. 1.) 1 0)))
		   )
	    )
  )
)
(defun c:tt (/ l lp lpi le c cc t0 t1 t2 n GB GD GV i n tm)
  (progn (repeat 3 (gc))
	 (setq t0  (getvar "MilliSecs")
               L   (F2
		     (ff1 (_getedges (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget))))) 1e-3)
		   )
               t1 (getvar "MilliSecs")
	       lp  (car l)
	       lpi (cadr l)
	       le  (caddr l)
	       cc  nil
	       c   nil	       
	 )
	 (princ (strcat "\nNumber of vertex: " (itoa (length lp)) "."))
	 (princ (strcat "\nNumber of Edges : " (itoa (length le)) "."))
	 (setq n  (length lpi)
	       GB (vlax-make-safearray vlax-vbstring (cons 0 (1- n)))
	 )
	 (mapcar (function (lambda (x y)
			     (safearray-put GB x (cons y (safearray-get GB x)))
			     (safearray-put GB y (cons x (safearray-get GB y)))
			   )
		 )
		 (mapcar (function car) le)
		 (mapcar (function cadr) le)
	 )
	 (setq lb (mapcar (function read) (vlax-safearray->list GB))
	       i  -1
	       tm nil
	 )
	 (repeat n (setq i (1+ i)) (setq tm (cons (sort_adj-ccw i (nth i lb) lp) tm)))
	 (setq lb (reverse tm)
	       tm nil
	       i  -1
	 )
	 (mapcar (function (lambda (x) (safearray-put GB (setq i (1+ i)) x))) lb)
	 (if (setq i  -1
		   tm (vl-remove nil
				 (mapcar (function (lambda (x)
						     (setq i (1+ i))
						     (if (= (length x) 1)
						       i
						     )
						   )
					 )
					 lb
				 )
		      )
	     )
	   (remove-chain tm GB)
	 )
	 (foreach p lpi (setq c (f1 p GB)) (setq cc (cons c cc)))
	 (princ (strcat "\n\tTime to calculate polygons : " (rtos (- (setq t2 (getvar "MilliSecs")) t1)) " ms\n"))
	 (if cc
	   (progn (setq cc (vl-remove nil (apply 'append cc)))
		  (mapcar (function (lambda (c) (_Lwpoly "tmpp" (mapcar '(lambda (x) (nth x lp)) c) 44))) cc)
		  (princ (strcat "\n\tTime to Create polygons : " (rtos (- (getvar "MilliSecs") t2)) " ms\n"))
                  (princ (strcat "\n\tTotal time is : " (rtos (- (getvar "MilliSecs") t0)) " ms\n"))
		  (princ (strcat "\nTotal: " (itoa (length cc)) " polygons found./"))
	   )
	   (princ "\nThere is no Cycle found!")
	 )
  )
  (princ)
)

<<

Filename: 415138_tt.lsp
Tác giả: vietanh2108
Bài viết gốc: 415190
Tên lệnh: zhid chid
Nhờ Chỉnh Sửa Lisp Zoom Tới Handle Id

Em tìm được lisp này trên mạng với chức năng highlight và zoom tới đối tượng có Handle ID tương ứng. Nhờ bác nào đi qua giúp em thêm chức năng làm việc vơi 1 và cả với nhiều ID với.

Kiểu như em có list ID

A;B;C;D...

thì nó hightlight và zoom tất cả các đối tượng có ID trong chuỗi ngăn cách bởi ";"

Em xin chân thành cám ơn. :D

P/s: zhid để zoom tới, còn chid để tạo...

>>

Em tìm được lisp này trên mạng với chức năng highlight và zoom tới đối tượng có Handle ID tương ứng. Nhờ bác nào đi qua giúp em thêm chức năng làm việc vơi 1 và cả với nhiều ID với.

Kiểu như em có list ID

A;B;C;D...

thì nó hightlight và zoom tất cả các đối tượng có ID trong chuỗi ngăn cách bởi ";"

Em xin chân thành cám ơn. :D

P/s: zhid để zoom tới, còn chid để tạo text ID của đối tượng.

;Zoom to handle ID
    (defun c:zhid ( / YourHandle ll ur )
      (vl-load-com)
      (setq YourHandle (getstring "\nEnter Handle: "))
      (if (handent YourHandle)
        (progn
          (vla-getboundingbox (vlax-ename->vla-object (handent YourHandle)) 'll 'ur)
          (vla-zoomwindow (vlax-get-acad-object) ll ur)
          (sssetfirst nil (ssadd (handent YourHandle)))
        )
        (princ "\nHandle not in drawing")
      )
      (princ)
    )
;Tao Handle ID
(defun c:chid (/ ss n ed sz)
  (setq sz (getvar 'TextSize))
  (prompt "Select objects: ")
  (if (and (setq ss (ssget)) (setq n (sslength ss)))
    (while (>= (setq n (1- n)) 0)
      (setq ed (entget (ssname ss n)))
      (entmake (list '(0 . "TEXT")
                     (assoc 10 ed)
                     (cons 1 (cdr (assoc 5 ed)))
                     (cons 40 sz)
               )
      )
    )
  )
  (princ)
)

<<

Filename: 415190_zhid_chid.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 415219
Tên lệnh: zhid chid
Nhờ Chỉnh Sửa Lisp Zoom Tới Handle Id

Đây bạn!

;Zoom to handle ID
(defun c:zhid ( / YourHandle lst lst1 ss)
 (vl-load-com)
 (setq YourHandle (getstring "\nEnter List Handle: "))
 (setq lst (#String->ListString YourHandle ";"))
 (setq lst (mapcar 'handent (vl-remove-if '(lambda(x) (not (handent x))) lst)))
 (if lst
  (progn
   (setq lst1 (LM:ListBoundingBox (mapcar 'vlax-ename->vla-object lst)))
   (vla-zoomwindow...
>>

Đây bạn!

;Zoom to handle ID
(defun c:zhid ( / YourHandle lst lst1 ss)
 (vl-load-com)
 (setq YourHandle (getstring "\nEnter List Handle: "))
 (setq lst (#String->ListString YourHandle ";"))
 (setq lst (mapcar 'handent (vl-remove-if '(lambda(x) (not (handent x))) lst)))
 (if lst
  (progn
   (setq lst1 (LM:ListBoundingBox (mapcar 'vlax-ename->vla-object lst)))
   (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (car lst1)) (vlax-3d-point (cadr lst1)))
   (setq ss (ssadd)) (foreach s lst (ssadd s ss)) (sssetfirst nil ss))
  (princ "\nHandle not in drawing"))
 (princ))
;Tao Handle ID
(defun c:chid (/ ss n ed sz)
 (setq sz (getvar 'TextSize))
 (prompt "Select objects: ")
 (if (and (setq ss (ssget)) (setq n (sslength ss)))
  (while (>= (setq n (1- n)) 0)
   (setq ed (entget (ssname ss n)))
   (entmake (list '(0 . "TEXT") (assoc 10 ed) (cons 1 (cdr (assoc 5 ed))) (cons 40 sz)))))
 (princ))
(defun LM:ListBoundingBox ( objlst / l1 l2 ll ur )
 (foreach obj objlst
  (vla-getboundingbox obj 'll 'ur)
  (setq l1 (cons (vlax-safearray->list ll) l1) l2 (cons (vlax-safearray->list ur) l2)))
  (mapcar (function (lambda (a b) (apply 'mapcar (cons a b)))) '(min max) (list l1 l2)))
;; Convert String to List of Strings. EX1: (#String->ListString "1,2,3" ",") >> ("1" "2" "3") ; EX2: (#String->ListString "1ab2ab3" "ab") >> ("1" "2" "3")
(defun #String->ListString(str del / pos lst) (while (setq pos (vl-string-search del str)) (setq lst (cons (substr str 1 pos) lst) str (substr str (+ pos 1 (strlen del))))) (reverse (cons str lst)))

<<

Filename: 415219_zhid_chid.lsp
Tác giả: quansla
Bài viết gốc: 335993
Tên lệnh: hh
Kiểm tra layer để thực hiện lệnh

Chào các bác. Em tìm trên diễn đàn mà không thấy có chủ đề nào em thắc mắc. Em nhờ các bác viết cho e cái lisp tên là HH để hatch vật liệu với yêu cầu như sau:
Ví dụ bản vẽ của e có  layer là: (HTS)-Hatch. Em muốn khi thực hiện lệnh HH, lisp sẽ kiểm tra xem bản vẽ có layer (HTS)-Hatch không, nếu tìm thấy thì...

>>

Chào các bác. Em tìm trên diễn đàn mà không thấy có chủ đề nào em thắc mắc. Em nhờ các bác viết cho e cái lisp tên là HH để hatch vật liệu với yêu cầu như sau:
Ví dụ bản vẽ của e có  layer là: (HTS)-Hatch. Em muốn khi thực hiện lệnh HH, lisp sẽ kiểm tra xem bản vẽ có layer (HTS)-Hatch không, nếu tìm thấy thì Hatch vật liệu bằng layer (HTS)-Hatch. Nếu không tìm thấy thì Hatch vật liệu bằng layer đang hiện hành
 
em xin cảm ơn các bác. Chúc các bác ngày mới vui vẻ  :)  :)  :)  :)  :)

Nếu bạn biết về lisp thì hàm sau sẽ cho phép cho bạn kiểm tra layer (HTS)-Hatch có trong bản vẽ không
(tblsearch "layer" "(HTS)-Hatch")
Để kiểm tra bạn cũng có thể dùng code trên nhưng thay "0" vào "(HTS)-Hatch")" để thành
(tblsearch "layer" "0")
hàm sẽ trả về nil nếu không có layer tương ứng, và trả về Lisp nếu có Layer này trong bản vẽ
Về yêu cầu của bạn, bạn yêu cầu rõ hơn thì sẽ dễ hơn. chẳng hạn : sau khi dùng xong lệnh HH thì cad hiện hộp thoại Hatch lên hay là chỉ cần đổi mặc định layer Hatch là layer "(HTS)-Hatch"
thì có thể dùng

(defun c:HH()
(if (tblsearch "layer" "(HTS)-Hatch")
(setvar "HPLAYER" "(HTS)-Hatch")
(setvar "HPLAYER" (getvar "clayer"))
))

<<

Filename: 335993_hh.lsp
Tác giả: Tue_NV
Bài viết gốc: 42502
Tên lệnh: dlm
Viết Lisp theo yêu cầu

Mình đã check kỹ lại rồi. Không có lỗi gì trong đoạn code này :
Lệnh là DLM

Filename: 42502_dlm.lsp
Tác giả: jangboko
Bài viết gốc: 415410
Tên lệnh: sq
Nhờ Sửa Lisp Chon Nhanh Tất Cả Dim Và Leader
 ;; free lisp from cadviet.com
;; this lisp was downloaded from <a href="http://www.cadviet.com/forum/topic/56306-da-xong-lisp-chon-nhieu-doi-tuong-giong-nhau/" class="bbc_url" title="">http://www.cadviet.c...ong-giong-nhau/
(defun c:sq(/ aaa ls dt dt1 sdt sdt1 ent ent1 id id1)
  (setq AAA(SSGET)
sdt (sslength AAA)
id 0
dt (ssadd)
)
  (repeat ;;repeat1
	(setq ent (ssname AAA id)
id (1+ id)
);;setq
	(setq ls (entget ent))
	(if (= (cdr (assoc 0...
>>
 ;; free lisp from cadviet.com
;; this lisp was downloaded from <a href="http://www.cadviet.com/forum/topic/56306-da-xong-lisp-chon-nhieu-doi-tuong-giong-nhau/" class="bbc_url" title="">http://www.cadviet.c...ong-giong-nhau/
(defun c:sq(/ aaa ls dt dt1 sdt sdt1 ent ent1 id id1)
  (setq AAA(SSGET)
sdt (sslength AAA)
id 0
dt (ssadd)
)
  (repeat ;;repeat1
	(setq ent (ssname AAA id)
id (1+ id)
);;setq
	(setq ls (entget ent))
	(if (= (cdr (assoc 0 ls)) "INSERT")
  	(get-block ent)
  	(setq dt1 (ssget (list(assoc 0 ls) (assoc 8 ls))))
  	);;if
	(setq sdt1 (sslength dt1)
   id1 -1)
	(while (setq ent1(ssname dt1 (setq id1 (1+ id1))))
  	(setq dt (ssadd ent1 dt))
  	);;While
	(sssetfirst dt dt)
	(princ)
	);;repeat1
  )
;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-block(entm / sdtb idb ent2 entb dtm namem name BBB entb)
  (setq dtm (vlax-ename->vla-object entm))
  (setq namem (if(vlax-property-available-p dtm 'effectivename)
   (vla-get-effectivename dtm)
   (vla-get-name dtm)
   ));;;
  (setq BBB(SSGET  (list(cons 0 "INSERT") (assoc 8 (entget entm))))
sdtb (sslength BBB)
idb 0
dt1 (ssadd)
)
  (repeat ;;repeat1
	(setq entb (ssname BBB idb)
idb (1+ idb)
)
	(setq ent2(vlax-ename->vla-object entb))
	(setq name (if(vlax-property-available-p ent2 'effectivename)
   (vla-get-effectivename ent2)
   (vla-get-name ent2)
   ))
	(if (= name namem)
  	(setq dt1 (ssadd entb dt1))
  	)
	)
  )

 

 

bên trên là lisp chon đối tượng giống đối tượng chọn trước, em nhờ các bác có thể chỉnh sửa cho em thành lisp chọn dim và leader  trong toàn bản vẽ với. Lisp hoạt động như sau: 

- Khi gõ lệnh  cd thì tất cả các dim, leader trong bản vẽ sẽ được chọn 

mục đích của em để sau đó dùng lệnh DIMDISASSOCIATE để cho các dim  khỏi bị nhảy ( em dùng layout nên buộc phải chọn cái mục  Make new dimension  associative nên dim nó hay bị nhảy)

P/S: bác có thể kết hợp 2 lệnh này ( chọn tất cả các dim +leader và lệnh 

DIMDISASSOCIATE ) thành 1 thì tuyệt vời.  Em xin cảm ơn diễn đàn

 

 



<<

Filename: 415410_sq.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 415411
Tên lệnh: cd
Nhờ Sửa Lisp Chon Nhanh Tất Cả Dim Và Leader

(defun C:CD()
 (sssetfirst nil (ssget "X" '((0 . "DIMENSION,LEADER")))))

Filename: 415411_cd.lsp
Tác giả: a12k39duchao
Bài viết gốc: 415576
Tên lệnh: tt
Chỉnh Sửa Lisp Để Lisp Lấy Thêm Được Giá Trị Chiều Dài Của *line

Nhờ các Anh Chị bổ sung thêm câu lệnh vào lisp của A ketxu để lisp này có thể xuất ra giá trị của chiều dài *line nữa ạ!

Cảm ơn tất cả mọi người!

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/55599-yeu-cau-lisp-lay-gia-tri-cua-dimenson-text-va-xuat-ra-file-text/


(defun C:tt(/ lst fn fw i j) ;Doan Van Ha Cadviet.com

(princ "\nChon cac...
>>

Nhờ các Anh Chị bổ sung thêm câu lệnh vào lisp của A ketxu để lisp này có thể xuất ra giá trị của chiều dài *line nữa ạ!

Cảm ơn tất cả mọi người!

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/55599-yeu-cau-lisp-lay-gia-tri-cua-dimenson-text-va-xuat-ra-file-text/


(defun C:tt(/ lst fn fw i j) ;Doan Van Ha Cadviet.com

(princ "\nChon cac Text/Mtext/Dimension can xuat ra file...")

(setq lst (mapcar 'entget (acet-ss-to-list (ssget '((0 . "*TEXT,DIMENSION")))))

    	fn (getfiled "Chon file de save" "" "csv" 1)

    	fw (open fn "w") i 0 j 0)

(foreach n lst

(princ

  (cond

   ((wcmatch (cdadr n) "*TEXT")(strcat (acet-dxf 1 n) ";Text" (itoa (setq i (1+ i))) "\n"))  

   ((= (cdadr n) "DIMENSION")(strcat (if (= (acet-dxf 1 n) "")(rtos (acet-dxf 42 n))(acet-dxf 1 n))  ";Dim" (itoa (setq j (1+ j))) "\n"))

  )

   fw

  )

  )

(close fw))




<<

Filename: 415576_tt.lsp
Tác giả: Tue_NV
Bài viết gốc: 415584
Tên lệnh: tt
Chỉnh Sửa Lisp Để Lisp Lấy Thêm Được Giá Trị Chiều Dài Của *line

Của em đây:

(defun C:tt(/ lst fn fw i j d)
 
(princ "\nChon cac Text/Mtext/Dimension can xuat ra file...")
 
(setq lst (mapcar 'entget (acet-ss-to-list (ssget '((0 . "*TEXT,DIMENSION,*LINE")))))
 
     fn (getfiled "Chon file de save" "" "csv" 1)
 
     fw (open fn "w") i 0 j 0 d 0)
 
(foreach n lst
 
(princ
 
  (cond
 
   ((wcmatch (cdadr n) "*TEXT")(strcat...
>>

Của em đây:

(defun C:tt(/ lst fn fw i j d)
 
(princ "\nChon cac Text/Mtext/Dimension can xuat ra file...")
 
(setq lst (mapcar 'entget (acet-ss-to-list (ssget '((0 . "*TEXT,DIMENSION,*LINE")))))
 
     fn (getfiled "Chon file de save" "" "csv" 1)
 
     fw (open fn "w") i 0 j 0 d 0)
 
(foreach n lst
 
(princ
 
  (cond
 
   ((wcmatch (cdadr n) "*TEXT")(strcat (acet-dxf 1 n) ";Text" (itoa (setq i (1+ i))) "\n"))  
 
   ((= (cdadr n) "DIMENSION")(strcat (if (= (acet-dxf 1 n) "")(rtos (acet-dxf 42 n))(acet-dxf 1 n))  ";Dim" (itoa (setq j (1+ j))) "\n"))
   ((wcmatch (cdadr n) "*LINE") (strcat (rtos (vlax-curve-getdistatparam (cdar n) (vlax-curve-getendparam  (cdar n))) ) ";*Line" (itoa (setq d (1+ d))) "\n"))
 
  )
 
   fw
 
  )
 
  )
 
 
(close fw)
    (command "._ai_editcustfile" fn))

<<

Filename: 415584_tt.lsp

Trang 217/303

217