KangKung
-
Số lượng nội dung
192 -
Đã tham gia
-
Lần ghé thăm cuối
-
Ngày trúng
28
Bài đăng được đăng bởi KangKung
-
-
Bạn muốn tăng dày điểm trên bình đồ thì cách tốt nhất là vác máy đi đo lại. Cái kiểu đo được vài điểm rồi về văn phòng nội suy thì số liệu sao đúng thực tế được. Nội suy có nhiều phương pháp cũng như có nhiều phần mềm làm được nhưng tốt nhất là không nên dùng. Người thực việc thực thì mới mong xã hội phát triển được bạn ah.
-
1
-
-
Lisp của bạn đây
;========LISP VE DUONG THANG TREN 2 LAYER========== ;=============KANGKUNG 30/03/2013================== (defun C:KK() (command "PLINE") (while (> (getvar 'cmdactive) 0) (command pause)) (KK)) (defun *error* (msg) (KK)) (defun kk() (vla-put-layer (vlax-ename->vla-object (entlast)) "duong") (vla-put-color (vlax-ename->vla-object (entlast)) "3") (command "COPY" (entlast) "" "0,0" "0,0") (vla-put-layer (vlax-ename->vla-object (entlast)) "muong")) (princ "\n Written By KangKung - 30/03/2013\n") (princ "\n Nhap KK de chay chuong trinh\n")
-
:D :D :D Tại copy paste không để ý. Nói như bác Đoàn Văn Hà thì là cởi áo ra rồi mặc lại :D :D :D. Đã sửa lại ở #4
-
Hê hê ý ketxu là thế này chứ gì
(defun C:SL()(sssetfirst nil (ssget (list (assoc 8 (entget (car (entsel "\n Chon doi tuong mau:\n"))))))))Mình viết thế cho bác nào gà mờ về Lisp đọc dễ hiểu tí. Còn việc khử biến thì do lười copy paste nên cứ kệ. :D :D :D-
1
-
-
Tặng bạn cái Lisp như yêu cầu
;========LISP XOAY BLOCK THEO HUONG TUYEN========== ;=============KANGKUNG 28/03/2013================== (defun C:KK() (command "UNDO" "BE") (setq tuyen nil) (while (= (setq tuyen (car (entsel "\n Chon tuyen:\n"))) nil)) (setq taphop(ssget '((0 . "INSERT")))) (setq index 0) (while (< index (sslength taphop)) (setq block(entget (ssname taphop index))) (setq insertpoint(cdr (assoc 10 block))) (if (= (vlax-curve-getDistAtPoint tuyen (vlax-curve-getClosestPointTo tuyen insertpoint)) (vla-get-length (vlax-ename->vla-object tuyen))) (entmod (subst (cons 50 (+ pi (angle (vlax-curve-getClosestPointTo tuyen insertpoint) ( vlax-curve-getPointAtDist tuyen (+ (vlax-curve-getDistAtPoint tuyen (vlax-curve-getClosestPointTo tuyen insertpoint)) -0.001))))) (assoc 50 block) block)) (entmod (subst (cons 50 (+ pi (angle ( vlax-curve-getPointAtDist tuyen (+ (vlax-curve-getDistAtPoint tuyen (vlax-curve-getClosestPointTo tuyen insertpoint)) 0.001)) (vlax-curve-getClosestPointTo tuyen insertpoint)))) (assoc 50 block) block)) ) (setq index (+ index 1))) (command "UNDO" "END") ) (princ "\n Written By KangKung - 28/03/2013\n") (princ "\n Nhap KK de chay chuong trinh\n")-
3
-
-
Lisp đây bác ơi
(defun C:SL() (setq lay(cdr (assoc 8 (entget (car (entsel "\n Chon doi tuong mau:\n")))))) (setq taphop(ssget (list (cons 8 lay)))) (sssetfirst nil taphop))
-
Nhờ các bác viết hộ em lisp lọc các đối tượng là text trong một vùng kín (pline kín) sau đó xuất ra excel. Em cảm ơn các bác.
Lisp của bạn đây. Vùng kín hay hở đều chơi hết.File xuất ra gồm có STT X Y và nội dung Text
;========LISP OUTPUT TEXT BEN TRONG PLINE========== ;=============KANGKUNG 28/03/2013================== (defun C:KK() (setq plst (acet-geom-vertex-list (car (entsel "\n Select pline:\n")))) (setq plst1 (vl-sort plst '(lambda (e1 e2) (if (/= (car e1) (car e2)) (< (car e1) (car e2)) (< (cadr e1) (cadr e2)))))) (setq X_min(car (nth 0 plst1)) X_max(car (last plst1))) (setq plst2 (vl-sort plst '(lambda (e1 e2) (if (/= (cadr e1) (cadr e2)) (< (cadr e1) (cadr e2)) (< (car e1) (car e2)))))) (setq Y_min(cadr (nth 0 plst2)) Y_max(cadr (last plst2))) (command "ZOOM" (list X_min Y_min) (list X_max Y_max)) (setq taphop (ssget "CP" plst '((0 . "TEXT")))) (if (not Path) (setq Path(getvar "dwgprefix"))) (setq file(getfiled "Output File" Path "csv" 11) Path file) (setq file_out(open file "W")) (setq index 0) (while (< index (sslength taphop)) (setq TEXT (entget (ssname taphop index))) (if (= (+ (cdr(assoc 72 TEXT)) (cdr(assoc 73 TEXT))) 0) (setq InsertPoint(cdr(assoc 10 TEXT))) (setq InsertPoint(cdr(assoc 11 TEXT)))) (setq String(cdr(assoc 1 TEXT))) (write-line (strcat (rtos (+ index 1) 2 0) "," (rtos (car InsertPoint) 2 3) "," (rtos (cadr InsertPoint) 2 3) "," String) file_out) (setq index (+ index 1)) ) (close file_out) (alert "Well done!") ) (princ "\n Written By KangKung - 28/03/2013\n") (princ "\n Nhap KK de chay chuong trinh\n")-
3
-
-
Mình lại có việc làm phiền mọi người đây.
Mình làm quy hoạch, thường xuyên phải vẽ các tuyến đường 12m, 13m, 16m,.... nên nhờ mọi người viết 1 lisp về lệnh Offset để làm việc này.
Yêu cầu cụ thể như sau:
Từ 1 đường line (or pline, arc, spline) là tim đường ta gõ lệnh LG12, Cad sẽ tự động làm các việc như sau:
* Từ tim offset qua 2 bên, khoảng cách mỗi bên là 3 và chuyển 2 đường mới tạo ra này vào layer "00_Mep duong" sẵn có, nếu chưa có thì tạo mới layer này.
* Từ tim offset qua 2 bên, khoảng cách mỗi bên là 6 và chuyển 2 đường mới tạo ra này vào layer "00_Mep he" sẵn có, nếu chưa có thì tạo mới layer này.
Tương tự,
Từ 1 đường line (or pline) là tim đường ta gõ lệnh LG13, Cad sẽ tự động làm các việc như sau:
* Từ tim offset qua 2 bên, khoảng cách mỗi bên là 3,5 và chuyển 2 đường mới tạo ra này vào layer "00_Mep duong" sẵn có, nếu chưa có thì tạo mới layer này.
* Từ tim offset qua 2 bên, khoảng cách mỗi bên là 6,5 và chuyển 2 đường mới tạo ra này vào layer "00_Mep he" sẵn có, nếu chưa có thì tạo mới layer này.
....
Mời ae xem file đính kèm sẽ rõ hơn.
http://www.cadviet.com/upfiles/3/31951_offset_duong.dwg
Cái này rất hữu ích cho dân quy hoạch nên mong ae giúp dùm mình!
Thanks tất cả ae diễn đàn Cadviet!
Lisp của bác đây:
;========LISP OFFSET========== ;====KANGKUNG 28/03/2013====== (defun C:LG12() (command "UNDO" "BE") (setq os(getvar "OSMODE")) (setvar "OSMODE" 0) (setq dt (car(entsel)) i (/ pi 2)) (repeat 2 (setq pt (polar (vlax-curve-getPointAtDist dt 0) (+ (angle (vlax-curve-getPointAtDist dt 0) (vlax-curve-getPointAtDist dt (+ 0 0.1))) i) 1)) (of "3" pt "00_Mep duong") (of "6" pt "00_Mep he") (setq i (/ pi -2)) ) (setvar "OSMODE" os) (command "UNDO" "END") ) (defun C:LG13() (command "UNDO" "BE") (setq os(getvar "OSMODE")) (setvar "OSMODE" 0) (setq dt (car(entsel)) i (/ pi 2)) (repeat 2 (setq pt (polar (vlax-curve-getPointAtDist dt 0) (+ (angle (vlax-curve-getPointAtDist dt 0) (vlax-curve-getPointAtDist dt (+ 0 0.1))) i) 1)) (of "3.5" pt "00_Mep duong") (of "6.5" pt "00_Mep he") (setq i (/ pi -2)) ) (setvar "OSMODE" os) (command "UNDO" "END") ) (defun of(di pt la) (command "offset" di dt pt "") (if (= (tblsearch "Layer" la) nil) (progn (command "LAYER" "N" la "") (vla-put-layer (vlax-ename->vla-object (entlast)) la)) (vla-put-layer (vlax-ename->vla-object (entlast)) la))) (princ "\n Written By KangKung - 28/03/2013\n")-
3
-
-
Hê hê. Thằng block nó có áo giáp nên không đụng đến được bằng code trên đâu.
-
Vẫn không xuất ra txt được bạn ơi. Bạn xem lại giúp
Có hàng nghìn cách để không xuất ra được txt ví dụ như lisp lỗi, người sử dụng không đúng cách, hoặc gì gì đó v.v.... Vì thế để biết nó lỗi gì và có cách khắc phục thì bạn nên copy cái đoạn nó báo lỗi rồi paste lên đây hoặc là gửi file số liệu của bạn để mình test thử. Lần sau bạn nên làm như thế khi gặp trường hợp như thế này, đừng có thông báo quá sức ngắn gọn như vậy, chả ai biết mà lần với mò.
-
Mình mới tham gia vào diển đàn.rất mong các bác giúp đỡ.mình cần chuyển các đối tượng trong bản vẽ về layer,linetype khác.vd:
Tất cả layer 0-->layer 10
Layer 2 -->layer 90
Nét dash-->dash2
....
Mình đã tạo được lisp chuyển được các đối tượng về layer,linetype,linescale mong muốn rồi.NGOẠI TRỪ các đối tượng nằm trong BLOCK.các bác chỉ giùm mình cách truy cập các đối tượng trong block mà không phải rã block ra( có rất nhiều block,rã ra rồi phải ngồi block lại)mình cũng mới biết chút ít về autolisp thôi.cảm ơn các bác nhiều.
Yêu cầu của bạn tương tự yêu cầu ở Topic Vấn đề về màu Layer:
http://www.cadviet.com/forum/topic/69447-van-de-ve-mau-layer/
và Topic [Yên cầu] lisp lọc tất cả các đối tượng theo màu
http://www.cadviet.com/forum/topic/42436-yeu-cau-lisp-loc-tat-ca-cac-doi-tuong-theo-mau/
có chăng khác nhau ở chỗ bạn muốn chuyển từ Layer này sang Layer khác và từ Linetype này sang kiểu khác mà thôi.
Còn đây là Lisp theo yêu cầu của bạn. Lệnh KK1 để chuyển layer, lệnh KK2 để chuyển Linetype. Phải load linetype trước khi chạy lệnh KK2 nhé. Khi chạy lisp thì không riêng gì block mà toàn bộ đối tượng khác đều bị hết. Nói tóm lại là lisp này dùng cho toàn bộ đối tượng trên bản vẽ
http://www.cadviet.com/upfiles/3/71162_chuyeni_layer_linetype.lsp
;========LISP CHUYEN LAYER LINETYPE========== ;===========KANGKUNG 26/03/2013============== (defun C:KK1() (vl-load-com) (command "UNDO" "BE") (setq lay1(getstring T "\n Nhap ten Layer can chuyen: ")) (setq lay2(getstring T "\n Nhap ten Layer chuyen den: ")) (vlax-for for-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object))) (vlax-for item for-item (if (= (vla-get-Layer item) lay1) (vla-put-layer item lay2) ) ) ) (command "UNDO" "END") (alert "Well done!") ) (defun C:KK2() (vl-load-com) (command "UNDO" "BE") (setq type1(strcase(getstring T "\n Nhap ten LineType can chuyen: "))) (setq type2(strcase(getstring T "\n Nhap ten LineType chuyen den: "))) (vlax-for for-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object))) (vlax-for item for-item (if (= (vla-get-linetype item) "ByLayer") (setq Ltype(vla-get-linetype (vlax-ename->vla-object (TBLOBJNAME "LAYER" (vla-get-Layer item))))) (setq Ltype(vla-get-linetype item))) (if (= Ltype type1) (vla-put-linetype item type2) ) ) ) (command "UNDO" "END") (alert "Well done!") ) (princ "\n Written By KangKung - 26/03/2013\n") (princ "\n Nhap KK1 de chuyen Layer KK2 de chuyen LineType\n")-
2
-
-
Lisp này tuyệt quá rồi KangKung ơi. Cám ơn nhiều nha. Cho mình xin hỏi thêm tí. Vòng tròn trên mình dùng cho kí hiệu ô lưới 10 m, nếu có sự thay đổi kích cở của vòng tròn ( Ô lưới 5m ) Lisp có bị ảnh hưởng gì không ?? nhờ bạn giúp. Bạn viết Lisp hay qua, xin giải thích giúp mình các dòng lệnh của lisp này để mình học tâp với. ;;----------------------------------------------------------------- Xin phép bạn đừng nghĩ là mình thế này nọ nha... Nhờ bạn giúp mình Lisp : xuất ngược các nội dung từ Cad ( Theo mẫu cũ trên ) ra Excel với các nội dung STTO - CCTC - DIENTICH - KHOILUONG Trong vòng tròn ra Excel theo theo từng hàng, file xuất nằm cùng thư mục và cùng tên của cad . Rất Cám ơn
Lisp #6 chỉ đúng với trường hợp cụ thể như bản vẽ của bạn gửi thôi. Nếu bạn muốn xuất ngược xuất xuôi số liệu thì tốt nhất là dùng Block Attribute như Lisp #3. Lisp #3 có ưu điểm nữa là nếu bạn vẽ cho lưới 5m, 10m, 100m ... đều được hết, để làm điều đó bạn chỉ cần chỉnh lại vị trí của các Text trong bản vẽ đính kèm mục #3 thôi.
Tiện đây cho bạn cái lisp xuất số liệu Block Attribute từ CAD sang txt. Bạn dùng Lisp #3 và Lisp này là có thể chuyển đổi số liệu từ CAD sang TXT và ngược lại ngon lành rồi.
http://www.cadviet.com/upfiles/3/71162_output_attribute.lsp
;=====LISP CONVERT ATTRIBUTE TO TEXT========== ;=========KANGKUNG 26/03/2013================= (defun C:KK() (IF (NOT PATH) (SETQ PATH (getvar "dwgprefix"))) (setq taphop(ssget '((0 . "INSERT"))) index 0 tenfileout(getfiled "Output File" PATH "txt" 11)) (SETQ PATH tenfileout tenfile(open tenfileout "W")) (write-line "No. Easting Northing STTO CCTC D.TICH K.LUONG" tenfile) (setq i 0) (while (< index (sslength taphop)) (setq enlist (entget (ssname taphop index))i(1+ i) STT(rtos i 2 0) insert_point(cdr(assoc 10 enlist)) CHUOI (strcat STT "\t" (rtos (car insert_point) 2 3) "\t" (rtos (cadr insert_point) 2 3)) EN2(ENTNEXT(ssname taphop index)) ENLIST2(ENTGET EN2)) (while (/= (cdr(assoc 0 enlist2)) "SEQEND") (SETQ VALUE(cdr(assoc 1 enlist2)) TAG(cdr(assoc 2 enlist2)) CHUOI(STRCAT CHUOI "\t" VALUE) en2(entnext en2) enlist2(entget en2)) ) (write-line CHUOI tenfile) (setq index (+ index 1)) ) (alert (strcat (rtos i 2 0) " objects converted!")) (princ) (close tenfile) (COMMAND "NOTEPAD" tenfileout) ) (princ "\n Written By KangKung - 26/03/2013\n") (princ "\n Nhap KK de chay chuong trinh\n")-
1
-
-
Không muốn dùng Block Attribute thì chơi Lisp này, đúng theo yêu cầu luôn.
http://www.cadviet.com/upfiles/3/71162_update_so_lieu_tu_excel_vao_cad_rev1_1.lsp
;=====LISP UPDATE SO LIEU TU FILE TXT VAO CAD - REV1========== ;================KANGKUNG 25/03/2013========================== (defun C:KK() (command "UNDO" "BE") (setq taphop(ssget '((0 . "TEXT"))) os(getvar "OSMODE")) (if (not Path) (setq Path(getvar "dwgprefix"))) (setq file(getfiled "Select File:" Path "txt" 2) Path file index 0 TEXT_LIST (list)) (while (< index (sslength taphop)) (setq TEXT (entget (ssname taphop index))) (if (/= (read (cdr(assoc 1 TEXT))) (atof (cdr(assoc 1 TEXT)))) (progn (setq String(cdr(assoc 1 TEXT))) (if (= (+ (cdr(assoc 72 TEXT)) (cdr(assoc 73 TEXT))) 0) (setq InsertPoint(cdr(assoc 10 TEXT))) (setq InsertPoint(cdr(assoc 11 TEXT)))) (setq TEXT_LIST (append (list (list String InsertPoint)) TEXT_LIST)))) (setq index (1+ index))) (setq file_in(open file "R") lst_solieu(list)) (while(setq txt(read-line file_in)) (if (/= txt nil) (setq lst (read (strcat "(" txt ")" )))) (foreach dt TEXT_LIST (if (= (car dt) (vl-princ-to-string(car lst))) (progn (setq pt1(cadr dt) pt2(list (- (car pt1) 1.0757) (- (cadr pt1) 1.3762)) pt3(list (+ (car pt1) 1.2744) (- (cadr pt1) 1.3762)) pt4(list (car pt1) (- (cadr pt1) 2.7500))) (entmakex (list '(0 . "TEXT") (cons 8 "Main_DTOV") (cons 62 3) (cons 10 pt1) (cons 40 0.5) (cons 1 (vl-princ-to-string(car lst))) (cons 72 1) (cons 11 pt1) (cons 73 2))) (entmakex (list '(0 . "TEXT") (cons 8 "Main_CDTC") (cons 62 130) (cons 10 pt2) (cons 40 0.5) (cons 1 (rtos (cadr lst) 2 2)) (cons 72 1) (cons 11 pt2) (cons 73 2))) (entmakex (list '(0 . "TEXT") (cons 8 "Main_DTOV") (cons 62 2) (cons 10 pt3) (cons 40 0.5) (cons 1 (rtos (caddr lst) 2 2)) (cons 72 1) (cons 11 pt3) (cons 73 2))) (entmakex (list '(0 . "TEXT") (cons 8 "Main_KLOV") (cons 62 31) (cons 10 pt4) (cons 40 0.5) (cons 1 (rtos (cadddr lst) 2 2)) (cons 72 1) (cons 11 pt4) (cons 73 2))) ) ) ) ) (COMMAND "ERASE" TAPHOP "") (close file_in) (command "UNDO" "END") ) (princ "\n Written By KangKung - 25/03/2013\n") (princ "\n Nhap KK de chay chuong trinh\n")-
1
-
1
-
-
Thêm 1 Lisp nữa cho bạn đây.
http://www.cadviet.com/upfiles/3/71162_update_so_lieu_tu_excel_vao_cad.lsp
Lệnh KK nhé. Sau đó chọn file số liệu (chuyển sang dạng txt ngăn cách bởi dấu tab hoặc space) rồi chọn số liệu trên bản vẽ.
Tuy nhiên để chạy lisp này thì bạn copy file sau đây vào thư mục Support trong CAD
http://www.cadviet.com/upfiles/3/71162_a.dwg
;========LISP UPDATE SO LIEU TU FILE TXT VAO CADU========== ;================KANGKUNG 25/03/2013======================= (defun C:KK() (command "UNDO" "BE") (setq os(getvar "OSMODE")) (setvar "OSMODE" 0) (if (not Path) (setq Path(getvar "dwgprefix"))) (setq file(getfiled "Select File:" Path "txt" 2)) (setq Path file) (setq taphop(ssget '((0 . "TEXT")))) (setq index 0) (setq TEXT_LIST (list)) (while (< index (sslength taphop)) (setq TEXT (entget (ssname taphop index))) (if (/= (read (cdr(assoc 1 TEXT))) (atof (cdr(assoc 1 TEXT)))) (progn (setq String(cdr(assoc 1 TEXT))) (if (= (+ (cdr(assoc 72 TEXT)) (cdr(assoc 73 TEXT))) 0) (setq InsertPoint(cdr(assoc 10 TEXT))) (setq InsertPoint(cdr(assoc 11 TEXT))) ) (setq TEXT_LIST (append (list (list String InsertPoint)) TEXT_LIST)) ) ) (setq index (1+ index)) ) (setq file_in(open file "R")) (setq lst_solieu(list)) (while(setq txt(read-line file_in)) (if (/= txt nil) (setq lst (read (strcat "(" txt ")" )))) (foreach dt TEXT_LIST (if (= (car dt) (vl-princ-to-string(car lst))) (command "insert" "a" (cadr dt) "1" "1" "0" (vl-princ-to-string(car lst)) (vl-princ-to-string(cadr lst)) (vl-princ-to-string(caddr lst)) (vl-princ-to-string(cadddr lst))) ) ) ) (COMMAND "ERASE" TAPHOP "") (close file_in) (setvar "OSMODE" os) ) (princ "\n Written By KangKung - 25/03/2013\n") (princ "\n Nhap KK de chay chuong trinh\n")-
1
-
-
Vấn đề về màu layer
trong AutoLisp
Cụ tientracdia này có khả năng giải thích mà ai nghe hiểu được là chết liền :D :D :D
Đây là lisp chuyển các đối tượng về cùng 1 Layer (Current Layer) hoặc chuyển về Layer tương ứng theo màu đồng thời giữ nguyên kiểu đường. Lisp #11của KangKung và #12 của bác Duy mới chỉ chuyển được các đối tượng bình thường thôi chứ chưa xử được thằng block. Lisp mới này chơi hết luôn,
Hướng dẫn: Lệnh KK, Lisp sẽ hỏi chuyển các đối tượng về cùng 1 layer hay không. Nếu chọn Y thì toàn bộ đối tượng trong bản vẽ sẽ về layer hiện hành, nếu chọn N thì đối tượng màu 1,2,3 ... sẽ về layer Color_1, Color_2, Color_3 ...
;========LISP CHUYEN TAT CA CAC DOI TUONG VE CUNG LAYER HOAC VE LAYER THEO MAU========== ;=======================GIU NGUYEN MAU SAC, LINETYPE==================================== ;===========================KANGKUNG 25/03/2013========================================= (defun C:KK() (vl-load-com) (command "UNDO" "BE") (initget 1 "Y N") (setq hoi(getkword "\n Chuyen ve cung 1 Layer? (Y or N): ")) (setq Clayer(getvar "CLAYER")) (vlax-for for-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object))) (vlax-for item for-item (setq color (cond ((/= (setq color (vla-get-color item)) 256) color) ((cdr (assoc 62 (entget (TBLOBJNAME "LAYER" (vla-get-Layer item)))))) ) ) (if (= 0 color) (setq color 255)) (if (= (vla-get-linetype item) "ByLayer") (setq Ltype(vla-get-linetype (vlax-ename->vla-object (TBLOBJNAME "LAYER" (vla-get-Layer item))))) (setq Ltype(vla-get-linetype item))) (vla-put-linetype item Ltype) (vla-put-color item color) (if (= hoi "Y") (vla-put-layer item Clayer) (if (= (tblsearch "Layer" (strcat "Color_" (rtos color 2 0))) nil) (progn (command "LAYER" "N" (strcat "Color_" (rtos color 2 0)) "C" color (strcat "Color_" (rtos color 2 0)) "") (vla-put-layer item (strcat "Color_" (rtos color 2 0))) ) (vla-put-layer item (strcat "Color_" (rtos color 2 0))) ) ) ) ) (command "REGEN") (command "UNDO" "END") (princ) (alert "Well done!") ) (princ "\n Written By KangKung\n") (princ "\n Nhap KK de chay chuong trinh\n")-
1
-
1
-
-
Đúng hay sai cứ Like cái đã. Bạn nhiệt tình quá, có nhiều mem thế này bảo sao CV k mạnh ^^
Chuẩn rồi đấy. Két bấm like cho mỏi tay vào nhé. :D :D :D
Đang lúc rỗi rải nên tranh thủ góp vui với anh em CV tí. Tỉ phú thời gian mà.
-
Lisp mới chuyển toàn bộ các đối tượng trong block về cùng 1 Layer, giữ nguyên màu sắc. Block đơn giản hay phức tạp cũng chơi hết. :D
Load lisp rồi nhập kk là xong. Không cần phải chọn đối tượng làm gì, toàn bộ block có trong bản vẽ sẽ được chuyển hết.
http://www.cadviet.com/upfiles/3/71162_chuyen_cac_doi_tuong_trong_block_ve_cung_1_layer_rev2.lsp
PS: Cụ thanhphatld muốn che đối tượng nằm dưới block thì dùng wipeout trong block là OK ngay.
;=====LISP CHUYEN CAC DOI TUONG TRONG BLOCK VE CUNG 1 LAYER - REV2======= ;======================KANGKUNG 24/03/2013=============================== (defun C:kk() (vl-load-com) (command "UNDO" "BE") (vlax-for for-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object))) (vlax-for item (vla-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object))) (vla-get-name for-item)) (if (= (vlax-get-property item 'Color) 256) (setq color (cdr (assoc 62 (entget (TBLOBJNAME "LAYER" (vlax-get-property item 'Layer)))))) (setq color (vlax-get-property item 'Color))) (vlax-put-property item 'Color color) (vlax-put-property item 'Layer (getvar "CLAYER")) ) ) (command "UNDO" "END") (princ) (alert "Well done!") ) (princ "\n Written By KangKung\n") (princ "\n Nhap KK de chay chuong trinh\n")-
1
-
5
-
-
Theo mình, Quick Select và Filter hoàn toàn không đáp ứng được nhu cầu. Mình xin diễn giải nhu cầu của chủ thớt như sau:
- Tự động tìm kiếm xem trên bản vẽ có bao nhiêu màu (bao gồm cả màu đối tượng và màu của layer). Giả sử có 2 màu là 1 và 2.
- Tạo lớp Color001 và lọc tất cả các đối tượng có màu số 1, bao gồm
+ Tất cả đối tượng có màu 1.
+ Tất cả đối tượng có màu bylayer nằm trên layer có màu 1.
+ Tất cả đối tượng con trong Block đáp ứng 2 điều kiện trên.
-> sau đó chuyển về tất cả về lớp Color001.
- Tiếp tục cho lớp Color002.
- Kết quả: Sau khi thực hiện xong Lisp, màu của bản vẽ không có gì thay đổi, trong bản vẽ có bao nhiêu màu thì sẽ có bấy nhiêu layer được tạo ra và chứa đúng đối tượng có màu đó. Riêng với đối tượng Dimension mình chưa biết phải làm thế nào, vì nó là đối tượng phức và bản thân nó có thể có nhiều màu khác nhau (cho mũi tên, text và đường gióng nữa).
Đây là yêu cầu, còn thực hiện nó không hề đơn giản chỉ một câu lệnh.
Lisp đây lisp đây.....
Lisp này chuyển tất tần tật các loại đối tượng trên bản vẽ (Model hay Layout đều chơi tất) có màu giống nhau về layer tương ứng với màu đó. (chả biết có chuyển được hết tất cả các đối tượng không nhưng mà test thử nhiều loại đối tượng như Text, Qleader, Xline, Mline, Hatch v.v... thì OK rồi, Dimension và các đối tượng con trong block của bác LoveLisp cũng chuyển ngon lành luôn).
Các bác dùng xem có vấn đề gì không rồi cho ý kiến và nhớ đừng quên Like em đấy nhé.
http://www.cadviet.com/upfiles/3/71162_lisp_chuyen_doi_tuong_cung_mau_ve_cung_layer.lsp
;========LISP CHUYEN DOI TUONG CUNG MAU VE CUNG LAYER========== ;=================KANGKUNG 24/03/2013========================== (defun C:KK() (vl-load-com) (command "UNDO" "BE") (vlax-for for-item (vla-get-modelspace(vla-get-activedocument (vlax-get-acad-object))) (progn (if (= (vla-get-color for-item) 256) (setq color(cdr (assoc 62 (entget (TBLOBJNAME "LAYER" (vla-get-layer for-item)))))) (setq color(vla-get-color for-item)) ) (if (= (tblsearch "Layer" (strcat "Color_" (rtos color 2 0))) nil) (progn (command "LAYER" "N" (strcat "Color_" (rtos color 2 0)) "C" color (strcat "Color_" (rtos color 2 0)) "") (vla-put-layer for-item (strcat "Color_" (rtos color 2 0))) ) (vla-put-layer for-item (strcat "Color_" (rtos color 2 0))) ) ) ) (vlax-for for-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object))) (vlax-for item (vla-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object))) (vla-get-name for-item)) (if (= (vlax-get-property item 'Color) 256) (setq color (cdr (assoc 62 (entget (TBLOBJNAME "LAYER" (vlax-get-property item 'Layer)))))) (setq color (vlax-get-property item 'Color)) ) (if (= 0 color) (setq color 7)) (if (= (tblsearch "Layer" (strcat "Color_" (rtos color 2 0))) nil) (progn (command "LAYER" "N" (strcat "Color_" (rtos color 2 0)) "C" color (strcat "Color_" (rtos color 2 0)) "") (vlax-put-property item 'Layer (strcat "Color_" (rtos color 2 0))) ) (vlax-put-property item 'Layer (strcat "Color_" (rtos color 2 0))) ) ) ) (command "UNDO" "END") (princ) (alert "Well done!") ) (princ "\n Written By KangKung\n") (princ "\n Nhap KK de chay chuong trinh\n")-
2
-
-
Hàng mới của cụ thanhphatld đây. Đã sửa code theo góp ý của Ketxu tuy nhiên đang lằng nhằng ở đoạn block trong block nên mới chỉ sử dụng được với các block đơn giản thôi nhé.
http://www.cadviet.com/upfiles/3/71162_chuyen_cac_doi_tuong_trong_block_ve_cung_1_layer_rev1.lsp
;=====LISP CHUYEN CAC DOI TUONG TRONG BLOCK VE CUNG 1 LAYER - REV1======= ;======================KANGKUNG 23/03/2013=============================== (defun C:kk() (vl-load-com) (command "UNDO" "BE") (setq taphop(ssget '((0 . "INSERT")))) (setq soluong (sslength taphop)) (setq index 0) (setq items (list)) (while (< index soluong) (setq nfo (entget (ssname taphop index))) (vlax-for item (vla-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object))) (cdr (assoc 2 nfo))) (progn (setq kt 0) (foreach abcdef items (if (eq abcdef (vlax-vla-object->ename item)) (setq kt 1))) (if (= kt 0) (setq items (cons (vlax-vla-object->ename item) items))) )) (setq index (+ index 1)) ) (foreach item items (if (= (vlax-get-property (vlax-ename->vla-object item) 'Color) 256) (setq Color (cdr (assoc 62 (entget (TBLOBJNAME "LAYER" (vlax-get-property (vlax-ename->vla-object item) 'Layer)))))) (setq Color (vlax-get-property (vlax-ename->vla-object item) 'Color)) ) (vlax-put-property (vlax-ename->vla-object item) 'color Color) (vlax-put-property (vlax-ename->vla-object item) 'Layer (getvar "CLAYER")) ) (command "REGEN") (command "UNDO" "END") (princ) ) (princ "\nNhap KK de chay chuong trinh\n")-
3
-
-
@KangKung : mình đọc qua code thì có mấy góp ý nhỉ sau, bạn xem có xài đc thằng nào k ^^
- Nên lọc insert trong thao tác ssget, bỏ bước kiểm tra type
- Mỗi insert thì nên lưu tên vào một list, lần sau k có trong list thì mới làm. Bạn đang làm việc thay đổi Block table, mà cứ thấy có insert lại lục tung định nghĩa block ra sửa, ắt sẽ chịu cảnh chặt chém nhiều lần
- Yêu cầu là layer thôi, k liên quan đến màu
- Nếu dùng vlax-for rồi thì chỉ cần put layer thôi, đừng chuyển về ename nữa ...
- Nếu đã chuyển về ename, mà lại thíh đổi cả màu thì cứ thế mà entmod list entget + 62 màu thôi ...
- và v...v
Két comment chuẩn đấy. Tuy nhiên có điều này thôi: Chủ thớt không yêu cầu về màu sắc nhưng nếu block được tạo bằng các đối tượng có màu sắc khác nhau thì khi chuyển về cùng 1 layer có thể xảy ra trường hợp toàn bộ đối tượng trong block sẽ bị đổi màu về màu của layer (By Layer). Code đặt màu nhằm giữ nguyên màu sắc cho block đó.
Lisp trên mới chuyển được các đối tượng trong block đơn giản, nghĩa là block được tạo bằng các đối tượng bình thường của CAD như text, line, polyline ... còn block phức tạp bao gồm block trong block (nhiều block lồng vào nhau) thì không chuyển được. Mình đang viết code cho trường hợp đó.
-
trong bản vẽ của mình có rất nhiều block , mình muốn chuyển tất cả các đối tượng trong tất cả các block về cùng 1 layer thì làm thế nào mong các bác giúp em với, chỉ thực hiện 1 lệnh thui chứ làm từng cái thì lâu quá
Đây Lisp của cụ đây. Lệnh KK rồi chọn block. Các đối tượng trong block sẽ chuyển về Layer hiện hành.
Cụ chạy ngon lành thì vui lòng bấm nút mũi tên màu xanh phía dưới bên phải của bài viết này hộ cái nhé.
http://www.cadviet.com/upfiles/3/71162_chuyen_cac_doi_tuong_trong_block_ve_cung_1_layer.lsp
;=====LISP CHUYEN CAC DOI TUONG TRONG BLOCK VE CUNG 1 LAYER======= ;===================KANGKUNG 22/03/2013=========================== (defun C:kk() (vl-load-com) (command "UNDO" "BE") (setq taphop(ssget)) (setq soluong (sslength taphop)) (setq index 0) (setq items (list)) (while (< index soluong) (if (= (cdr (assoc 0 (setq nfo (entget (ssname taphop index))))) "INSERT") (vlax-for item (vla-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object))) (cdr (assoc 2 nfo))) (setq items (cons (vlax-vla-object->ename item) items)) ) ) (foreach obj1 items (setq obj(entget obj1)) (if (= (assoc 62 obj) nil) (setq Color (cdr (assoc 62 (entget (TBLOBJNAME "LAYER" (cdr (assoc 8 obj))))))) (setq Color (cdr(assoc 62 obj)))) (if (= (assoc 62 obj) nil) (progn (setq obj(append obj (list (cons 62 Color)))) (entmod obj)) (entmod (subst (cons 62 Color) (assoc 62 obj) obj)) ) (setq Layer (getvar "Clayer")) (entmod (subst (cons 8 Layer) (assoc 8 obj) obj)) ) (setq items (list)) (setq index (+ index 1)) ) (command "UNDO" "END") (princ) ) (princ "\nNhap KK de chay chuong trinh\n")-
4
-
14
-
-
Vấn đề về màu layer
trong AutoLisp
mọi người ơi làm sao để đăng bài lên diễn đàn vậy
Bạn vào mục này: CADViet forum - Lập trình CAD - AutoLisp. Chọn nút Gửi bài mới ở phía trên bên phải. Nếu vẫn chưa tìm thấy thì Link đây
-
1
-
-
Vấn đề về màu layer
trong AutoLisp
Tình hình là mình có một nhóm đối tượng gồm nhiều layer khác nhau và mình muốn chuyển tất cả những layer đó về cùng một layer mà màu của chúng vẫn giữ nguyên. Bác nào biết cách nào làm được điều đó hoặc lisp nào làm được thì chỉ mình với!
Bạn dùng cái này xem. Lệnh kk sau đó chọn đối tượng. Toàn bộ đối tượng được chọn sẽ chuyển về Layer hiện hành.
http://www.cadviet.com/upfiles/3/71162_chuyen_tat_ca_layer_thanh_1_layer_giu_nguyen_mau_sac.lsp
(defun C:kk() (command "UNDO" "BE") (setq taphop(ssget)) (setq soluong (sslength taphop)) (setq index 0) (while (< index soluong) (setq obj(entget(ssname taphop index))) (if (= (assoc 62 obj) nil) (setq Color (cdr (assoc 62 (entget (TBLOBJNAME "LAYER" (cdr (assoc 8 obj))))))) (setq Color (cdr(assoc 62 obj)))) (if (= (assoc 62 obj) nil) (progn (setq obj(append (list (cons 62 Color)) obj)) (entmod obj)) (entmod (subst (cons 62 Color) (assoc 62 obj) obj)) ) (setq layer (getvar "Clayer")) (entmod (subst (cons 8 Layer) (assoc 8 obj) obj)) (setq index (+ index 1)) ) (command "UNDO" "END") (princ) )-
1
-
1
-
-
anh KangKung xem hình minh họa nhoc đưa lên chưa anh ^^
Hi Nhoclangbat
Mình xem hình minh họa nhoc post lên rồi nhưng chưa hiểu ý đồ của nhoc lắm. Tuy nhiên mình nghĩ việc này nhoc tự làm được mà. Nhoc thử modify cái lisp mình gửi theo ý của nhoc xem sao. Nhoc muốn gì thì nhoc là người hiểu rõ nhất phải không? Mình nghĩ code Lisp trong file mình gửi cho nhoc đủ để làm việc đó, nhoc chỉ việc thay đổi thứ tự của nó đi thôi là được.
[ yêu cầu ] Lisp up nội dung từ Excel vào Cad
trong AutoLisp
Đã đăng · Trả lời báo cáo
Bạn xem hình minh hoạ rồi sửa lại cho phù hợp.