Đến nội dung


Hình ảnh
* * * - - 8 Bình chọn

Viết lisp theo yêu cầu [phần 2]


  • Chủ đề bị khóa Chủ đề bị khóa
3783 replies to this topic

#2781 nguyentuyen6

nguyentuyen6

    biết lệnh chamfer

  • Advance Member
  • PipPipPipPip
  • 213 Bài viết
Điểm đánh giá: 124 (tàm tạm)

Đã gửi 29 November 2010 - 07:35 PM

[quote name='hugo75' post='120075' date='Nov 29 2010, 18:49']E sưu tầm được 1 lisp vẽ ký hiệu đối xứng.Nhưng khi vẽ xong nó không phải block,e lại không biết lisp.Nhờ các bác sửa giùm khi vẽ xong nó là 1 block.Thanks.
(DEFUN C:dx (/ CMD OSM OLDERR PT1 PT2 PT3 PT4 PT5 PT6 PT7 PT8 PT9
SZ G45 G135 G90 G180 SS loi)
(defun loi (s)
(if (= s "Function cancelled")
(princ)
(princ (strcat "Error:" s))
)
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(SETQ *error* OLDERR)
(PRINC)
)
;;***************************************
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETVAR "CMDECHO" 0)
(SETQ OLDERR *error*
*error* loi)
(SETQ SZ (GETREAL "\nSize <1>:"))
(SETQ bn (getstring "\nTen block:"))
(IF (= SZ nil) (SETQ SZ 100))
(SETQ G45 (/ PI 4))
(SETQ G135 (* 3 (/ PI 4)))
(SETQ G90 (- G45 (/ PI 2)))
(SETQ G180 (+ G135 (/ PI 2)))
(SETQ PT1 (GETPOINT "\nDiem doi xung:"))
(SETVAR "OSMODE" 0)
(SETQ PT2 (POLAR PT1 G45 (* 2 SZ)))
(SETQ PT3 (POLAR PT2 G90 (* 2 SZ)))
(SETQ PT4 (POLAR PT1 G45 (* 1 SZ)))
(SETQ PT5 (POLAR PT1 G135 (* 2 SZ)))
(SETQ PT6 (POLAR PT5 G180 (* 2 SZ)))
(SETQ PT7 (POLAR PT1 G135 (* 1 SZ)))
(SETQ PT8 (POLAR PT1 G45 (* -0.7 SZ)))
(SETQ PT9 (POLAR PT1 G135 (* -0.7 SZ)))
(PRINC "\nGoc quay:")
(SETQ SS (SSADD))
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "150" "")
(COMMAND "LINE" PT8 PT2 "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "LINE" PT9 PT5 "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "COLOR" "7" "")
(COMMAND "SOLID" PT2 PT3 PT4 "" "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "SOLID" PT5 PT6 PT7 "" "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "ROTATE" SS "" PT1 PAUSE)
(command "_.BLOCK" bn PT1 ss ""
"_.INSERT" bn PT1 1 1 0)
(COMMAND "COLOR" "BYLAYER" "")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(SETQ *error* OLDERR)
(PRINC)
)

  • 2

Lisp In bản vẽ hàng loạt:
http://www.cadviet.c...ndpost&p=139860


#2782 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 29 November 2010 - 07:43 PM

[quote name='hugo75' post='120075' date='Nov 29 2010, 18:49']E sưu tầm được 1 lisp vẽ ký hiệu đối xứng.Nhưng khi vẽ xong nó không phải block,e lại không biết lisp.Nhờ các bác sửa giùm khi vẽ xong nó là 1 block.Thanks.

;; free lisp from cadviet.com
(DEFUN C:dx (/ CMD OSM OLDERR PT1 PT2 PT3 PT4 PT5 PT6 PT7 PT8 PT9
        SZ G45 G135 G90 G180 SS loi)
(defun loi (s)
(if (= s "Function cancelled")
     (princ)
     (princ (strcat "Error:" s))
)
    (SETVAR "CMDECHO" CMD)
    (SETVAR "OSMODE" OSM)
    (SETQ *error* OLDERR)
    (PRINC)
)
;;***************************************
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETVAR "CMDECHO" 0)
(SETQ OLDERR *error*
    *error* loi)
(SETQ SZ (GETREAL "Size <1>:"))
(IF (= SZ nil) (SETQ SZ 1))
(SETQ G45 (/ PI 4))
(SETQ G135 (* 3 (/ PI 4)))
(SETQ G90 (- G45 (/ PI 2)))
(SETQ G180 (+ G135 (/ PI 2)))
(SETQ PT1 (GETPOINT "\nDiem doi xung:"))
(SETVAR "OSMODE" 0)
(SETQ PT2 (POLAR PT1 G45 2))
(SETQ PT3 (POLAR PT2 G90 2))
(SETQ PT4 (POLAR PT1 G45 1))
(SETQ PT5 (POLAR PT1 G135 2))
(SETQ PT6 (POLAR PT5 G180 2))
(SETQ PT7 (POLAR PT1 G135 1))
(SETQ PT8 (POLAR PT1 G45 -0.7))
(SETQ PT9 (POLAR PT1 G135 -0.7))
(PRINC "\nGoc quay:")
(SETQ SS (SSADD))
(if (= (tblsearch "block" "trucdoixung") nil)
(progn
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "150" "")
(COMMAND "LINE" PT8 PT2 "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "LINE" PT9 PT5 "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "COLOR" "7" "")
(COMMAND "SOLID" PT2 PT3 PT4 "" "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "SOLID" PT5 PT6 PT7 "" "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "block" "trucdoixung" PT1 ss "")
(command "insert" "trucdoixung" PT1 sz sz "")
)
(command "insert" "trucdoixung" PT1 sz sz "")
)
(COMMAND "ROTATE" "l" "" PT1 PAUSE)
(COMMAND "COLOR" "BYLAYER" "")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(SETQ *error* OLDERR)
(PRINC)
)

  • 2
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2783 hugo75

hugo75

    biết vẽ polygon

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

Đã gửi 29 November 2010 - 09:06 PM

Cảm ơn các bác rất nhiều.
Trong dòng:
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "150" "")
(COMMAND "LINE" PT8 PT2 "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "LINE" PT9 PT5 "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "COLOR" "7" "")
(COMMAND "SOLID" PT2 PT3 PT4 "" "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "SOLID" PT5 PT6 PT7 "" "")
(SETQ SS (SSADD (ENTLAST) SS))...
Theo e hiểu layer của block là "ghichu"
Màu của 2 đường xéo là màu số 7
Màu của solid là màu số 7 luôn.Em muốn 2 đường xéo là layer DUONGTHANG màu số 8,solid là layer TOMAU màu sô 3 thì sửa làm sao?Thanks.
  • 0

#2784 18011985

18011985

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 255 Bài viết
Điểm đánh giá: 61 (tàm tạm)

Đã gửi 30 November 2010 - 07:51 AM

Hề hề hề,
Đền cho bạn cái nè, chạy thử coi có cười nổi không nhé. Thôi nín đi mà.....


(defun c:ctxt ( / oldos ss1 ss2 els p1 t1 t2 )
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq ss1 (acet-ss-to-list (ssget "x" (list (cons 0 "text")))))
(While (/= ss1 nil)
(setq x (nth 0 ss1)
els (entget x)
p1 (cdr (assoc 10 els))
t1 (atof (cdr (assoc 1 els)))
)
(if (/= t1 0.0)
(progn
(setq ss2 (acet-ss-to-list (ssget "x" (list (cons 0 "text") (cons 10 p1)))))
(if (/= ss2 nil)
(progn
(foreach y ss2
(if (not (equal x y))
(progn
(setq t2 (atof (cdr (assoc 1 (entget y)))))
(if (/= t2 0.0)
(progn
(setq t1 (+ t1 t2))
(command "erase" y "")
(setq ss1 (vl-remove y ss1))
)
)
)
)
)
(setq els (subst (cons 1 (rtos t1 2 0)) (assoc 1 els) els))
(entmod els)
)
)
)
)
(setq ss1 (vl-remove x ss1))
)
(setvar "osmode" oldos)
)


Mà cái nè là chỉ xài để cộng các TEXT thôi nghen. MTEXT thì chưa xét. và cũng chỉ cộng những thằng có chung điểm đặt mã dxf10 thôi nhé. Những cái khác để xét sau, nếu bạn Ok thì mới nói chuyện tiếp được. bằng không thì mình sẽ khóc thay bạn vậy. Hề hề hề....

Chuẩn nhưng mình vẫn cần chỉnh một chút hì hì. Nhưng dù sao cũng thanks bạn. Mình làm theo cách khác để chạy từ cad14-cad2010 hì hì. không phụ thuộc vào Express
  • 1
Trăng 16 trăng tròn
Em 16 bụng ... như trăng

Hướng dẫn sử dụng diễn đàn:
Để cảm ơn hay bài viết có ích: Ấn dấu + cuối bài.
Không vừa lòng hay bài spam: Ấn dấu - cuối bài.

#2785 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 30 November 2010 - 08:08 AM

Cảm ơn các bác rất nhiều.
Trong dòng:
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "150" "")
(COMMAND "LINE" PT8 PT2 "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "LINE" PT9 PT5 "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "COLOR" "7" "")
(COMMAND "SOLID" PT2 PT3 PT4 "" "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "SOLID" PT5 PT6 PT7 "" "")
(SETQ SS (SSADD (ENTLAST) SS))...
Theo e hiểu layer của block là "ghichu"
Màu của 2 đường xéo là màu số 7
Màu của solid là màu số 7 luôn.Em muốn 2 đường xéo là layer DUONGTHANG màu số 8,solid là layer TOMAU màu sô 3 thì sửa làm sao?Thanks.

Chào bạn Hugo75!
1. Layer của block là layer hiện hành layer hiện hành là "ghichu" bởi dòng này (command "layer" "m" "ghichu" "c" "163" """")
2. Muốn gán đối tượng cho layer thì bạn phải kiểm tra xem layer đó có chưa, nếu có rồi thì thôi, nếu chưa có thì tạo ra. Mình viết cho bạn hàm con tạo Layer
(defun taolayer ()
(if (= (tblsearch "layer" "DUONGTHANG") nil)
(command "layer" "n" "DUONGTHANG" "c" "8" "DUONGTHANG" "")
)
(if (= (tblsearch "layer" "TOMAU") nil)
(command "layer" "n" "TOMAU" "c" "3" "TOMAU" "")
)
)
Bạnk chép đoạn code này vào lisp của bạn sau đó bạn thêm dòng (taolayer) vào code chính của bạn.
3. Gán đối tượng cho layer thì làm như sau:
Ví dụ sau khi tạo xong line tại dòng (COMMAND "LINE" PT8 PT2 "") bạn thêm dòng sau xuống dưới dòng này
(command "change" (entlast) "" "p" "la" "DUONGTHANG" "")
Bạn nên tự nghiên cứu một chút. Có gì thắc mắc thì cứ hỏi.
  • 1
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2786 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 30 November 2010 - 11:34 AM

Mình làm công tác về địa chính, phải chỉnh lý biến động khi các đường giao thông đi qua, phải cắt tỉa nhiều qu1a.
Mong các anh giúp cho một lisp chọn đường bên trái chọn lề đường bên phải, thì các đường nằm trong giữa được cắt và ghi vào một lớp khác như là lớp biến động và tắt lớp nó đi. ví dụ sau :
http://www.cadviet.c.../3/biendong.dwg

Mình viết code này cho bạn. Bạn test thử và cho ý kiến nhé.

(defun c:tg ()
(vl-load-com)
(setq l1 (car (entsel "\nChon duong thu nhat: "))
l2 (car (entsel "\nChon duong thu hai: "))
p (getpoint "\Pick 1 diem ben ngoai ban ve: ")
p1 (car (acet-geom-vertex-list l1))
p2 (cadr (acet-geom-vertex-list l1))
p3 (car (acet-geom-vertex-list l2))
p4 (cadr (acet-geom-vertex-list l2))
)
(command "pline" p1 p2)
(if (< (distance p2 p3) (distance p2 p4))
(progn
(command p3 p4 "c")
(setq mp (acet-geom-midpoint p1 p3))
)
(progn
(command p4 p3 "c")
(setq mp (acet-geom-midpoint p1 p4))
)
)
(setq el (entlast))
(command "offset" 0.1 el mp "")
(setq in (entlast))
(command "offset" 0.1 el p "")
(setq out (entlast))
(setq lsp (acet-geom-vertex-list el))
(setq ss (ssget "cp" lsp))
(setq ss (ssdel el ss))
(setq ss (ssdel in ss))
(command "copy" ss "" mp p "")
(command "copy" el "" mp p "")
(setq elc (entlast))
(command "move" out "" mp p)
(setq lsout (acet-geom-vertex-list out))
(entdel out)
(repeat 5
(setq i 0)
(command "trim" elc "" "f")
(repeat (length lsout)
(command (nth i lsout))
(setq i (1+ i))
)
(command "" "")
)
(setq lsin (acet-geom-vertex-list in))
(entdel in)
(repeat 5
(setq i 0)
(command "trim" el "" "f")
(repeat (length lsin)
(command (nth i lsin))
(setq i (1+ i))
)
(command "" "")
)
(command "erase" (ssget "wp" lsp) "")
(setq lselc (acet-geom-vertex-list elc))
(entdel elc)
(setq tt (ssget "cp" lselc))
(command "move" tt "" p mp)
(command "change" tt "" "p" "la" "biendong" "c" "bylayer" "")
(entdel el)
)

  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2787 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 30 November 2010 - 12:28 PM

Cảm ơn các bác rất nhiều.
Trong dòng:
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "150" "")
(COMMAND "LINE" PT8 PT2 "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "LINE" PT9 PT5 "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "COLOR" "7" "")
(COMMAND "SOLID" PT2 PT3 PT4 "" "")
(SETQ SS (SSADD (ENTLAST) SS))
(COMMAND "SOLID" PT5 PT6 PT7 "" "")
(SETQ SS (SSADD (ENTLAST) SS))...
Theo e hiểu layer của block là "ghichu"
Màu của 2 đường xéo là màu số 7
Màu của solid là màu số 7 luôn.Em muốn 2 đường xéo là layer DUONGTHANG màu số 8,solid là layer TOMAU màu sô 3 thì sửa làm sao?Thanks.

Chào bạn hugo75,
Để làm như bạn yêu cầu, trước hết bạn cần hiểu rõ nội dung các dòng lệnh phía trên.
Dòng :
(command "layer" "m" "ghichu" "c" "163" """") là để tạo một layer mới tên là ghichu và có màu là màu số 163.
(COMMAND "COLOR" "150" "") là để đặt màu hiện hành về màu số 150.
(COMMAND "LINE" PT8 PT2 "") là để vẽ cái line từ điểm pt8 đến điểm pt2
(SETQ SS (SSADD (ENTLAST) SS)) là để nhét cái thằng cu vừa vẽ vào trong tập chọn ss có sẵn
..........
Tương tự vậy với các dòng code phía dưới.

Như vậy với lisp trên thì các line pt8 đến pt2 và line pt9 đến pt5 sẽ có màu là màu số 150 chứ không phải 7.
Các solid sẽ có màu là màu số 7.
Tất cả mấy thằng ni đều nằm trên layer hiện hành là layer ghichu vừa tạo lúc trước.

Vì thế nếu muốn thằng nào có màu gì thì trước khi tạo thằng đó bạn xài (COMMAND "COLOR" "số hiệu màu bạn muốn" "")
Còn muốn thằng nào ở layer nào thì hơi phức tạp hơn.
a/-Trong trường hợp layer bạn muốn chửa có trên bản vẽ thì bạn phải làm tương tự như trên tức là tạo layer mới:
(command "layer" "m" "ten layer mà bạn khoai chọn" "c" "số hiệu màu mà bạn ưa xài" """")
Dòng lệnh này phải đặt ngay trước dòng lệnh tạo đối tượng bạn cần.
b/- Trong trường hợp bản vẽ đã có layer bạn cần rồi thì chỉ việc đưa nó ra thành hiện hành để mình xài bằng cách dùng:
(stevar "clayer" "tên layer bạn muốn dùng")
Cái này cũng nhớ là phải đặt trước cái lệnh tạo đối tượng mới xi nhê bạn nhé.

Hề hề hề, bạn thử làm coi nó có giống thằng cu nhà bạn không nhé....
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2788 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 30 November 2010 - 02:14 PM

Mình viết code này cho bạn. Bạn test thử và cho ý kiến nhé.


(defun c:tg ()
(vl-load-com)
(setq l1 (car (entsel "\nChon duong thu nhat: "))
l2 (car (entsel "\nChon duong thu hai: "))
p (getpoint "\Pick 1 diem ben ngoai ban ve: ")
p1 (car (acet-geom-vertex-list l1))
p2 (cadr (acet-geom-vertex-list l1))
p3 (car (acet-geom-vertex-list l2))
p4 (cadr (acet-geom-vertex-list l2))
)
(command "pline" p1 p2)
(if (< (distance p2 p3) (distance p2 p4))
(progn
(command p3 p4 "c")
(setq mp (acet-geom-midpoint p1 p3))
)
(progn
(command p4 p3 "c")
(setq mp (acet-geom-midpoint p1 p4))
)
)
(setq el (entlast))
(command "offset" 0.1 el mp "")
(setq in (entlast))
(command "offset" 0.1 el p "")
(setq out (entlast))
(setq lsp (acet-geom-vertex-list el))
(setq ss (ssget "cp" lsp))
(setq ss (ssdel el ss))
(setq ss (ssdel in ss))
(command "copy" ss "" mp p "")
(command "copy" el "" mp p "")
(setq elc (entlast))
(command "move" out "" mp p)
(setq lsout (acet-geom-vertex-list out))
(entdel out)
(repeat 5
(setq i 0)
(command "trim" elc "" "f")
(repeat (length lsout)
(command (nth i lsout))
(setq i (1+ i))
)
(command "" "")
)
(setq lsin (acet-geom-vertex-list in))
(entdel in)
(repeat 5
(setq i 0)
(command "trim" el "" "f")
(repeat (length lsin)
(command (nth i lsin))
(setq i (1+ i))
)
(command "" "")
)
(command "erase" (ssget "wp" lsp) "")
(setq lselc (acet-geom-vertex-list elc))
(entdel elc)
(setq tt (ssget "cp" lselc))
(command "move" tt "" p mp)
(command "change" tt "" "p" "la" "biendong" "c" "bylayer" "")
(entdel el)
)

Hề hề hề,
Chào bác phamngoctukts,
Vì sao bác phải copy các đối tượng sang vị trí khác để trim rồi sau đó mới mang trả về???
Theo thiển ý của mình bác có thể dùng lisp break tất cả các đối tượng tại điểm giao cắt với polyline el. Cái này trên diễn đàn cũng có mà bác.
Sau đó change tất cả các đối tượng trong vùng chọn tạo bởi polyline in về cái lớp mong muốn bác ạ.
Như vậy có nhẽ đơn giản hơn bác nhỉ????
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2789 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 30 November 2010 - 02:27 PM

Hề hề hề,
Chào bác phamngoctukts,
Vì sao bác phải copy các đối tượng sang vị trí khác để trim rồi sau đó mới mang trả về???
Theo thiển ý của mình bác có thể dùng lisp break tất cả các đối tượng tại điểm giao cắt với polyline el. Cái này trên diễn đàn cũng có mà bác.
Sau đó move tất cả các đối tượng trong vùng chọn tạo bởi polyline in về cái lớp mong muốn bác ạ.
Như vậy có nhẽ đơn giản hơn bác nhỉ????

Hê hề Chào Bác!
Do em không biết cái code break đó mặt mũi nó ra thế nào có break được thằng pline không. Hình như code đó của bác gia_bach để em tìm thử xem sao rồi sửa lại cũng chưa muộn. Em đã nói rồi về độ ngô nghê thì em hơn Bác mà.
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2790 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 30 November 2010 - 03:08 PM

Hê hề Chào Bác!
Do em không biết cái code break đó mặt mũi nó ra thế nào có break được thằng pline không. Hình như code đó của bác gia_bach để em tìm thử xem sao rồi sửa lại cũng chưa muộn. Em đã nói rồi về độ ngô nghê thì em hơn Bác mà.

Hề hề hề,
Biếu bác cái nè xài chơi nhé.
Với trường hợp này bác có thể xài thằng BreakWithTouching khá ngon bác ạ.
http://www.cadviet.c...cacdoituong.lsp
Chúc bác luôn vui.
Hề hề hề.
  • 2
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2791 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 30 November 2010 - 03:42 PM

Hê hề Chào Bác!
Do em không biết cái code break đó mặt mũi nó ra thế nào có break được thằng pline không. Hình như code đó của bác gia_bach để em tìm thử xem sao rồi sửa lại cũng chưa muộn. Em đã nói rồi về độ ngô nghê thì em hơn Bác mà.

Hề hề hề,
Mạn phép bác Phamngoctukts, mình chỉnh cái lisp của bác kết hợp với cái lisp breaktohopcacdoituong mình mót trên diễn đàn. Nghe chừng có vẻ lẹ hơn bác ạ mặc dầu cái code thì nó dài lê thê.
Mình chưa chỉnh hết, chỉ chỉnh những thứ cần mà thôi, nếu bác rảnh có thể chỉnh thêm nhé.

(defun c:tg ()
(vl-load-com)
(setq l1 (car (entsel "\nChon duong thu nhat: "))
l2 (car (entsel "\nChon duong thu hai: "))
;;;;;; p (getpoint "\Pick 1 diem ben ngoai ban ve: ")
p1 (car (acet-geom-vertex-list l1))
p2 (cadr (acet-geom-vertex-list l1))
p3 (car (acet-geom-vertex-list l2))
p4 (cadr (acet-geom-vertex-list l2))
)
(command "pline" p1 p2)
(if (< (distance p2 p3) (distance p2 p4))
(progn
(command p3 p4 "c")
(setq mp (acet-geom-midpoint p1 p3))
)
(progn
(command p4 p3 "c")
(setq mp (acet-geom-midpoint p1 p4))
)
)
(setq el (entlast))
(command "offset" 0.1 el mp "")
(setq in (entlast))
;;;;;;;;;;;(command "offset" 0.1 el p "")
;;;;;;;;;;;(setq out (entlast))
;;;;;;;;;;;(setq lsp (acet-geom-vertex-list el))
;;;;;;;;;;;(setq ss (ssget "cp" lsp))
;;;;;;;;;;;;;(setq ss (ssdel el ss))
;;;;;;;;;;(setq ss (ssdel in ss))
;;;;;;;;;;;;;(command "copy" ss "" mp p "")
;;;;;;;;;;;;;;;(command "copy" el "" mp p "")
;;;;;;;;;;;;(setq elc (entlast))
;;;;;;;;;;;;;;;(command "move" out "" mp p)
;;;;;;;;;;;;;;(setq lsout (acet-geom-vertex-list out))
;;;;;;;;;;;(entdel out)
;;;;;;;;;;;;;;(repeat 5
;;;;;;;;;;;;;;;;;(setq i 0)
;;;;;;;;;;;;;;;;;(command "trim" elc "" "f")
;;;;;;;;;;;;;;;(repeat (length lsout)
;;;;;;;;;;;;;;(command (nth i lsout))
;;;;;;;;;;;;;;;;(setq i (1+ i))
;;;;;;;;;;;;;;;:s_big:
;;;;;;;;;;;;(command "" "")
;;;;;;;;;;;;;;:leluoi:
;;;;;;;;;;;;(setq lsin (acet-geom-vertex-list in))
;;;;;;;;;;;;(entdel in)
;;;;;;;;;;;;(repeat 5
;;;;;;;;;;;;;;;(setq i 0)
;;;;;;;;;;;(command "trim" el "" "f")
;;;;;;;;;;(repeat (length lsin)
;;;;;;;;;;;;;;(command (nth i lsin))
;;;;;;;;;;;;;;;;;;;(setq i (1+ i))
;;;;;;;;;;;;;;;:cheers:
;;;;;;;;;;;;;;;;;(command "" "")
;;;;;;;;;;;;;;;:D
;;;;;;;;;;;;;;;;;(command "erase" (ssget "wp" lsp) "")
;;;;;;;;;;;;;(setq lselc (acet-geom-vertex-list elc))
;;;;;;;;;;;;;;;;(entdel elc)
;;;;;;;;;;;;;;;;(setq tt (ssget "cp" lselc))
;;;;;;;;;;;;;;;;;;(command "move" tt "" p mp)

(setq el (ssadd el))
(breakwithtouching el)
(setq tt (ssget "cp" (acet-geom-vertex-list in)))
(command "change" tt "" "p" "la" "biendong" "c" "bylayer" "")
(entdel el)
(entdel in)
)

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

(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
)
;; ss2brk selection set to break
;; ss2brkwith selection set to use as break points
;; self when true will allow an object to break itself
;; note that plined will break at each vertex
;;
;; return list of enames of new objects

(vl-load-com)

(princ "\nCalculating Break Points, Please Wait.\n")

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

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

;; return a list of objects from a selection set
;| (defun ssget->vla-list (ss)
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
)|;
(defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)

;; return a list of lists grouped by 3 from a flat list
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)))
(reverse new)
)

;;=====================================
;; return a list of intersect points
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
))))))
iplist
)
)


;;========================================
;; Break entity at break points in list
;;========================================
;; New as per version 1.8 [BrkGap] --- This subroutine has been re-written
;; Loop through the break points breaking the entity
;; If the entity is not a closed entity then a new object is created
;; This object is added to a list. When break points don't fall on the current
;; entity the list of new entities are searched to locate the entity that the
;; point is on so it can be broken.
;; "Break with a Gap" has been added to this routine. The problem faced with
;; this method is that sections to be removed may lap if the break points are
;; too close to each other. The solution is to create a list of break point pairs
;; representing the gap to be removed and test to see if there i an overlap. If
;; there is then merge the break point pairs into one large gap. This way the
;; points will always fall on an object with one exception. If the gap is too near
;; the end of an object one break point will be off the end and therefore that
;; point will need to be replaced with the end point.
;; NOTE: in ACAD2000 the (vlax-curve-getdistatpoint function has proven unreliable
;; so I have used (vlax-curve-getdistatparam in most cases
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
brkptE brkpt result GapFlg result ignore dist tmppt
#ofpts 2gap enddist lastent obj2break stdist
)
(or BrkGap (setq BrkGap 0.0)) ; default to 0
(setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point

(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
GapFlg (not (zerop BrkGap)) ; gap > 0
closedobj (vlax-curve-isclosed obj2break)
)
;; when zero gap no need to break at end points
(if (zerop Brkgap)
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)))
brkptlst)
)
)
(if brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break x))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))

(if GapFlg ; gap > 0
;; Brkptlst starts as the break point and then a list of pairs of points
;; is creates as the break points
(progn
;; create a list of list of break points
;; ((idx# stpoint distance)(idx# endpoint distance)...)
(setq idx 0)
(foreach brkpt brkptlst

;; ----------------------------------------------------------
;; create start break point, then create end break point
;; ((idx# startpoint distance)(idx# endpoint distance)...)
;; ----------------------------------------------------------
(setq dist (cadr brkpt)) ; distance to center of gap
;; subtract gap to get start point of break gap
(cond
((and (minusp (setq stDist (- dist BrkGap))) closedobj )
(setq stdist (+ (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)) stDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((minusp stDist) ; off start of object so get startpoint
(setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; add gap to get end point of break gap
(cond
((and (> (setq stDist (+ dist BrkGap))
(setq endDist (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)))) closedobj )
(setq stdist (- stDist endDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((> stDist endDist) ; off end of object so get endpoint
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getendparam obj2break))
endDist) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; -------------------------------------------------------
(setq idx (1+ IDX))
) ; foreach brkpt brkptlst


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

;; setup brkptlst with pair of break pts ((p1 p2)(p3 p4)...)
;; one of the pair of points will be on the object that
;; needs to be broken
(setq dlst (reverse result)
brkptlst nil)
(while dlst ; grab the points only
(setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
dlst (cddr dlst))
)
)
)
;; -----------------------------------------------------

;; (if (equal a ent) (princ)) ; debug CAB -------------

(foreach brkpt (reverse brkptlst)
(if GapFlg ; gap > 0
(setq brkptS (car brkpt)
brkptE (cadr brkpt))
(setq brkptS (car brkpt)
brkptE brkptS)
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj2break tmppt))))
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while (and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj tmppt)))
(null (setq obj2break obj)) ; switch objects, null causes exit
t
)
)
)
)
)
)
)
;| ;; ver 2.0 fix - removed this code as there are cases where the break point
;; is at the end of a line which is not a valid break but does no harm
(if (and brkobjlst idx (minusp idx)
(null (alert (strcat "Error - point not on object"
"\nPlease report this error to"
"\n CAB at TheSwamp.org"))))
(exit)
)
|;
;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB -------------

;; Handle any objects that can not be used with the Break Command
;; using one point, gap of 0.000001 is used
(setq closedobj (vlax-curve-isclosed obj2break))
(if GapFlg ; gap > 0
(if closedobj
(progn ; need to break a closed object
(setq brkpt2 (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
(command "._break" obj2break "_non" (trans brkpt2 0 1)
"_non" (trans brkptE 0 1))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(setq BrkptE brkpt2)
)
)
;; single breakpoint ----------------------------------------------------
;|(if (and closedobj ; problems with ACAD200 & this code
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001))))
)
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001)))

)|;
(if (and closedobj
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
)
) ; endif

;; (if (null brkptE) (princ)) ; debug

(setq LastEnt (GetLastEnt))
(command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast))))
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
) ; endif brkptlst

) ; defun break_obj

;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;===================================
;; CAB - return a list of new enames
(defun GetNewEntities (ename / new)
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (setq new (cons ename new)))
)
)
((alert "Ename wrong type."))
)
new
)


;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(setq LastEntInDatabase (GetLastEnt))
(if (and ss2brk ss2brkwith)
(progn
(setq oc 0
ss2brkwithList (ssget->vla-list ss2brkwith))
(if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)
(setq *BrkVerbose* t)
)
(and *BrkVerbose*
(princ (strcat "Objects to be Checked: "
(itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))
;; CREATE a list of entity & it's break points
(foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
(if (not (onlockedlayer (vlax-vla-object->ename obj)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj ss2brkwithList
(if (and (or self (not (equal obj intobj)))
(setq intpts (get_interpts obj intobj))
)
(setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
)
(and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))
)
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
)
)
)
)


(and *BrkVerbose* (princ "\nBreaking Objects.\n"))
(setq *brkcnt* 0) ; break counter
;; masterlist = ((ent brkpts)(ent brkpts)...)
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk) Gap)
)
)
)
)
;;==============================================================
(and (zerop *brkcnt*) (princ "\nNone to be broken."))
(setq *BrkVerbose* nil)
(GetNewEntities LastEntInDatabase) ; return list of enames of new objects
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D O F M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;======================
;; Redraw ss with mode
;;======================
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)

;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq
ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)



;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D M A I N F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++



;;===============================================
;; Break all objects selected with each other
;;===============================================
(defun c:BreakAll (/ cmd ss NewEnts AllEnts tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)


;;===========================================
;; Break a single object with other objects
;;===========================================
(defun c:BreakObject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nSelect single object to break: ")
(if (and (setq ss1 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 4)))
(Break_with ss1 ss2 nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================
;; Break many objects with a single object
;;==========================================
(defun c:BreakWobject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select single object to break with: ***"))
(setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)


;;==========================================
;; Break objects with objects on a layer
;;==========================================
;; New 08/01/2008
(defun c:BreakWlayer (/ cmd ss1 ss2 tmp lay)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\n*** Select single object for break layer: ***")

(if (and (setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq lay (assoc 8 (entget (ssname ss2 0))))
(setq ss2 (ssget "_X" (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
lay (cons 410 (getvar "ctab")))))
(not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss1 (ssget (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 8 (strcat "~" (cdr lay))))))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)


;;======================================================
;; Break selected objects with other selected objects
;;======================================================
(defun c:BreakWith (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)



;;=============================================
;; Break objects touching selected objects
;;=============================================

(defun c:BreakTouching (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if (and (not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)



;;=================================================
;; Break touching objects with selected objects
;;=================================================
;; New 08/01/2008
(defun BreakWithTouching ( ss2 / cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(prompt "\nSelect object(s) to break with & press enter: ")
(if
(and
;;;;;;;;;(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
ss2
(setq tlst (gettouching ss2))
)
(progn
(setq tlst (vl-remove-if '(lambda (x)(ssmemb x ss2)) tlst)) ; remove if in picked ss
(mapcar '(lambda (x) (ssadd x ss1)) tlst) ; convert to a selection set
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)


;;==========================================================
;; Break selected objects with any objects that touch it
;;==========================================================


(defun c:BreakSelected (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil Bgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;; ***************************************************
;; Function to create a dcl support file if it
;; does not exist
;; Usage : (create_dcl "file name")
;; Returns : T if successful else nil
;; ***************************************************
(defun create_Breakdcl (fname / acadfn dcl-rev-check)
;;=======================================
;; check revision date Routine
;;=======================================
(defun dcl-rev-check (fn / rvdate ln lp)
;; revision flag must match exactly and must
;; begin with //
(setq rvflag "// Revision Control 05/12/2008@14:11" )
(if (setq fn (findfile fn))
(progn ; check rev date
(setq lp 5) ; read 4 lines
(setq fn (open fn "r")) ; open file for reading
(while (> (setq lp (1- lp)) 0)
(setq ln (read-line fn)) ; get a line from file
(if (vl-string-search rvflag ln)
(setq lp 0)
)
)
(close fn) ; close the open file handle
(if (= lp -1)
nil ; no new dcl needed
t ; flag to create new file
)
)
t ; flag to create new file
)
)
(if (null(wcmatch (strcase fname) "*`.DCL"))
(setq fname (strcat fname ".DCL"))
)
(if (dcl-rev-check fname)
;; create dcl file in same directory as ACAD.PAT
(progn
(setq acadfn (findfile "ACAD.PAT")
fn (strcat (substr acadfn 1 (- (strlen acadfn) 8))fname)
fn (open fn "w")
)
(foreach x (list
"// WARNING file will be recreated if you change the next line"
rvflag
"//BreakAll.DCL"
"BreakDCL : dialog { label = \"[ Break All or Some by CAB v1.8 ]\";"
" : text { label = \"--=< Select type of Break Function needed >=--\"; "
" key = \"tm\"; alignment = centered; fixed_width = true;}"
" spacer_1;"
" : button { key = \"b1\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break all objects selected with each other\";} "
" : button { key = \"b2\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break selected objects with other selected objects\";}"
" : button { key = \"b3\"; mnemonic = \"T\"; alignment = centered;"
" label = \" Break selected objects with any objects that touch it\";}"
" spacer_1;"
" : row { spacer_0;"
" : edit_box {key = \"gap\" ; width = 8; mnemonic = \"G\"; label = \"Gap\"; fixed_width = true;}"
" : button { label = \"Help\"; key = \"help\"; mnemonic = \"H\"; fixed_width = true;} "
" cancel_button;"
" spacer_0;"
" }"
"}"
) ; endlist
(princ x fn)
(write-line "" fn)
) ; end foreach
(close fn)
(setq acadfn nil)
(alert (strcat "\nDCL file created, please restart the routine"
"\n again if an error occures."))
t ; return True, file created
)
t ; return True, file found
)
) ; end defun


;;==============================
;; BreakAll Dialog Routine
;;==============================
(defun c:MyBreak(/ dclfile dcl# RunDCL BreakHelp cmd txt2num)
;; return number or nil
(defun txt2num (txt / num)
(if txt
(or (setq num (distof txt 5))
(setq num (distof txt 2))
(setq num (distof txt 1))
(setq num (distof txt 4))
(setq num (distof txt 3))
)
)
(if (numberp num)
num
)
)
(defun mydonedialog (flag)
(setq DCLgap (txt2num (get_tile "gap")))
(done_dialog flag)
)
(defun RunDCL (/ action)
(or DCLgap (setq DCLgap 0)) ; error trap value
(action_tile "b1" "(mydonedialog 1)")
(action_tile "b2" "(mydonedialog 2)")
(action_tile "b3" "(mydonedialog 3)")
(action_tile "gap" "(setq DCLgap (txt2num value$))")
(set_tile "gap" (rtos DCLgap))
(action_tile "help" "(BreakHelp)")
(action_tile "cancel" "(done_dialog 0)")
(setq action (start_dialog))
(or DCLgap (setq DCLgap 0)) ; error trap value
(setq DCLgap (max DCLgap 0)) ; nu negative numbers

(cond
((= action 1) ; BreakAll
(command "_.undo" "_begin")
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil DCLgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(command "_.undo" "_end")
(princ)
)

((= action 2) ; BreakWith
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil DCLgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

)
((= action 3) ; BreakSelected
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil DCLgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)
)
)
)
(defun BreakHelp ()
(alert
(strcat
"BreakAll.lsp © 2007-2008 Charles Alan Butler\n\n"
"This LISP routine will break objects based on the routine you select.\n"
"It will not break objects on locked layers and objects must have the same z-value.\n"
"Object types are limited to LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE\n"
"BreakAll - Break all objects selected with each other\n"
"BreakwObject - Break many objects with a single object\n"
"BreakObject - Break a single object with many objects \n"
"BreakWith - Break selected objects with other selected objects\n"
"BreakTouching - Break objects touching selected objects\n"
"BreakSelected - Break selected objects with any objects that touch it\n"
" The Gap distance is the total opening created.\n"
"You may run each routine by entering the function name at the command line.\n"
"For updates & comments contact Charles Alan Butler AKA CAB at TheSwamp.org.\n")
)
)

;;================================================================
;; Start of Routine
;;================================================================
(vl-load-com)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq dclfile "BreakAll.dcl")
(cond
((not (create_Breakdcl dclfile))
(prompt (strcat "\nCannot create " dclfile "."))
)
((< (setq dcl# (load_dialog dclfile)) 0)
(prompt (strcat "\nCannot load " dclfile "."))
)
((not (new_dialog "BreakDCL" dcl#))
(prompt (strcat "\nProblem with " dclfile "."))
)
((RunDCL)) ; No DCL problems: fire it up
)
(and cmd (setvar "CMDECHO" cmd))
(princ)
)
(prompt "Break routines loaded, Enter Mybreak to run.")
(princ)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;; E n d O f F i l e I f y o u A r e H e r e
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.



@All: Hề hề hề, code dài không phải tại mình đâu, tại mấy cái thằng TÂY nó viết vậy, mình chỉ mót về mà hổng dám chọc ngoáy nên cứ để vấy cho nó.... Tây ý mà. Mong các bác chớ giận. (có giận thì giận cái thằng Tây ý nhé) Hề hề hề.....
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2792 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 30 November 2010 - 03:57 PM

Hề hề hề,
Mạn phép bác Phamngoctukts, mình chỉnh cái lisp của bác kết hợp với cái lisp breaktohopcacdoituong mình mót trên diễn đàn. Nghe chừng có vẻ lẹ hơn bác ạ mặc dầu cái code thì nó dài lê thê.
Mình chưa chỉnh hết, chỉ chỉnh những thứ cần mà thôi, nếu bác rảnh có thể chỉnh thêm nhé.


(defun c:tg ()
(vl-load-com)
(setq l1 (car (entsel "\nChon duong thu nhat: "))
l2 (car (entsel "\nChon duong thu hai: "))
;;;;;; p (getpoint "\Pick 1 diem ben ngoai ban ve: ")
p1 (car (acet-geom-vertex-list l1))
p2 (cadr (acet-geom-vertex-list l1))
p3 (car (acet-geom-vertex-list l2))
p4 (cadr (acet-geom-vertex-list l2))
)
(command "pline" p1 p2)
(if (< (distance p2 p3) (distance p2 p4))
(progn
(command p3 p4 "c")
(setq mp (acet-geom-midpoint p1 p3))
)
(progn
(command p4 p3 "c")
(setq mp (acet-geom-midpoint p1 p4))
)
)
(setq el (entlast))
(command "offset" 0.1 el mp "")
(setq in (entlast))
;;;;;;;;;;;(command "offset" 0.1 el p "")
;;;;;;;;;;;(setq out (entlast))
;;;;;;;;;;;(setq lsp (acet-geom-vertex-list el))
;;;;;;;;;;;(setq ss (ssget "cp" lsp))
;;;;;;;;;;;;;(setq ss (ssdel el ss))
;;;;;;;;;;(setq ss (ssdel in ss))
;;;;;;;;;;;;;(command "copy" ss "" mp p "")
;;;;;;;;;;;;;;;(command "copy" el "" mp p "")
;;;;;;;;;;;;(setq elc (entlast))
;;;;;;;;;;;;;;;(command "move" out "" mp p)
;;;;;;;;;;;;;;(setq lsout (acet-geom-vertex-list out))
;;;;;;;;;;;(entdel out)
;;;;;;;;;;;;;;(repeat 5
;;;;;;;;;;;;;;;;;(setq i 0)
;;;;;;;;;;;;;;;;;(command "trim" elc "" "f")
;;;;;;;;;;;;;;;(repeat (length lsout)
;;;;;;;;;;;;;;(command (nth i lsout))
;;;;;;;;;;;;;;;;(setq i (1+ i))
;;;;;;;;;;;;;;;:s_big:
;;;;;;;;;;;;(command "" "")
;;;;;;;;;;;;;;:leluoi:
;;;;;;;;;;;;(setq lsin (acet-geom-vertex-list in))
;;;;;;;;;;;;(entdel in)
;;;;;;;;;;;;(repeat 5
;;;;;;;;;;;;;;;(setq i 0)
;;;;;;;;;;;(command "trim" el "" "f")
;;;;;;;;;;(repeat (length lsin)
;;;;;;;;;;;;;;(command (nth i lsin))
;;;;;;;;;;;;;;;;;;;(setq i (1+ i))
;;;;;;;;;;;;;;;:cheers:
;;;;;;;;;;;;;;;;;(command "" "")
;;;;;;;;;;;;;;;:D
;;;;;;;;;;;;;;;;;(command "erase" (ssget "wp" lsp) "")
;;;;;;;;;;;;;(setq lselc (acet-geom-vertex-list elc))
;;;;;;;;;;;;;;;;(entdel elc)
;;;;;;;;;;;;;;;;(setq tt (ssget "cp" lselc))
;;;;;;;;;;;;;;;;;;(command "move" tt "" p mp)

(setq el (ssadd el))
(breakwithtouching el)
(setq tt (ssget "cp" (acet-geom-vertex-list in)))
(command "change" tt "" "p" "la" "biendong" "c" "bylayer" "")
(entdel el)
(entdel in)
)

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

;;;;;;;

(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
)
;; ss2brk selection set to break
;; ss2brkwith selection set to use as break points
;; self when true will allow an object to break itself
;; note that plined will break at each vertex
;;
;; return list of enames of new objects

(vl-load-com)

(princ "\nCalculating Break Points, Please Wait.\n")

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

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

;; return a list of objects from a selection set
;| (defun ssget->vla-list (ss)
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
)|;
(defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)

;; return a list of lists grouped by 3 from a flat list
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)))
(reverse new)
)

;;=====================================
;; return a list of intersect points
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
))))))
iplist
)
)
;;========================================
;; Break entity at break points in list
;;========================================
;; New as per version 1.8 [BrkGap] --- This subroutine has been re-written
;; Loop through the break points breaking the entity
;; If the entity is not a closed entity then a new object is created
;; This object is added to a list. When break points don't fall on the current
;; entity the list of new entities are searched to locate the entity that the
;; point is on so it can be broken.
;; "Break with a Gap" has been added to this routine. The problem faced with
;; this method is that sections to be removed may lap if the break points are
;; too close to each other. The solution is to create a list of break point pairs
;; representing the gap to be removed and test to see if there i an overlap. If
;; there is then merge the break point pairs into one large gap. This way the
;; points will always fall on an object with one exception. If the gap is too near
;; the end of an object one break point will be off the end and therefore that
;; point will need to be replaced with the end point.
;; NOTE: in ACAD2000 the (vlax-curve-getdistatpoint function has proven unreliable
;; so I have used (vlax-curve-getdistatparam in most cases
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
brkptE brkpt result GapFlg result ignore dist tmppt
#ofpts 2gap enddist lastent obj2break stdist
)
(or BrkGap (setq BrkGap 0.0)) ; default to 0
(setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point

(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
GapFlg (not (zerop BrkGap)) ; gap > 0
closedobj (vlax-curve-isclosed obj2break)
)
;; when zero gap no need to break at end points
(if (zerop Brkgap)
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)))
brkptlst)
)
)
(if brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break x))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))

(if GapFlg ; gap > 0
;; Brkptlst starts as the break point and then a list of pairs of points
;; is creates as the break points
(progn
;; create a list of list of break points
;; ((idx# stpoint distance)(idx# endpoint distance)...)
(setq idx 0)
(foreach brkpt brkptlst

;; ----------------------------------------------------------
;; create start break point, then create end break point
;; ((idx# startpoint distance)(idx# endpoint distance)...)
;; ----------------------------------------------------------
(setq dist (cadr brkpt)) ; distance to center of gap
;; subtract gap to get start point of break gap
(cond
((and (minusp (setq stDist (- dist BrkGap))) closedobj )
(setq stdist (+ (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)) stDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((minusp stDist) ; off start of object so get startpoint
(setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; add gap to get end point of break gap
(cond
((and (> (setq stDist (+ dist BrkGap))
(setq endDist (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)))) closedobj )
(setq stdist (- stDist endDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((> stDist endDist) ; off end of object so get endpoint
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getendparam obj2break))
endDist) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; -------------------------------------------------------
(setq idx (1+ IDX))
) ; foreach brkpt brkptlst
(setq dlst (reverse dlst))
;; remove the points of the gap segments that overlap
(setq idx -1
2gap (* BrkGap 2)
#ofPts (length Brkptlst)
)
(while (<= (setq idx (1+ idx)) #ofPts)
(cond
((null result) ; 1st time through
(setq result (list (car dlst)) ; get first start point
result (cons (nth (1+(* idx 2)) dlst) result))
)
((= idx #ofPts) ; last pass, check for wrap
(if (and closedobj (> #ofPts 1)
(<= (+(- (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break))
(cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
(progn
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (cadr (reverse result)) result) ; get last end point
result (cdr (reverse result))
result (reverse (cdr result)))
)
)
)
;; Break Gap Overlaps
((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
)
;; Break Gap does Not Overlap previous point
(t
(setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
)
) ; end cond stmt
) ; while

;; setup brkptlst with pair of break pts ((p1 p2)(p3 p4)...)
;; one of the pair of points will be on the object that
;; needs to be broken
(setq dlst (reverse result)
brkptlst nil)
(while dlst ; grab the points only
(setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
dlst (cddr dlst))
)
)
)
;; -----------------------------------------------------

;; (if (equal a ent) (princ)) ; debug CAB -------------

(foreach brkpt (reverse brkptlst)
(if GapFlg ; gap > 0
(setq brkptS (car brkpt)
brkptE (cadr brkpt))
(setq brkptS (car brkpt)
brkptE brkptS)
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj2break tmppt))))
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while (and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj tmppt)))
(null (setq obj2break obj)) ; switch objects, null causes exit
t
)
)
)
)
)
)
)
;| ;; ver 2.0 fix - removed this code as there are cases where the break point
;; is at the end of a line which is not a valid break but does no harm
(if (and brkobjlst idx (minusp idx)
(null (alert (strcat "Error - point not on object"
"\nPlease report this error to"
"\n CAB at TheSwamp.org"))))
(exit)
)
|;
;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB -------------

;; Handle any objects that can not be used with the Break Command
;; using one point, gap of 0.000001 is used
(setq closedobj (vlax-curve-isclosed obj2break))
(if GapFlg ; gap > 0
(if closedobj
(progn ; need to break a closed object
(setq brkpt2 (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
(command "._break" obj2break "_non" (trans brkpt2 0 1)
"_non" (trans brkptE 0 1))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(setq BrkptE brkpt2)
)
)
;; single breakpoint ----------------------------------------------------
;|(if (and closedobj ; problems with ACAD200 & this code
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001))))
)
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001)))

)|;
(if (and closedobj
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
)
) ; endif

;; (if (null brkptE) (princ)) ; debug

(setq LastEnt (GetLastEnt))
(command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast))))
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
) ; endif brkptlst

) ; defun break_obj

;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;===================================
;; CAB - return a list of new enames
(defun GetNewEntities (ename / new)
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (setq new (cons ename new)))
)
)
((alert "Ename wrong type."))
)
new
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

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

;;======================
;; Redraw ss with mode
;;======================
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)

;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq
ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D M A I N F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;===============================================
;; Break all objects selected with each other
;;===============================================
(defun c:BreakAll (/ cmd ss NewEnts AllEnts tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;===========================================
;; Break a single object with other objects
;;===========================================
(defun c:BreakObject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nSelect single object to break: ")
(if (and (setq ss1 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 4)))
(Break_with ss1 ss2 nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================
;; Break many objects with a single object
;;==========================================
(defun c:BreakWobject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select single object to break with: ***"))
(setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;==========================================
;; Break objects with objects on a layer
;;==========================================
;; New 08/01/2008
(defun c:BreakWlayer (/ cmd ss1 ss2 tmp lay)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\n*** Select single object for break layer: ***")

(if (and (setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq lay (assoc 8 (entget (ssname ss2 0))))
(setq ss2 (ssget "_X" (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
lay (cons 410 (getvar "ctab")))))
(not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss1 (ssget (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 8 (strcat "~" (cdr lay))))))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;======================================================
;; Break selected objects with other selected objects
;;======================================================
(defun c:BreakWith (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;=============================================
;; Break objects touching selected objects
;;=============================================

(defun c:BreakTouching (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if (and (not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;=================================================
;; Break touching objects with selected objects
;;=================================================
;; New 08/01/2008
(defun BreakWithTouching ( ss2 / cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(prompt "\nSelect object(s) to break with & press enter: ")
(if
(and
;;;;;;;;;(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
ss2
(setq tlst (gettouching ss2))
)
(progn
(setq tlst (vl-remove-if '(lambda (x)(ssmemb x ss2)) tlst)) ; remove if in picked ss
(mapcar '(lambda (x) (ssadd x ss1)) tlst) ; convert to a selection set
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;==========================================================
;; Break selected objects with any objects that touch it
;;==========================================================
(defun c:BreakSelected (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil Bgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;; ***************************************************
;; Function to create a dcl support file if it
;; does not exist
;; Usage : (create_dcl "file name")
;; Returns : T if successful else nil
;; ***************************************************
(defun create_Breakdcl (fname / acadfn dcl-rev-check)
;;=======================================
;; check revision date Routine
;;=======================================
(defun dcl-rev-check (fn / rvdate ln lp)
;; revision flag must match exactly and must
;; begin with //
(setq rvflag "// Revision Control 05/12/2008@14:11" )
(if (setq fn (findfile fn))
(progn ; check rev date
(setq lp 5) ; read 4 lines
(setq fn (open fn "r")) ; open file for reading
(while (> (setq lp (1- lp)) 0)
(setq ln (read-line fn)) ; get a line from file
(if (vl-string-search rvflag ln)
(setq lp 0)
)
)
(close fn) ; close the open file handle
(if (= lp -1)
nil ; no new dcl needed
t ; flag to create new file
)
)
t ; flag to create new file
)
)
(if (null(wcmatch (strcase fname) "*`.DCL"))
(setq fname (strcat fname ".DCL"))
)
(if (dcl-rev-check fname)
;; create dcl file in same directory as ACAD.PAT
(progn
(setq acadfn (findfile "ACAD.PAT")
fn (strcat (substr acadfn 1 (- (strlen acadfn) 8))fname)
fn (open fn "w")
)
(foreach x (list
"// WARNING file will be recreated if you change the next line"
rvflag
"//BreakAll.DCL"
"BreakDCL : dialog { label = \"[ Break All or Some by CAB v1.8 ]\";"
" : text { label = \"--=< Select type of Break Function needed >=--\"; "
" key = \"tm\"; alignment = centered; fixed_width = true;}"
" spacer_1;"
" : button { key = \"b1\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break all objects selected with each other\";} "
" : button { key = \"b2\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break selected objects with other selected objects\";}"
" : button { key = \"b3\"; mnemonic = \"T\"; alignment = centered;"
" label = \" Break selected objects with any objects that touch it\";}"
" spacer_1;"
" : row { spacer_0;"
" : edit_box {key = \"gap\" ; width = 8; mnemonic = \"G\"; label = \"Gap\"; fixed_width = true;}"
" : button { label = \"Help\"; key = \"help\"; mnemonic = \"H\"; fixed_width = true;} "
" cancel_button;"
" spacer_0;"
" }"
"}"
) ; endlist
(princ x fn)
(write-line "" fn)
) ; end foreach
(close fn)
(setq acadfn nil)
(alert (strcat "\nDCL file created, please restart the routine"
"\n again if an error occures."))
t ; return True, file created
)
t ; return True, file found
)
) ; end defun
;;==============================
;; BreakAll Dialog Routine
;;==============================
(defun c:MyBreak(/ dclfile dcl# RunDCL BreakHelp cmd txt2num)
;; return number or nil
(defun txt2num (txt / num)
(if txt
(or (setq num (distof txt 5))
(setq num (distof txt 2))
(setq num (distof txt 1))
(setq num (distof txt 4))
(setq num (distof txt 3))
)
)
(if (numberp num)
num
)
)
(defun mydonedialog (flag)
(setq DCLgap (txt2num (get_tile "gap")))
(done_dialog flag)
)
(defun RunDCL (/ action)
(or DCLgap (setq DCLgap 0)) ; error trap value
(action_tile "b1" "(mydonedialog 1)")
(action_tile "b2" "(mydonedialog 2)")
(action_tile "b3" "(mydonedialog 3)")
(action_tile "gap" "(setq DCLgap (txt2num value$))")
(set_tile "gap" (rtos DCLgap))
(action_tile "help" "(BreakHelp)")
(action_tile "cancel" "(done_dialog 0)")
(setq action (start_dialog))
(or DCLgap (setq DCLgap 0)) ; error trap value
(setq DCLgap (max DCLgap 0)) ; nu negative numbers

(cond
((= action 1) ; BreakAll
(command "_.undo" "_begin")
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil DCLgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(command "_.undo" "_end")
(princ)
)

((= action 2) ; BreakWith
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil DCLgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

)
((= action 3) ; BreakSelected
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil DCLgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)
)
)
)
(defun BreakHelp ()
(alert
(strcat
"BreakAll.lsp © 2007-2008 Charles Alan Butler\n\n"
"This LISP routine will break objects based on the routine you select.\n"
"It will not break objects on locked layers and objects must have the same z-value.\n"
"Object types are limited to LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE\n"
"BreakAll - Break all objects selected with each other\n"
"BreakwObject - Break many objects with a single object\n"
"BreakObject - Break a single object with many objects \n"
"BreakWith - Break selected objects with other selected objects\n"
"BreakTouching - Break objects touching selected objects\n"
"BreakSelected - Break selected objects with any objects that touch it\n"
" The Gap distance is the total opening created.\n"
"You may run each routine by entering the function name at the command line.\n"
"For updates & comments contact Charles Alan Butler AKA CAB at TheSwamp.org.\n")
)
)

;;================================================================
;; Start of Routine
;;================================================================
(vl-load-com)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq dclfile "BreakAll.dcl")
(cond
((not (create_Breakdcl dclfile))
(prompt (strcat "\nCannot create " dclfile "."))
)
((< (setq dcl# (load_dialog dclfile)) 0)
(prompt (strcat "\nCannot load " dclfile "."))
)
((not (new_dialog "BreakDCL" dcl#))
(prompt (strcat "\nProblem with " dclfile "."))
)
((RunDCL)) ; No DCL problems: fire it up
)
(and cmd (setvar "CMDECHO" cmd))
(princ)
)
(prompt "Break routines loaded, Enter Mybreak to run.")
(princ)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;; E n d O f F i l e I f y o u A r e H e r e
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.



@All: Hề hề hề, code dài không phải tại mình đâu, tại mấy cái thằng TÂY nó viết vậy, mình chỉ mót về mà hổng dám chọc ngoáy nên cứ để vấy cho nó.... Tây ý mà. Mong các bác chớ giận. (có giận thì giận cái thằng Tây ý nhé) Hề hề hề.....

Oài Sao mà dài thế. Đọc hết code này chắc chết mất. THôi chơi đồ nội vậy. Mà hình như code này break được cả đối tượng trong block đúng không Bác Bình nhể.
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2793 gia_bach

gia_bach

    biết lệnh adcenter

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

Đã gửi 30 November 2010 - 04:28 PM

Mình làm công tác về địa chính, phải chỉnh lý biến động khi các đường giao thông đi qua, phải cắt tỉa nhiều qu1a.
Mong các anh giúp cho một lisp chọn đường bên trái chọn lề đường bên phải, thì các đường nằm trong giữa được cắt và ghi vào một lớp khác như là lớp biến động và tắt lớp nó đi. ví dụ sau :
http://www.cadviet.c.../3/biendong.dwg

Bạn thử Lisp chọn đối tuợng với đuờng bao
link : bài 32

và các Lisp khác trong cùng chủ đề đuờng bao.
  • 0

#2794 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 30 November 2010 - 04:42 PM

Oài Sao mà dài thế. Đọc hết code này chắc chết mất. THôi chơi đồ nội vậy. Mà hình như code này break được cả đối tượng trong block đúng không Bác Bình nhể.

Hề hề hề,
Đọc chi cho hết, chỉ đọc chỗ mình cần thôi mừ.....
Cái củ này lắm xơ ra phết, gặm hoài chửa hết. Song mình cứ xài những cái đã gặm thôi. Còn thì để ăn dần chớ chả nhẽ bỏ phí hoài đi. Cái vụ block thì của đáng tội mình chửa dám xài bao giờ nên bác hỏi làm mình nghẹn luôn.
Còn nội ngoại ư, cứ xài được là mình măm măm thôi chớ cũng chả dám kén chọn chi bác ạ. Dân đi mót mà lị.
Bác xài thử cái củ lắp ghép của mình trên đây chưa, ngon đáo để bác ạ. Hề hề hề. Code dài vầy như load nhanh lắm, mà chạy còn lẹ hơn nữa nên thôi thì chịu tốn tí memory space vậy.
Hề hề hề, ăn chơi mà lị bác hỉ....
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2795 lacvanhoa

lacvanhoa

    biết vẽ line

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

Đã gửi 30 November 2010 - 06:08 PM

Các bác trên diễn đàn cho em hỏi 1 tý. ví dụ minh hoạ http://www.cadviet.c...es/3/extrim.dwg
  • 0

#2796 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 30 November 2010 - 06:32 PM

Các bác trên diễn đàn cho em hỏi 1 tý. ví dụ minh hoạ http://www.cadviet.c...es/3/extrim.dwg

Ặc tưởng bạn hỏi gì ghê gớm. Cái này dùng lệnh extend chọn đường màu xanh enter chọn dường màu trắng là OK
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2797 hugo75

hugo75

    biết vẽ polygon

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

Đã gửi 30 November 2010 - 08:52 PM

Tiện thể nhờ các bác giúp giùm e 1 cái nửa.E có 1lisp ghi chú :Điểm click đầu tiên sẽ 1 mũi tên,e muốn nhờ các bác sửa giùm khi click điểm đầu tiên sẽ là 1 vòng tròn có đường kính 200 thay cho mũi tên và vòng tròn này với các đường thẳng sẽ là 1 giống như polyline đồng thời gán giùm e vòng tròn ký hiệu số là 1 block ATT vì e vẫn chưa hiểu hết về tạo block ATT trong lisp.Thanks.
;GHI CHU THEP
(DEFUN C:gct ()
(SETQ DK1 (GETVAR "USERR3"))
(IF (= DK1 0)
(PROGN
(SETQ STR "1")
(SETVAR "USERR3" 1)
)
(SETQ STR (RTOS DK1))
)
(SETQ PRPT (STRCAT "\nSize <" STR ">:"))
(SETQ DK1 (GETREAL PRPT))
(IF (= DK1 NIL)
(SETQ DK1 (GETVAR "USERR3"))
(SETVAR "USERR3" DK1)
)
(setq dk (* dk1 50))
(INITGET 7)
(SETQ PTD (GETPOINT "\nFrom point:"))
(INITGET 7)
(SETQ PTC (GETPOINT PTD "\nTo point:"))
(SETQ GOCX (ANGLE PTD PTC))
(SETQ GOCY (+ GOCX (/ PI 2)))
(setq v (rtos dk))
(setq t (distance ptd ptc))
(setq r (/ t 2))
(SETQ PT1 (POLAR PTc 0 (* 33 DK)))
(SETQ o (POLAR PT1 0 (* 5.2 DK)))
(setq h (substr v 1 1))
(setq y (substr v 2 3))
(setq l (distance ptc pt1))
(setq pt3 (polar ptc 0 (/ l 1.85)))
(setq pt4 (polar pt3 (/ pi 2) (* 4 DK)))
(setq pt5 (polar ptd (- gocx (/ pi 2)) r))
(setq pt6 (polar ptd (+ gocx (/ pi 2)) r))
(setq pt7 (polar ptd (+ gocx pi) r))
(setq pt8 (polar ptd gocx (* 2.8 dk)))
(command "osnap" "")
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "84" "")
(COMMAND "STYLE" "T_THEP" "romans.shx,vn1.shx" "" "" "" "" "" "" )
(command "text" "j" "m" pt4 (* 5 DK) 0)
(command "%%c10a150" )
(COMMAND "STYLE" "VnAvant" ".VnAvant" "" "" "" "" "")
(command "text" "j" "m" o (* 5 DK) 0)
(command "1" "")
(COMMAND "COLOR" "4" "")
(command "circle" o (* 5.2 DK)"")
(COMMAND "COLOR" "150" "")
(COMMAND "PLINE" ptd "w" "" (* 0.5 dk) pt8 "w" "" 0 pt8 ptc pt1 "")
(COMMAND "COLOR" "BYLAYER" "")
(command "osnap" "End,Mid,Cen,Quad,Int,Perp,Tan,Near,App,Int,Ext,Par" )
(command "ddedit" pause)
)

  • 0

#2798 lacvanhoa

lacvanhoa

    biết vẽ line

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

Đã gửi 30 November 2010 - 09:52 PM

Chào anh phamngoctukts ý của em là duỗi thẳng tất cả các đường hàng loạt kìa không phải pick từng đường như lệng extend( giống như lệnh extrim vậy đó) hay là anh viết cho em 1 lisp đi
  • 0

#2799 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 30 November 2010 - 11:20 PM

Lisp tp của bạn cắt rất tốt, nhưng chiỉ sử dụng qua 2 đường thằng. Nhưng khi đường pline có nhiều đoạn thì ó chiỉ cắt trên độạn, bạn giúp lại mình đi
http://www.cadviet.c...3/biendong1.dwg

Thì bạn nối nó lại rồi dùng lisp. Cái bước dễ như vậy mà bạn còn nhờ sửa lisp thì đúng là bó tay với bạn. nếu bạn chưa biết nối thì có thể dùng lệnh fillet hoặc tham khảo lệnh pedit.
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!

#2800 phamngoctukts

phamngoctukts

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1107 Bài viết
Điểm đánh giá: 696 (tốt)

Đã gửi 30 November 2010 - 11:26 PM

Chào anh phamngoctukts ý của em là duỗi thẳng tất cả các đường hàng loạt kìa không phải pick từng đường như lệng extend( giống như lệnh extrim vậy đó) hay là anh viết cho em 1 lisp đi

Hình như bạn dùng phiên bản cad2004 hoặc thấp hơn đúng không??. Nếu bạn dùng phiên bản cad cao hơn thì đây chỉ là chuyện nhỏ đâu cần đến lisp.
  • 0
Tất cả vì sự phát triển của diễn đàn ...
Cám ơn đừng nói lời suông mà hãy nhấn Hình đã gửi!