Đến nội dung


Hình ảnh
- - - - -

[YÊU CẦU] Xin lisp chuyển layer của các đối tượng trong block về cùng layer của block


  • Please log in to reply
16 replies to this topic

#1 rongvuong

rongvuong

    biết zoom

  • Members
  • Pip
  • 12 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 04 January 2013 - 09:43 PM

nếu đã có xin mõi người share giúp
em tìm mãi ko thấy
  • 0

#2 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 05 January 2013 - 09:24 AM

nếu đã có xin mõi người share giúp
em tìm mãi ko thấy

Hề hề hề,
Lisp này chắc chắn đã có trên diễn đàn. Chịu khó kiếm một chút sẽ thấy.Gõ từ khóa cbl thử coi.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#3 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 05 January 2013 - 09:39 AM

Lisp chuyển tất cả đối tượng trong block về cùng layer của block.

;Doan Van Ha - CADViet.com - Ngay 05/01/2013
;Chuc nang: chuyen tat ca doi tuong trong block ve cung layer cua block.
(defun C:HA ( / acdoc acblk ss )
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
acblk (vla-get-blocks acdoc))
(if (setq ss (ssget "_+.:E:S" '((0 . "INSERT"))))
(LM:ApplytoBlockObjects acblk (cdr (assoc 2 (entget (ssname ss 0))))
(function
(lambda (obj) (vla-put-Layer obj (vla-get-Layer (vlax-ename->vla-object (ssname ss 0))))))))
(princ))
(defun LM:ApplytoBlockObjects ( _acblocks _blockname _function / result )
((lambda ( _function / def )
(if
(not
(vl-catch-all-error-p
(setq def
(vl-catch-all-apply 'vla-item (list _acblocks _blockname)))))
(vlax-for obj def (setq result (cons (_function obj) result)))))
(eval _function))
(reverse result))

  • 4

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#4 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 05 January 2013 - 11:54 AM

Gọn quá đâm ra lần nào cũng phải tính lại layer bác ạ :)
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#5 Polyline

Polyline

    biết lệnh mirror

  • Members
  • PipPipPip
  • 159 Bài viết
Điểm đánh giá: 18 (tàm tạm)

Đã gửi 18 July 2013 - 09:56 AM

Lisp của bác HA rất tốt đối với trường hợp đơn giản. Với Block lồng nhau thì vẫn chưa xử lý triệt để được.


  • 0

#6 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1360 (rất tốt)

Đã gửi 18 July 2013 - 10:56 AM

Chi bằng ta đổi tất cả các đối tượng trong block thành layer 0 màu bylayer như vậy nó sẽ tự thành như ý nhỉ.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;sua ma dxf block
;;;Cu phap su dung (duy:block_s_dxf block mdxf thanh)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun block_s_dxf (blk mdxf thanh /  e el name ob lname name mdxf thanh)
(setq name (cdr (assoc 2 (entget blk))))
(if (not (member name lname))
(progn
(setq lname (append lname (list name)))
(setq e (cdr (assoc -2 (tblsearch "BLOCK" name))))
(while e
(setq el (entget e))

(cond 
((wcmatch (cdr (assoc 0 el)) "INSERT") (block_s_dxf e mdxf thanh) )
)

(setq Ent (subst (cons mdxf thanh) (assoc mdxf el) el))
(entmod ent)
(setq e (entnext e))  
);while
);progn
);if
(command ".move" (ssget "x" (list (cons 0 "INSERT")(cons 2 name))) "" (list 0 0 0) (list 0 0 0))
)

(DEFUN C:dlb ()
(setq dttd (car(entsel "Chon BLOCK!")))
(block_s_dxf dttd 8 "0")
(block_s_dxf dttd 62 256)
)

  • 1

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#7 Polyline

Polyline

    biết lệnh mirror

  • Members
  • PipPipPip
  • 159 Bài viết
Điểm đánh giá: 18 (tàm tạm)

Đã gửi 18 July 2013 - 11:38 AM

Nhưng yêu cầu của người ta là chuyển các đối tượng bên trong Block về cùng layer với Block mà bạn! Như vậy có thể có nhiều Block khác nhau nằm ở nhiều layer khác nhau.

 

P/S: Trong code của bạn có lệnh Move từ (0,0) về (0,0) để làm gì vậy bạn?


  • 0

#8 Polyline

Polyline

    biết lệnh mirror

  • Members
  • PipPipPip
  • 159 Bài viết
Điểm đánh giá: 18 (tàm tạm)

Đã gửi 18 July 2013 - 11:57 AM

...Lisp này chắc chắn đã có trên diễn đàn...

Có phải ở đây không bạn:
http://www.cadviet.c...er/#entry125869
Mình tìm thấy các lệnh CBL, nhưng không có cái nào đáp ứng đúng yêu cầu của topic này cả!


  • 0

#9 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1360 (rất tốt)

Đã gửi 18 July 2013 - 01:57 PM

Nhưng yêu cầu của người ta là chuyển các đối tượng bên trong Block về cùng layer với Block mà bạn! Như vậy có thể có nhiều Block khác nhau nằm ở nhiều layer khác nhau.

 

P/S: Trong code của bạn có lệnh Move từ (0,0) về (0,0) để làm gì vậy bạn?

1.Ở đây là chuyễn tất cả các đtưiợng trong block (kể cả lồng nhau) về layer 0 và màu bylayer. Còn layer của block không có thay đổi. Nghĩa là nếu block uyuy có trên bản vẽ 1000 cái và thuộc 1000 layer khác nhau thì chỉ cần thao tác với 1 block uyuy bất kỳ lúc này tự khắc các block uyuy có trong bản vẽ sẽ hiển thị thành màu mà block đang thuộc (đây là tính chất hay mà khi tạo block mình hay tạo từ layer 0 và màu bylayer)

2.Move như vậy tác dụng cập nhật trạng thái hiển thị của block vừa được sửa (cad2007 nếu ko làm vậy thì chưa cập nhật trạng thái hiển thị)


  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#10 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 18 July 2013 - 03:25 PM

Xét cả block lồng nhiều tầng.

;; Convert Layer cua cac doi tuong ben trong block (co the long nhau) ve cung Layer cua Block chinh.
;; Doan Van Ha - CadViet.com - ngay 18/7/2013
(defun C:HA ( / ent1 obj1 )
 (if (setq ent1 (car (entsel "\nChon Block: ")))
  (foreach obj (Get_lst_Obj (vla-get-Name (setq obj1 (vlax-ename->vla-object ent1))))
   (vla-put-Layer obj (vla-get-Layer obj1))))
 (vla-update obj1))
(defun Get_lst_Obj (blkname / lst)
 (vlax-for each (vla-Item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) blkname)
  (if (/= (vla-get-ObjectName each) "AcDbBlockReference")
   (setq lst (cons each lst))
   (setq lst (append (Get_lst_Obj (vla-get-Name each)) lst))))
 lst)

  • 5

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#11 Polyline

Polyline

    biết lệnh mirror

  • Members
  • PipPipPip
  • 159 Bài viết
Điểm đánh giá: 18 (tàm tạm)

Đã gửi 18 July 2013 - 05:22 PM

Vote!!! :D
Đúng là với block lồng nhiều tầng, dùng đệ quy cho ra kết quả không thể tốt hơn được!! Đợt này bác HA viết trực tiếp không dùng anh LeeMac nữa mà kết quả vẫn ngắn gọn.
  • 0

#12 dragontalon0802

dragontalon0802

    biết lệnh erase

  • Members
  • PipPipPip
  • 103 Bài viết
Điểm đánh giá: 4 (bình thường)

Đã gửi 19 July 2013 - 10:11 AM

Lisp bác Hà hay tuyệt, tuy nhiên nếu có thể chọn 1 lúc nhiều đối tượng block bằng cách quét chuột chứ ko phải chọn từng cái thì nó sẽ lợi hại hơn nhiều bác à.

Hy vọng bác dành ít thời gian cải tiến cho mọi người có lisp hay để dùng.


  • 0

#13 ndtnv

ndtnv

    biết lệnh minsert

  • Members
  • PipPipPipPipPipPip
  • 437 Bài viết
Điểm đánh giá: 384 (khá)

Đã gửi 19 July 2013 - 10:52 AM

Đầu tiên xin khen ngợi bạn đã viết nhiều Lisp giúp đỡ rất nhiều người. Đối với lisp này tôi không dùng vì kết quả sẽ thay đổi linetype và lineweight của các đối tượng trong block.
Tôi có 1 vài góp ý bạn Doan Van Ha như sau:
1. Lisp nào của bạn cũng dùng lệnh C:HA nên người nào đó bấm Download không cẩn thận thì sẽ ghi đè lên các file cũ.
2. Khi undo sẽ không về trạng thái cũ
3. Bạn dùng code quá rút gọn mà bỏ qua thời gian thi hành (mặc dù không đáng kể đối với các block nhỏ):
-Nếu block có nhiều block con cùng tên, Get_lst_Obj sẽ trả về rất nhiều đối tượng trùng nhau.
-Hàm vla-get-Layer thực hiện quá nhiều lần như bạn ketxu nhận xét ở trên.
  • 1

#14 Polyline

Polyline

    biết lệnh mirror

  • Members
  • PipPipPip
  • 159 Bài viết
Điểm đánh giá: 18 (tàm tạm)

Đã gửi 19 July 2013 - 11:58 AM

Theo mình, về tính thực dụng thì Lisp của bác HA hoàn toàn đạt yêu cầu đã đặt ra.
Về code thì cũng có vài vấn đề, ví dụ nó sẽ báo lỗi nếu người dùng nhấn enter ở dong nhắc "Chon Block: ".

Tuy nhiên, nếu lấy mục tiêu là tính ứng dụng của nó thì những lỗi này hoàn toàn không đáng ngại ... dùng tốt!!

(tốt hơn cả của bác Lee Mac nữa là...) :D


  • 0

#15 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 21 July 2013 - 09:37 AM

Chưa hạn chế được hết tất cả các khiếm khuyết, nhưng cái này có "khá" hơn.

;; Convert Layer cua cac doi tuong ben trong block (co the long nhau) ve cung Layer cua Block chinh. De Undo tat ca: dung lenh "U" + "Regen"
;; Doan Van Ha - CadViet.com - ngay 21/7/2013
(defun C:HA ( / doc blkname lay)
 (princ "\nChon cac Blocks...")
 (if (ssget '((0 . "INSERT")))
  (progn
   (vlax-for obj (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
    (setq blkname (vla-get-Name obj)
          lay (vla-get-Layer obj))
    (mapcar '(lambda(o) (vla-put-Layer o lay)) (Get_lst_Obj doc blkname)))
   (vla-Regen doc acActiveViewport))))
(defun Get_lst_Obj (doc blkname / lst)
 (vlax-for blk (vla-Item (vla-get-Blocks doc) blkname)
  (if (/= (vla-get-ObjectName blk) "AcDbBlockReference")
   (if (not (vl-position blk lst))
    (setq lst (cons blk lst)))
   (setq lst (append (Get_lst_Obj doc (vla-get-Name blk)) lst)))))
 

  • 2

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#16 nguyencanh160890

nguyencanh160890

    Edu level: ao5

  • Members
  • PipPip
  • 77 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 15 October 2013 - 11:03 AM

Chưa hạn chế được hết tất cả các khiếm khuyết, nhưng cái này có "khá" hơn.

 

;; Convert Layer cua cac doi tuong ben trong block (co the long nhau) ve cung Layer cua Block chinh. De Undo tat ca: dung lenh "U" + "Regen"
;; Doan Van Ha - CadViet.com - ngay 21/7/2013
(defun C:HA ( / doc blkname lay)
 (princ "\nChon cac Blocks...")
 (if (ssget '((0 . "INSERT")))
  (progn
   (vlax-for obj (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
    (setq blkname (vla-get-Name obj)
          lay (vla-get-Layer obj))
    (mapcar '(lambda(o) (vla-put-Layer o lay)) (Get_lst_Obj doc blkname)))
   (vla-Regen doc acActiveViewport))))
(defun Get_lst_Obj (doc blkname / lst)
 (vlax-for blk (vla-Item (vla-get-Blocks doc) blkname)
  (if (/= (vla-get-ObjectName blk) "AcDbBlockReference")
   (if (not (vl-position blk lst))
    (setq lst (cons blk lst)))
   (setq lst (append (Get_lst_Obj doc (vla-get-Name blk)) lst)))))
 

Anh cho em hỏi luôn. em tải lisp này về, và dùng tại sao block của em không đổi về màu 8 ? mà vẫn giữ nguyên màu trắng???

em muốn dùng lisp chuyển toàn bộ block trong file đính kèm, chuyển thành màu 8 nhưng block vẫn giữ nguyên.


  • -1

#17 htqk9

htqk9

    biết vẽ circle

  • Members
  • PipPip
  • 38 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 29 October 2014 - 11:00 AM

Chi bằng ta đổi tất cả các đối tượng trong block thành layer 0 màu bylayer như vậy nó sẽ tự thành như ý nhỉ.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;sua ma dxf block
;;;Cu phap su dung (duy:block_s_dxf block mdxf thanh)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun block_s_dxf (blk mdxf thanh /  e el name ob lname name mdxf thanh)
(setq name (cdr (assoc 2 (entget blk))))
(if (not (member name lname))
(progn
(setq lname (append lname (list name)))
(setq e (cdr (assoc -2 (tblsearch "BLOCK" name))))
(while e
(setq el (entget e))

(cond 
((wcmatch (cdr (assoc 0 el)) "INSERT") (block_s_dxf e mdxf thanh) )
)

(setq Ent (subst (cons mdxf thanh) (assoc mdxf el) el))
(entmod ent)
(setq e (entnext e))  
);while
);progn
);if
(command ".move" (ssget "x" (list (cons 0 "INSERT")(cons 2 name))) "" (list 0 0 0) (list 0 0 0))
)

(DEFUN C:dlb ()
(setq dttd (car(entsel "Chon BLOCK!")))
(block_s_dxf dttd 8 "0")
(block_s_dxf dttd 62 256)
)

@Pham Quoc DuyCái này ngon rồi nhưng bạn có thể edit lại tý xíu phần select object như trong cad không...ví dụ chọn đối tượng theo p, c, w, l, cp, wp...thk so much


Bài viết đã được chỉnh sửa nội dung bởi htqk9: 29 October 2014 - 11:02 AM

  • 0
...nothing 4ever...