Jump to content
InfoFile
Tác giả: quansla
Bài viết gốc: 227099
Tên lệnh: copy cad txt
AutoLisp copy "TEXT" từ Cad sang Excel và ngược lại

Mình có một lisp để có thể thao tác sử lý chuyển đổi nhanh chóng và đơn giản (chỉ bằng 1 cú click chuột) tất cả các dữ liệu dạng "text" từ AutoCad sang Excel và ngược lại, rất tiện dụng cho các bác QA/QS tính toán với vô vàn con số.

Giờ đây các bạn hoàn toàn có thể copy cả một kho dữ liệu từ Cad sang...

>>

Mình có một lisp để có thể thao tác sử lý chuyển đổi nhanh chóng và đơn giản (chỉ bằng 1 cú click chuột) tất cả các dữ liệu dạng "text" từ AutoCad sang Excel và ngược lại, rất tiện dụng cho các bác QA/QS tính toán với vô vàn con số.

Giờ đây các bạn hoàn toàn có thể copy cả một kho dữ liệu từ Cad sang Excel mà không cần phải chuyển đổi qua lại để nhập vào Office nữa, nói chung là bạn sử dụng sẽ thấy rất tuyệt vời.

***

***

 

Update: Link download & use:

http://cauduongbkdn.com/f@rums/showthread.php?39316-Xu%E1%BA%A5t-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-Cad-Sap-qua-Excel-v%C3%A0-ng%C6%B0%E1%BB%A3c-l%E1%BA%A1i

Hix, mình thì không có và nhìn sơ sơ thì có vẻ là mình không quen dùng, mình viết tạm cái lísp này vậy

Mới chỉ có khả năng copy text , Mtext từ Cad ra Txt thôi, phải thêm một công đoạn nữa nếu mún sang Excel

Còn từ Excel về Txt rồi qua Cad thì từ từ mình tính(hix, khả năng có hạn, mà cố quá khéo quá cố mất)

đây là líp. tên lệnh là copy_cad_txt . Cách sử dụng là gõ tên lệnh, chọn File Txt có sẵn(lưu ý sẽ bị ghi đè lên giữ liệu cũ) hoặc lưu vào File txt mới. Sau đó quét chẽ text bình thường

Anh Admin ơi sao giờ khó viết thế, anh chỉ em cách tắt Check chính tả và bật mấy cái vụ làm chữ đậm, in nghiêng, bôi đen tô mầu với

{ đoạn này em sửa được rồi, nhưng giờ ko nhanh như trước- chỉ còn đoạn tắt chính tả thôi- mong Ad giúp}

Đây là líp

(defun c:copy_cad_txt (/ Tieude TenFile f lst i xau N x y) (vl-load-com) (setq TenFile (getfiled "Chon file .txt:" "" "txt" 5)) (setq lst (vl-sort (acet-ss-to-list (ssget '(( 0 . "*text")))) '(lambda (x y / px py ) (if (not (equal (cadr (setq px (cdr(assoc 10 (entget x))))) (cadr (setq py (cdr(assoc 10 (entget y))))) 1E-3)) (> (cadr px) (cadr py)) (< (car px) (car py)) ) ) )) (setq Tieude (strcat (getvar "dwgprefix") (getvar "dwgname") "\n" "\n")) (setq xau (strcat Tieude (cdr (assoc 1 (entget (setq m1 (car lst))) ))) i 0 N (length lst)) (while (< i (1- N)) (if (equal (caddr(assoc 10 (entget (nth i lst)) )) (caddr(assoc 10 (entget (nth (1+ i) lst)) )) 1E-3) (setq xau (strcat xau "\t" (cdr (assoc 1 (entget (nth (1+ i) lst)))))) (setq xau (strcat xau "\n" (cdr (assoc 1 (entget (nth (1+ i) lst)))) )) ) (setq i (1+ i)) ) (progn (setq f (open TenFile "w")) (write-line xau f) (close f) ) (prompt (strcat "Da xuat cac Text duoc chon ra: " TenFile )) (princ) )
<<

Filename: 227099_copy_cad_txt.lsp
Tác giả: KangKung
Bài viết gốc: 227047
Tên lệnh: mtl
[Yêu cầu] Lisp tạo viewport từ khung chọn bên model.

Bạn khaosatheco thân mến.

Lisp #54 vẫn chạy được nếu polyline kín của bạn chỉ có 5 điểm hoặc có 4 điểm đầu tiên trùng với 4 góc của khung hình chữ nhật. Tuy nhiên tôi đã sửa lại theo ý của bạn là chọn polyline kín thì lisp vẫn chạy được. Thậm chí nếu polyline có hình loằng ngoằng thì lisp vẫn tạo cho bạn viewport bao kín hình polyline đó đúng với tỷ lệ bạn nhập...

>>

Bạn khaosatheco thân mến.

Lisp #54 vẫn chạy được nếu polyline kín của bạn chỉ có 5 điểm hoặc có 4 điểm đầu tiên trùng với 4 góc của khung hình chữ nhật. Tuy nhiên tôi đã sửa lại theo ý của bạn là chọn polyline kín thì lisp vẫn chạy được. Thậm chí nếu polyline có hình loằng ngoằng thì lisp vẫn tạo cho bạn viewport bao kín hình polyline đó đúng với tỷ lệ bạn nhập vào.

http://www.cadviet.com/upfiles/3/71162_mtl_rev4i.lsp

;========LISP TAO VIEWPORT TREN LAYOUT BANG CACH CHON O MODEL======== ;===============REV4i===================== (defun C:mtl( / lst khung X_min Y_min X_max Y_max X index taphop) (command "UNDO" "BE") (setvar "OSMODE" 0) (setq taphop(ssget )) (if (= Tyle nil) (setq Tyle1 1) (setq Tyle1 Tyle)) (setq Tyle (getreal (strcat "\n Ty le: <" (rtos Tyle1 2 0) "> "))) (if (= Tyle nil) (setq Tyle Tyle1)) (setq soluong (sslength taphop)) (setq index 0) (command "LAYOUT" "N" "Layout1") (command "LAYOUT" "S" "Layout1") (command "ERASE" "ALL" "") (command "MODEL") (setq X 0) (command "ZOOM" "E") (while (< index soluong) (setq khung(ssname taphop index)) (setq lst(acet-geom-vertex-list khung)) (setq X_min 1000000000 Y_min 1000000000 X_max -1000000000 Y_max -1000000000) (foreach a lst (if (< (car a) X_min) (setq X_min (car a))) (if (< (cadr a) Y_min) (setq Y_min (cadr a))) (if (> (car a) X_max) (setq X_max (car a))) (if (> (cadr a) Y_max) (setq Y_max (cadr a))) ) (command "LAYOUT" "S" "Layout1") (command "RECTANG" (list X_min Y_min) (list X_max Y_max)) (command "MOVE" (entlast) "" (list X_min Y_min) (list X 0)) (command "SCALE" (entlast) "" (list X 0) (/ 1 tyle)) (command "MVIEW" "O" (entlast)) (command "MSPACE") (command "ZOOM" (list X_min Y_min) (list X_max Y_max)) (command "PSPACE") (setq X(+ X 50 (/ (abs(- X_max X_min)) tyle))) (command "ZOOM" "W" (list 0 0) (list (+ X 100) 0)) (setq index (+ index 1)) ) (command "MODEL") (command "UNDO" "END") (setvar "OSMODE" 15359) (princ) )
<<

Filename: 227047_mtl.lsp
Tác giả: draftsman38751
Bài viết gốc: 181607
Tên lệnh: oval%3Cbr%3E
[Nhờ chỉnh sửa]Lisp vẽ hình oval
Nhờ các bác chỉnh sửa giúp em lisp này với!Cảm ơn các bác nhiều!!

(defun main
FasStringtables 0
FasStringtables 1
(defun main
nil
(setq C:OVAL <Func> C:OVAL)
(vl-ACAD-defun C:OVAL)
(defun C:OVAL
(_al-bind-alist '(*OVL:ERR* C_E C1 C2 R ANG O1 O2 O3 O4 CE))
(defun *OVL:ERR*
(M)
(cond (MEMBER M '("Function cancelled" "quit / exit abort" "console break")) (
>>
Nhờ các bác chỉnh sửa giúp em lisp này với!Cảm ơn các bác nhiều!!

(defun main
FasStringtables 0
FasStringtables 1
(defun main
nil
(setq C:OVAL <Func> C:OVAL)
(vl-ACAD-defun C:OVAL)
(defun C:OVAL
(_al-bind-alist '(*OVL:ERR* C_E C1 C2 R ANG O1 O2 O3 O4 CE))
(defun *OVL:ERR*
(M)
(cond (MEMBER M '("Function cancelled" "quit / exit abort" "console break")) (
(cond (PROMPT (STRCAT "\n< " M " >\n")) (
it's OR skip next 6 bytes -> 81
it's OR skip next 6 bytes -> 81
T
(ENTDEL CE)
(SETVAR Then OR Else C_E)
(setq *ERROR* *E*)
(setq *OVL:ERR* <Func> *OVL:ERR*)
(cond *E* (
(cond *ERROR* (
normal cond
normal cond
(setq *E* nil)
(setq *ERROR* *OVL:ERR*)
(setq C_E (GETVAR "cmdecho"))
(setq C1 (GETPOINT "\nFirst end of oval <center point>: "))
(PROMPT "\nOval width <point>: ")
(SETVAR "cmdecho" 0)
(ads-cmd "circle")
(ads-cmd C1)
(ads-cmd PAUSE)
(setq CE (ENTLAST ))
(PROMPT "\nOther end of oval: ")
(ads-cmd "move")
(ads-cmd "l")
(ads-cmd "")
(ads-cmd C1)
(ads-cmd PAUSE)
(setq C2 (CDR (ASSOC 10 (ENTGET (ENTLAST )))))
(setq R (CDR (ASSOC 40 (ENTGET (ENTLAST )))))
(setq ANG (ANGLE C1 C2))
(setq O1 (POLAR C1 (+ ANG (/ PI 2)) R))
(setq O2 (POLAR C1 (- ANG (/ PI 2)) R))
(setq O3 (POLAR C2 (- ANG (/ PI 2)) R))
(setq O4 (POLAR C2 (+ ANG (/ PI 2)) R))
(ENTDEL CE)
(ads-cmd "pline")
(ads-cmd O1)
(ads-cmd "w")
(ads-cmd 0)
(ads-cmd 0)
(ads-cmd "a")
(ads-cmd "ce")
(ads-cmd C1)
(ads-cmd O2)
(ads-cmd "l")
(ads-cmd O3)
(ads-cmd "a")
(ads-cmd O4)
(ads-cmd "l")
(ads-cmd "c")
(SETVAR Then OR Else C_E)
(setq *ERROR* *E*)

<<

Filename: 181607_oval%3Cbr%3E.lsp
Tác giả: phamngoctukts
Bài viết gốc: 116115
Tên lệnh: colorx colorxref colorxl colorxrefl
Đổi màu tất cả các đối tượng trên bản vẽ thành một màu duy nhất

Cái lisp này mình sưu tầm được trên mạng đã lâu. Nay thấy bạn có nhu cầu mình port lên bạn xem có vư ý không nhé.

Filename: 116115_colorx_colorxref_colorxl_colorxrefl.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 228445
Tên lệnh: ha
Thanks for every other informative site. Where else may I am getting that kind of info written in such an ideal way? I have a mission that I"m simply now running on, and I"ve been at the look out for such information.

Có thể dùng field như anh Ketxu nói để ngày tháng có thể update được.

Còn muốn cố định chúng và muốn dùng lisp thì quick code cho bạn đây:

;Doan Van Ha - CADViet.com - Ngay 13/3/2013.

;Chuc nang: Chen ngay thang vao *TEXT.
;Ghi chu:
;Kieu 1: 13/3/2013
;Kieu 2: 13/3/2013 16:35
(defun C:HA( / lst kieu ent)
 (load "julian.lsp")
 (setq lst (jtoc...
>>

Có thể dùng field như anh Ketxu nói để ngày tháng có thể update được.

Còn muốn cố định chúng và muốn dùng lisp thì quick code cho bạn đây:

;Doan Van Ha - CADViet.com - Ngay 13/3/2013.

;Chuc nang: Chen ngay thang vao *TEXT.
;Ghi chu:
;Kieu 1: 13/3/2013
;Kieu 2: 13/3/2013 16:35
(defun C:HA( / lst kieu ent)
 (load "julian.lsp")
 (setq lst (jtoc (getvar "date")))
 (initget "1 2")
 (setq kieu (getkword "\nChon kieu chen <1>: "))
 (cond
  ((or (= kieu "1") (not kieu)) (setq txt (strcat (itoa (nth 2 lst)) "/" (itoa (nth 1 lst)) "/" (itoa (nth 0 lst)))))
  (T (setq txt (strcat (itoa (nth 2 lst)) "/" (itoa (nth 1 lst)) "/" (itoa (nth 0 lst)) " " (itoa (nth 3 lst)) ":" (itoa (nth 4 lst))))))
 (while (or (not (setq ent (car (entsel "\nChon 1 Text hoac Mtext: ")))) (not (wcmatch (cdr (assoc 0 (entget ent))) "*TEXT"))))
 (entmod (subst (cons 1 txt) (assoc 1 (entget ent)) (entget ent))))

<<

Filename: 228445_ha.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 228593
Tên lệnh: gcddm
Đưa bình đồ dạng đường đồng mức về bình đồ dạng cao độ

Bác tạo luôn block (bằng lisp) chứa text xong nổ nó ra sửa quách cho nó đỡ lẹo tẹo bác ạ!

Hề hề hề,

Đây là một cái block cd1 mình tạo ra cho nó phù hợp với bản vẽ của chủ thớt. Mọi người down về rồi tự hiệu chỉnh cho nó vừa khớp với bản vẽ của mỗi người và khớp với sở...

>>

Bác tạo luôn block (bằng lisp) chứa text xong nổ nó ra sửa quách cho nó đỡ lẹo tẹo bác ạ!

Hề hề hề,

Đây là một cái block cd1 mình tạo ra cho nó phù hợp với bản vẽ của chủ thớt. Mọi người down về rồi tự hiệu chỉnh cho nó vừa khớp với bản vẽ của mỗi người và khớp với sở thích của mỗi designer.

http://www.cadviet.com/upfiles/3/5194_cd1.dwg

 

Trước khi chạy lisp hãy copy cái block này vào bản vẽ cần chạy.

 

Mình có chỉnh sửa lại một chút trong lisp dưới đây để tránh lỗi do dùng lệnh measure với các đường đồng mức có độ dài nhỏ hơn khoảng cách 200 như đã mặc định trong lisp. Khi người dùng cần thay đổi khoảng cách này thì lưu ý đặt lại điều kiện cho phù hợp.

 

(defun c:gcddm ( / pl plst ssdml cdmax chcd i els ssp cdt p0 ssp0)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq pl (car (entsel "\n Chon duong dan"))
          plst (acet-geom-vertex-list pl ) )
 
(setq ssdml (acet-ss-to-list (ssget "f" plst (list (cons 0 "lwpolyline") (cons 62 30) (cons 8 "1,2,5")))))
 
(setq cdmax (getreal "\n Nhap cao do bat dau: ")
          chcd (getreal "\n Nhap do chenh cao giua cac duong dong muc: ")
          i 0 )
 (foreach dm ssdml
         (setq els (entget dm)
                  cdt  (+ cdmax (* i chcd))
                  els (subst (cons 38 cdt ) (assoc 38 els) els)
                  els (subst (cons 62 2) (assoc 62 els) els) )
         (entmod els)
         (setq p0 (vlax-curve-getpointatdist dm 200))
         (if p0
             (progn
                   (command "measure" dm   200)
                   (setq ssp0 (ssget "p"))
                   (setq ssp (acet-ss-to-list ssp0))         
                   (foreach pt ssp
                        (command "insert" "cd1" (cdr (assoc 10 (entget pt))) 1 1 0 (rtos cdt 2 0) )
                   )
              )
              (command "insert" "cd1" (vlax-curve-getstartpoint dm) 1 1 0 (rtos cdt 2 0) )
         )
         (setq i (1+ i)  )
)
(command "erase" pl "")
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
         
Chúc mọi người luôn hạnnh phúc, vui vẻ, khỏe người.

<<

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

Bản vẽ A đang mở. Bản vẽ B đang đóng. Trong B có chứa 1 số Block Attribute.

Việc lấy các block trong B để chèn vào A thì OK rồi.

Nhưng việc lấy các Att của từng block trong B thì sao tôi mần hoài không được.

Ai biết xin chỉ giùm với?

Hà tham khảo hàm get_attLst trích trong Lisp

>>

Bản vẽ A đang mở. Bản vẽ B đang đóng. Trong B có chứa 1 số Block Attribute.

Việc lấy các block trong B để chèn vào A thì OK rồi.

Nhưng việc lấy các Att của từng block trong B thì sao tôi mần hoài không được.

Ai biết xin chỉ giùm với?

Hà tham khảo hàm get_attLst trích trong Lisp Block Attributes Extraction

(defun get_attLst (fullFileName blkName / acver attlst dbxdoc res)
  (setq dbxdoc (vla-GetInterfaceObject (vlax-get-acad-object)
   (if (< (setq acVer (atoi (getvar "ACADVER"))) 16) "ObjectDBX.AxDbDocument"
     (strcat "ObjectDBX.AxDbDocument." (itoa acVer)))))
  (vla-open dbxdoc fullFileName)
  (vlax-for lay (vla-get-Layouts dbxdoc)
    (vlax-for obj (vla-get-Block lay)
      (if (and (eq (vla-get-ObjectName obj) "AcDbBlockReference")
        (vla-get-HasAttributes obj)
        (eq (vla-get-Name obj) blkname)  )
 (progn
   (setq attLst (list))
   (foreach att (vlax-invoke obj 'GetAttributes)
     (setq attLst (cons (vla-get-TextString Att) attLst)) )
   (setq res (cons (reverse attLst) res))) )))
  (vlax-release-object dbxdoc)
  res)
 

cách sử dụng :

(defun c:test(/ blkname fil sfile) 
  (if (and
 (setq blkname "HA" ; doi ten block cho phu hop "KTA3Bia" "KTA3ngang"
       sfile(getfiled "File to get Attributes"  (getvar "dwgprefix")  "dwg" 16))
 (setq fil (findfile sfile)))
    (princ (vl-princ-to-string (get_attLst fil blkname))))
  (princ))
 


<<

Filename: 228557_test.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 6023
Tên lệnh: cinvis
Viết Lisp theo yêu cầu
Lệnh CINVIS dưới đây giống lệnh INVIS ở trên nhưng ẩn đối tượng theo màu.


Filename: 6023_cinvis.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 228654
Tên lệnh: gcddm
Đưa bình đồ dạng đường đồng mức về bình đồ dạng cao độ

Giờ mới rảnh, lại tò mò!

1. Các bác chỉ dùm mình chổ nào (nút nào) để down cái lisp của bác Bình !<hình>

 

2. Mình Copy --> dán theo bác Bình chỉ thì đc cái này

(defun c:gcddm ( / pl plst ssdml cdmax chcd i els ssp cdt )
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command...
>>

Giờ mới rảnh, lại tò mò!

1. Các bác chỉ dùm mình chổ nào (nút nào) để down cái lisp của bác Bình !<hình>

 

2. Mình Copy --> dán theo bác Bình chỉ thì đc cái này

(defun c:gcddm ( / pl plst ssdml cdmax chcd i els ssp cdt )
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq pl (car (entsel "\n Chon duong dan"))
          plst (acet-geom-vertex-list pl ) )
 
(setq ssdml (acet-ss-to-list (ssget "f" plst (list (cons 0 "lwpolyline") (cons 62 30)) ))) 
(setq cdmax (getreal "\n Nhap cao do bat dau: ")
          chcd (getreal "\n Nhap do chenh cao giua cac duong dong muc: ")
          i 0 )
 (foreach dm ssdml
         (setq els (entget dm)
                  cdt  (+ cdmax (* i chcd))
                  els (subst (cons 38 cdt ) (assoc 38 els) els)
                  els (subst (cons 62 2) (assoc 62 els) els) )
         (entmod els)
         (command "measure" dm   200)
         (setq ssp (acet-ss-to-list (ssget "p")))
         (foreach pt ssp
               (command "insert" "cd1" (cdr (assoc 10 (entget pt))) 1 1 0 (rtos cdt 2 0) )
         )
         (setq i (1+ i)  )
)
(command "erase" pl "")
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)

Vẽ thử vài đường PL để chạy thử thì thấy nó bị lỗi này <hình>. Nhờ các bác xem hộ !

 

 

Hề hề hề,

1/- Lỗi codebox của diễn đàn, mình không biết cách sửa.

2/- Bạn đã làm đúng. Tuy nhiên đây là code cũ chưa chỉnh sửa. Bởi vậy bạn nên làm tương tự với code mới và test với bản vẽ phù hợp.

3/- Lisp đã chạy hoàn tất chứ không hề mắc mứu chi. Tuy nhiên nó chả ra cái gì vì có thể bạn đã sử dụng bản vẽ để test chưa phù hợp với lisp.

hãy lưu ý các điểm sau đây khi sử dụng lisp này:

1/- Đường dẫn phải là một LWpolyline (vẽ bằng lệnh pline) và phải cắt lần lượt các đường đồng mức theo một chiều lên hay xuống và chỉ cắt mỗi đường đồng mức tại một điểm duy nhất. Do vậy người dùng phải vẽ đường dẫn này cho phù hợp chứ không thể vẽ tùy tiện.

2/- Các đường đồng mức trên bản vẽ phải cùng một màu số 30. (màu này là do mình viết dựa trên bản vẽ của chủ thớt gửi, người dùng khác có thể thay đổi lại trong code cho phù hợp với bản vẽ sử dụng)

3/- Do sử dụng lệnh measure nên độ dài của đường đồng mức phải lớn hơn 200 là khoảng cách giữa các điểm chia trên đường đồng mức. Nếu không sẽ có lỗi. Điều này đã được khắc phục trong code mới chỉnh sửa trong bài post #14 của topic này.

4/- Khi sử dụng lsp phải chắc chắn trên bản vẽ đã có block thuộc tính mang tên CD1 có cấu trúc giống như block mẫu mình đã post trong bài #14 nói trên.

5/- Nếu lười tạo block thuộc tính cd1 có thể sử dụng code bên dưới đây với lưu ý bổ sung là các đường đồng mức phải nằm trên một trong 3 layer sau: 1, 2, 5.

 

(defun c:gcddm ( / pl plst ssdml cdmax chcd i els ssp cdt p0 ssp0)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq pl (car (entsel "\n Chon duong dan"))
          plst (acet-geom-vertex-list pl ) )
(if (not (tblsearch "block" "cd1"))
    (atbmk "cd1")
)
 
(setq ssdml (acet-ss-to-list (ssget "f" plst (list (cons 0 "lwpolyline") (cons 62 30) (cons 8 "1,2,5")))))
 
(setq cdmax (getreal "\n Nhap cao do bat dau: ")
          chcd (getreal "\n Nhap do chenh cao giua cac duong dong muc: ")
          i 0 )
 (foreach dm ssdml
         (setq els (entget dm)
                  cdt  (+ cdmax (* i chcd))
                  els (subst (cons 38 cdt ) (assoc 38 els) els)
                  els (subst (cons 62 2) (assoc 62 els) els) )
         (entmod els)
         (setq p0 (vlax-curve-getpointatdist dm 200))
         (if p0
             (progn
                   (command "measure" dm   200)
                   (setq ssp0 (ssget "p"))
                   (setq ssp (acet-ss-to-list ssp0))         
                   (foreach pt ssp
                        (command "insert" "cd1" (cdr (assoc 10 (entget pt))) 1 1 0 (rtos cdt 2 0) )
                   )
              )
              (command "insert" "cd1" (vlax-curve-getstartpoint dm) 1 1 0 (rtos cdt 2 0) )
         )
         (setq i (1+ i)  )
)
(command "erase" pl "")
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun atbmk ( bln / )
;;;(setq bln (getstring "\n Nhap ten block: "))
(if (not (tblsearch "block" bln))
(progn
       (command "attdef" "" (getstring "\n Nhap att tag: ") (getstring T "\n Nhap dong nhac: ") 
                                     (getstring "\n Nhap gia tri mac dinh: ")  "J" "mc" (setq p0 (getpoint "\n Nhap diem chuan")) 0 )
       (command "scale" (entlast) "" p0 50)
       (command "block" bln p0 (entlast) "")
)
)
)
       

<<

Filename: 228654_gcddm.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 9704
Tên lệnh: c%3Cspan+styl
Viết Lisp theo yêu cầu
Đây là lệnh CNInvis theo đúng ý bạn. Chỉ việc thêm vài dòng code so với trước. Màu đỏ là mã tôi vừa thêm.

Filename: 9704_c%3Cspan+styl.lsp
Tác giả: xaydung
Bài viết gốc: 9700
Tên lệnh: cinvis
Viết Lisp theo yêu cầu

Đây là lisp Cinvis đã có trên diễn đàn, em đang cần 1 lisp tương tự nhưng ngược 1 chút có nghĩa là khi chọn đối tượng chứa 1 màu thì các đối tượng có màu giống màu đối tượng chọn được giữ lại còn các đối tương khác thì ẩn đi. Mong các anh giúp em, thanks!!

Filename: 9700_cinvis.lsp
Tác giả: crazylisp
Bài viết gốc: 17547
Tên lệnh: csvtocad
AutoCAD với Excel

Cái này của tôi chức năng không hề kém, nhưng free. Tiết kiếm cho bạn 30$ rồi nhé!
bạn sử dụng lệnh CsvToCad:

;;;*************************** ;;; CsvToCAD - free software, written by Crazylisp. (vl-load-com) (setq CaoHang 1 RongCot 2 ) (defun StrExp (Str / ListStr) (defun StrPos (sub st / l1 l2 index) (setq index 1 l1 (Strlen sub) l2 (Strlen st) ) (while (and (<= (+ index l1 -1) l2) (/= sub (subStr st index l1))) (setq index (1+...
>>

Cái này của tôi chức năng không hề kém, nhưng free. Tiết kiếm cho bạn 30$ rồi nhé!
bạn sử dụng lệnh CsvToCad:

;;;*************************** ;;; CsvToCAD - free software, written by Crazylisp. (vl-load-com) (setq CaoHang 1 RongCot 2 ) (defun StrExp (Str / ListStr) (defun StrPos (sub st / l1 l2 index) (setq index 1 l1 (Strlen sub) l2 (Strlen st) ) (while (and (<= (+ index l1 -1) l2) (/= sub (subStr st index l1))) (setq index (1+ index)) ) (if (= sub (subStr st index l1)) index nil ) ) (if (not (StrPos "," Str)) (setq Str (Strcat Str ",")) ) (while (StrPos "," Str) (setq ListStr (append ListStr (list (subStr Str 1 (1- (StrPos "," Str)))) ) Str (subStr Str (1+ (StrPos "," Str))) ) ) (setq ListStr (append ListStr (list Str))) ) (defun c:CsvToCad(/ cdata data) (setq filecsv (getfiled "file CSV: " "" "CSV" 0) f (open filecsv "r") SoCot 0 ) (while (setq Str (read-line f)) (setq cdata (StrExp Str) SoCot (max SoCot (length cdata)) data (append data (list cdata)) ) ) (setq SoHang (length data)) (close f) (setq CTBL (vla-AddTable (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)) ) (vlax-3d-point (getpoint "\ndiem chen bang: ")) (+ 1 SoHang) SoCot CaoHang RongCot ) ) (vla-setText CTBL 0 0 "Crazylisp table") (setq x 0) (foreach Hang Data (setq y 0 x (+ x 1) ) (foreach Cell Hang (vla-setText CTBL x y Cell) (setq y (+ y 1)) ) ) (princ) ) ;;;***************************
<<

Filename: 17547_csvtocad.lsp
Tác giả: duy782006
Bài viết gốc: 228801
Tên lệnh: xml
Cần giúp lisp hiện mã màu plot style

Mình đang dùng cad 2013 nhưng nó cũng k hiện rõ màu số bao nhiêu mà chỉ hiện là bylayer thôi. mún biết màu số bao nhiêu phải bật LA lên mới thấy dc.

(Defun c:XML ( )

                   
(princ "\nChon doi tuong muon xem thuoc tinh")
(setq doituong1 (entsel))
(while
(null doituong1)
(princ "\nChon doi tuong...
>>

Mình đang dùng cad 2013 nhưng nó cũng k hiện rõ màu số bao nhiêu mà chỉ hiện là bylayer thôi. mún biết màu số bao nhiêu phải bật LA lên mới thấy dc.

(Defun c:XML ( )

                   
(princ "\nChon doi tuong muon xem thuoc tinh")
(setq doituong1 (entsel))
(while
(null doituong1)
(princ "\nChon doi tuong muon xem thuoc tinh")
(setq doituong1 (entsel))
)

(setq doituong (car doituong1))
(setq doituong (entget doituong))


 (setq LAYERDOITUONG (cdr (assoc 8 doituong)))
 (setq COLORDOITUONG (cdr (assoc 62 doituong)))

  (setq TENLOP (TBLOBJNAME "LAYER" LAYERDOITUONG))
  (setq DOCLOP (entget TENLOP))
  (setq MAULOP (cdr (assoc 62 DOCLOP)))

 (Cond
  ((= COLORDOITUONG nill) 
  (setq COLORDOITUONG (strcat "BYLAYER <" (itoa MAULOP) ">"))
  )
  ((/= COLORDOITUONG nill) 
  (setq COLORDOITUONG (itoa COLORDOITUONG))
  )
  )

(alert (strcat 
    "\n -LAYER               : " LAYERDOITUONG
   "\n -COLOR              : " COLORDOITUONG))

(PRINC))

<<

Filename: 228801_xml.lsp
Tác giả: phamthe
Bài viết gốc: 228239
Tên lệnh: ee
Xin lisp giống lệnh trim

đây là đoạn code em đã copy ở #16.
 đoạn hỏi: Phia cat va xoa bo : anh có thể chọn bằng cách pick về phía cần cắt xóa

trong hoặc ngoài được không ạ! cảm ơn anh
 


Filename: 228239_ee.lsp
Tác giả: npham
Bài viết gốc: 169194
Tên lệnh: demo
Lisp cộng trừ text độ, phút, giây...


Bạn xem cái này vừa ý không.
Format:
Space: 123 00 00
Dot: 123.0000
Comma: 123,0000
Dash: 123-00-00
Degress:123d00'00"

Toán tử: +, -


Nếu bỏ qua thì format và toán tử sẽ lấy lần nhập trước. Cái này có kiểm tra phím nhập, do đó khi nhập toán tử bạn phải nhập đúng ký tự +, -



(defun c:demo (/ e e1 e2 key #func)
>>


Bạn xem cái này vừa ý không.
Format:
Space: 123 00 00
Dot: 123.0000
Comma: 123,0000
Dash: 123-00-00
Degress:123d00'00"

Toán tử: +, -


Nếu bỏ qua thì format và toán tử sẽ lấy lần nhập trước. Cái này có kiểm tra phím nhập, do đó khi nhập toán tử bạn phải nhập đúng ký tự +, -



(defun c:demo (/ e e1 e2 key #func)
(defun s2d (str / ret)
(setq ret
(vl-list->string
(vl-remove-if
'(lambda (x) (or (< x 48) (> x 57)))
(reverse (vl-string->list str))
)
)
)
(angtof
(vl-list->string
(reverse
(vl-string->list
(strcat "\"" (substr ret 1 2) "'" (substr ret 3 2) "d" (substr ret 5))
)
)
)
)
)
(defun format (value fm / lst mm ss)
(setq ss (vl-list->string (cdr (member 39 (vl-string->list value)))))
(if (= (strlen ss) 2) (setq value (strcat (substr value 1 (- (strlen value) 2)) "0" ss)))
(setq mm (vl-list->string (cdr (member 100 (vl-string->list value)))))
(if (= (strlen mm) 5) (setq value (strcat (substr value 1 (- (strlen value) 5)) "0" mm)))

(setq lst '(("Space" . 32)
("dOt" . 46)
("Comma" . 44)
("dAsh" . 45)
)
)
(setq fm (cdr (assoc fm lst)))
(cond
((member fm '(32 45))
(vl-list->string
(subst fm
100
(subst fm 39 (vl-remove 34 (vl-string->list value)))
)
))
((member fm '(44 46))
(vl-list->string
(subst fm
100
(vl-remove 39 (vl-remove 34 (vl-string->list value)))
)
))
(T value)
)
)

(if (null func) (setq func +))
(if (null fm) (setq fm "Degress"))
(setq key T)
(while (not (member key '("-" "+" nil)))
(setq #func (chr (cadr (reverse (vl-string->list (vl-princ-to-string func))))))
(initget "Degress Space dOt Comma dAsh + -")
(setq key (getkword (strcat "\nEnter an option <Default: "#func"/"fm">:")))
(cond
((member key '("-" "+")) (setq func (eval (read key))) nil)
(T (setq fm key))
)
)

(while
(and

(setq e1 (car (entsel "\nEnter Text 1 <Exit>:")))
(setq e1 (s2d (cdr (assoc 1 (setq e (entget e1))))))
(setq e2 (car (entsel (strcat "\nEnter Text 2 <Exit>:"))))
(setq e2 (s2d (cdr (assoc 1 (entget e2)))))
(setq p (Getpoint "\nDiem chen ket qua <exit>:"))
)
(setq e (subst (cons 10 p) (assoc 10 e) e))
(setq e (subst (cons 1 (format (angtos (func e1 e2) 1 4) fm)) (assoc 1 e) e))
(entmake e)
)
(princ)
)

<<

Filename: 169194_demo.lsp
Tác giả: duy782006
Bài viết gốc: 229017
Tên lệnh: chuyenlay cvml
Will I be paid weekly or monthly? generic nizoral cream If a patient presents with these problems, it is often these that are treated, while the underlying alcohol problem is missed.

Filename: 229017_chuyenlay_cvml.lsp
Tác giả: hiepttr
Bài viết gốc: 228597
Tên lệnh: gcddm
Đưa bình đồ dạng đường đồng mức về bình đồ dạng cao độ

Giờ mới rảnh, lại tò mò!

1. Các bác chỉ dùm mình chổ nào (nút nào) để down cái lisp của bác Bình !<hình>

80156_tomo2.jpg

2. Mình Copy --> dán theo bác Bình chỉ thì đc cái này

(defun c:gcddm ( / pl plst ssdml cdmax chcd i els ssp cdt )
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq...
>>

Giờ mới rảnh, lại tò mò!

1. Các bác chỉ dùm mình chổ nào (nút nào) để down cái lisp của bác Bình !<hình>

80156_tomo2.jpg

2. Mình Copy --> dán theo bác Bình chỉ thì đc cái này

(defun c:gcddm ( / pl plst ssdml cdmax chcd i els ssp cdt )
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq pl (car (entsel "\n Chon duong dan"))
          plst (acet-geom-vertex-list pl ) )
 
(setq ssdml (acet-ss-to-list (ssget "f" plst (list (cons 0 "lwpolyline") (cons 62 30)) ))) 
(setq cdmax (getreal "\n Nhap cao do bat dau: ")
          chcd (getreal "\n Nhap do chenh cao giua cac duong dong muc: ")
          i 0 )
 (foreach dm ssdml
         (setq els (entget dm)
                  cdt  (+ cdmax (* i chcd))
                  els (subst (cons 38 cdt ) (assoc 38 els) els)
                  els (subst (cons 62 2) (assoc 62 els) els) )
         (entmod els)
         (command "measure" dm   200)
         (setq ssp (acet-ss-to-list (ssget "p")))
         (foreach pt ssp
               (command "insert" "cd1" (cdr (assoc 10 (entget pt))) 1 1 0 (rtos cdt 2 0) )
         )
         (setq i (1+ i)  )
)
(command "erase" pl "")
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)

Vẽ thử vài đường PL để chạy thử thì thấy nó bị lỗi này <hình>. Nhờ các bác xem hộ !

80156_tomo.jpg

 




<<

Filename: 228597_gcddm.lsp
Tác giả: 3d.decor
Bài viết gốc: 151036
Tên lệnh: clear
Viết lisp theo yêu cầu [phần 2]
vẫn khônh được bác pham thanh binh a
bác thử sửa từ lisp này xem
nhưng trừ layer: cut,glass,hide,hatch,funitures,tree,text,center
lisp này không biết pro nào viết tẩy cả block và dim cực kỳ pro
mong pro nào rảnh giúp đỡ


sory pro ketxu
mong pro giúp amater cái
chuyển tất cả nhưng trừ lại một số layer: cut,glass,hide,hatch,funitures,tree,text,center
không cần chuyển dim,...
>>
vẫn khônh được bác pham thanh binh a
bác thử sửa từ lisp này xem
nhưng trừ layer: cut,glass,hide,hatch,funitures,tree,text,center
lisp này không biết pro nào viết tẩy cả block và dim cực kỳ pro
mong pro nào rảnh giúp đỡ


sory pro ketxu
mong pro giúp amater cái
chuyển tất cả nhưng trừ lại một số layer: cut,glass,hide,hatch,funitures,tree,text,center
không cần chuyển dim, hoặc chuyển cả dim ( cái này thì sao cũng được )
thank you
<<

Filename: 151036_clear.lsp
Tác giả: KangKung
Bài viết gốc: 229014
Tên lệnh: kk
Vấn đề về màu layer

 

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...

>>

 

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)
  )

<<

Filename: 229014_kk.lsp
Tác giả: luiz
Bài viết gốc: 229035
Tên lệnh: toado td
các pro giúp mình sửa lisp này với

mình có lisp xuất tọa độ này,nhưng tọa độ xuất ra là ở 1 block hơi xấu. mình muốn sửa việc xuất các thông số X, Y, tên nút ra block này, Cảm ơn mọi người http://www.cadviet.com/upfiles/3/117742_cm_1.dwg


;************************* Ch­¬ng tr×nh chÝnh
(DEFUN C:TOADO()
    (setq os (getvar...
>>

mình có lisp xuất tọa độ này,nhưng tọa độ xuất ra là ở 1 block hơi xấu. mình muốn sửa việc xuất các thông số X, Y, tên nút ra block này, Cảm ơn mọi người http://www.cadviet.com/upfiles/3/117742_cm_1.dwg


;************************* Ch­¬ng tr×nh chÝnh
(DEFUN C:TOADO()
    (setq os (getvar "OSMODE"))
    (command "UNDO" "G")
    ; T¹o kiÓu ch÷ míi
    (setq cst (getvar "TEXTSTYLE"))
    (command "STYLE" "VNARIALNARROW" ".VNARIAL NARROW" "" "" "" "" "")
    ; ThiÕt lËp kiÓu ghi kÝch th­íc
    (setvar "DIMASZ" 4);kÝch th­íc mòi tªn
    (setvar "DIMTXT" 4); kichs th­íc ch÷
    (setvar "DIMTAD" 0); ch÷ c©n gi÷a
    ; T×m khèi BANGTOADO (nÕu ch­a cã th× t¹o ra)
    (if (not (tblsearch "BLOCK" "BANGTOADO"))
       (progn
        (setvar "OSMODE" 0)
        (setq cla (getvar "CLAYER") cec (getvar "CECOLOR"))
        (setvar "CLAYER" "0")
        (setvar "CECOLOR" "BYBLOCK")
        (setq ssline (ssadd))
        (command "PLINE" '(0 0) '(30.5 0) '(30.5 13.5) '(0 13.5) "c")
        (ssadd (entlast) ssline)
        (command "LINE" '(7.5 0) '(7.5 13.5) "")
        (ssadd (entlast) ssline)
        (command "LINE" '(7.5 6.75) '(30.5 6.75) "")
        (ssadd (entlast) ssline)
        (command "CIRCLE" '(3.75 6.75) 3.5)
        (ssadd (entlast) ssline)
        (command "ATTDEF" "" "SH" "Sè hiÖu" "" "Middle" '(3.75 6.75) 4 0)
        (setq ssatt_sh (ssadd))(ssadd (entlast) ssatt_sh)
        (command "ATTDEF" "" "XXXXXX.XXXX" "To¹ ®é X" "" '(8.1 8.1) 4 0)
        (setq ssatt_xx (ssadd))(ssadd (entlast) ssatt_xx)
        (command "ATTDEF" "" "YYYYYY.YYYY" "To¹ ®é Y" "" '(8.1 1.1) 4 0)
        (setq ssatt_yy (ssadd))(ssadd (entlast) ssatt_yy)
        (command "BLOCK" "BANGTOADO" '(0 0) ssline ssatt_sh ssatt_xx ssatt_yy "")
        (setvar "CLAYER" cla)(setvar "CECOLOR" cec)
       );progn
    );if
    (if (not tenmocChinh)
        (setq tenmocChinh "1")
    );if
    (if (not tenmocPhu)
        (setq tenmocPhu "")
    );if
    (if (not tenmoc)
        (setq tenmoc (strcat tenmocChinh tenmocPhu))
    )
    (if (not sle)
        (setq sle 2)
    );if
    (if (not ShowMode)(setq ShowMode "X"))
    (setq loop T)
    (while loop
        (setvar "OSMODE" os)
        (initget "M T X L"); Mèc - Th­êng - XÞn - Sè lÎ
        (setq mark (getpoint (strcat "\nsè LÎ <" (itoa sle) ">/H×nh thøc (Th­êng/XÞn) <" ShowMode ">/tªn Mèc <" tenmoc ">/<ChØ ®iÓm>: ")))
        (cond
            ((= mark "M")
                (setq tenmoc0 (getstring (strcat "\nTªn Mèc míi (theo d¹ng : 1, 1a, A, A1...) <" tenmoc ">: ")))
                (if (/= tenmoc0 "")
                   (progn
                    ; ph©n tÝch tªn mèc ®Ó nhËn biÕt chÝnh-phô
                    (tachMoc tenmoc0)
                    (if (or (>= (ascii tenmocChinh) 57)(<= (ascii tenmocChinh) 48)); mèc chÝnh lµ ch÷
                        (setq tenmocChinh (strcase tenmocChinh))
                    );if
                    (setq tenmoc (strcat tenmocChinh tenmocPhu))
                   );progn
                );if
            )
            ((= mark "T")
                (setq ShowMode "T")
            )
            ((= mark "X")
                (setq ShowMode "X")
            )
            ((= mark "L")
                (setq sle0 (getint (strcat "\nSè ch÷ sè thËp ph©n (Tèi ®a=2; tèi thiÓu=0) <" (itoa sle) ">: ")))
                (if sle0
                   (progn
                    (if (< sle0 0)(setq sle0 0))
                    (if (> sle0 2)(setq sle0 2))
                    (setq sle sle0)
                   );progn
                );if
            )
            (T
                (if mark
                   (progn
                    (cond
                        ((= ShowMode "T");th­êng
                            (setq toadoX (cadr (trans mark 1 0)))
                            (setq toadoY (car (trans mark 1 0)))
                            (setq p (getpoint mark "\nVÞ trÝ: "))
                            (setvar "OSMODE" 0)
                            (command "LEADER" mark p "" (rtos toadoX 2 sle) (rtos toadoY 2 sle) "")
                            ;(command "PLINE" mark p "@11,0" "")
                            ;(command "TEXT" (list (+ (car p) 0.5) (+ (cadr p) 0.5)) "" "0" (rtos toadoX 2 4))
                            ;(command "TEXT" "TL" (list (+ (car p) 0.5) (- (cadr p) 0.5)) "" "0" (rtos toadoY 2 4))
                        )
                        ((= ShowMode "X");XÞn
                            (setq toadoX (cadr (trans mark 1 0)))
                            (setq toadoY (car (trans mark 1 0)))
                            (setq p (getpoint mark "\nVÞ trÝ: "))
                            (setvar "OSMODE" 0)
                            (command "LEADER" mark p "" "" "Block" "BANGTOADO" p 1 1 0 tenmoc (rtos toadoX 2 sle) (rtos toadoY 2 sle))
                            ; t¨ng gi¸ trÞ mèc
                            (tachmoc tenmoc)
                            (if (= tenmocPhu ""); kh«ng cã mèc phô
                                (if (and (<= (ascii tenmocChinh) 57)(>= (ascii tenmocChinh) 48)); mèc chÝnh lµ sè
                                    (setq tenmoc (itoa (+ (atoi tenmocChinh) 1)))
                                   (progn; else mèc chÝnh lµ ch÷
                                    (setq tenmocASCII (+ (ascii tenmocChinh) 1))
                                    (while (or (= (strcase (chr tenmocASCII)) "I")(= (strcase (chr tenmocASCII)) "O")
                                            (= (strcase (chr tenmocASCII)) "V")(= (strcase (chr tenmocASCII)) "X")
                                            (= (strcase (chr tenmocASCII)) "J"))
                                        (setq tenmocASCII (+ tenmocASCII 1))
                                    );while
                                    (setq tenmoc (chr tenmocASCII))
                                   );progn else
                                );if
                                ;else cã mèc phô
                                (if (and (<= (ascii tenmocChinh) 57)(>= (ascii tenmocChinh) 48)); mèc chÝnh lµ sè (mèc phô lµ ch÷)
                                   (progn
                                    (setq tenmocASCII (+ (ascii tenmocPhu) 1))
                                    (while (or (= (strcase (chr tenmocASCII)) "I")(= (strcase (chr tenmocASCII)) "O")
                                            (= (strcase (chr tenmocASCII)) "V")(= (strcase (chr tenmocASCII)) "X")
                                            (= (strcase (chr tenmocASCII)) "J"))
                                        (setq tenmocASCII (+ tenmocASCII 1))
                                    );while
                                    (setq tenmocPhu (chr tenmocASCII))
                                    (setq tenmoc (strcat tenmocChinh tenmocPhu))
                                   );progn
                                   (progn; else mèc chÝnh lµ ch÷ (mèc phô lµ sè)
                                    (setq tenmocPhu (itoa (+ (atoi tenmocPhu) 1)))
                                    (setq tenmoc (strcat tenmocChinh tenmocPhu))
                                   );progn
                                );if
                            );if
                        )
                    );cond
                    (setvar "OSMODE" os)
                   );progn
                    (setq loop nil);else
                );if
            )
        )    ; end of cond
    )    ; end of while
    (setvar "TEXTSTYLE" cst)
)    ; end of program
 
(Defun C:TD()
    (c:toado)
)
 
;******************************* Thèng kª *****************************************
 
(defun C:TK()
    (command "UNDO" "G")
    (setq tableStatus "")
    (setq btk (ssget "X" '((2 . "BANGTHONGKE"))))
    (if btk
        (setq TableStatus "On Board")
       (progn;else
        (if (tblsearch "BLOCK" "BANGTHONGKE")
            (setq TableStatus "Hiding Block")
            (setq TableStatus "Doesn't Exist")
        );if
       );progn else
    );if
    (if (or (= TableStatus "Doesn't Exist") (= TableStatus "Hiding Block"))
        (setq sp (getpoint "\nX¸c ®Þnh vÞ trÝ gãc trªn-tr¸i cña b¶ng: "))
       (progn ;else (On Board)
        (setq btk_name (ssname btk 0))
        (setq btk_ent (entget btk_name))
        (setq sp (cdr(assoc 10 btk_ent)))
       );progn else
    );if
    (setq luuChu '() luuSo '())
    (setq bang (ssget "X" '((2 . "BANGTOADO"))))
    (if bang
       (progn
        (setq i 1 chu_i 1 so_i 1)
        (repeat (sslength bang)
            (setq b_i (ssname bang (- i 1)))
                ; doc doi tuong thuoc tinh SH
            (setq bi_sh (entnext b_i))
            (setq bi_sh_ent (entget bi_sh))
            (setq sh (cdr(assoc 1 bi_sh_ent)))
                ; ®äc gi¸ trÞ toa ®é X
            (setq bi_X (entnext bi_sh))
            (setq bi_X_ent (entget bi_X))
            (setq X (cdr(assoc 1 bi_X_ent)))    
                ; ®äc gi¸ trÞ toa ®é Y
            (setq bi_Y (entnext bi_X))
            (setq bi_Y_ent (entget bi_Y))
            (setq Y (cdr(assoc 1 bi_Y_ent)))    
                ; cap nhat vao bang luu
            (tachMoc sh)
            (if (and (<= (ascii tenmocChinh) 57)(>= (ascii tenmocChinh) 48)); mèc chÝnh lµ sè
               (progn
                (setq luuSo (cons (list so_i sh X Y) luuSo))
                (setq so_i (+ so_i 1))
               );progn
               (progn ; else mèc chÝnh lµ ch÷
                (setq luuChu (cons (list chu_i sh X Y) luuChu))
                (setq chu_i (+ chu_i 1))
               )
            );if
            (setq i (+ i 1))
        );repeat
        ; s¾p xÕp theo thø tù t¨ng dÇn cña sè hiÖu (SH) trong danh s¸ch luuChu
        (setq i 1)
        (while (<= i (- (length luuChu) 1))
            (setq j (+ i 1))
            (while (<= j (length luuChu))
                (setq SH_tmpi (cadr (assoc i luuChu)))
                (tachMoc SH_tmpi)
                (setq SHi (ascii tenmocChinh))
                (setq SH_tmpj (cadr (assoc j luuChu)))
                (tachMoc SH_tmpj)
                (setq SHj (ascii tenmocChinh))
                (cond
                    ((< SHj SHi); ch÷ sau cã m·  ascii nhá h¬n sè tr­íc th× ®æi chç
                        (setq Xi (caddr (assoc i luuChu)))
                        (setq Yi (cadddr (assoc i luuChu)))
                        (setq Xj (caddr (assoc j luuChu)))
                        (setq Yj (cadddr (assoc j luuChu)))
                        (setq luuChu (subst (list i SH_tmpj Xj Yj) (assoc i luuChu) luuChu))
                        (setq luuChu (subst (list j SH_tmpi Xi Yi) (assoc j luuChu) luuChu))
                    )
                    ((= SHj SHi); cïng tªn mèc - > kiÓm tra mèc phô
                        (tachMoc SH_tmpi)
                        (setq ChisoPhu_i tenmocPhu)
                        (tachMoc SH_tmpj)
                        (setq ChisoPhu_j tenmocPhu)
                        (if (< ChisoPhu_j ChisoPhu_i);sè sau nhá h¬n sè tr­íc th× ®æi chç
                           (progn
                            (setq Xi (caddr (assoc i luuChu)))
                            (setq Yi (cadddr (assoc i luuChu)))
                            (setq Xj (caddr (assoc j luuChu)))
                            (setq Yj (cadddr (assoc j luuChu)))
                            (setq luuChu (subst (list i SH_tmpj Xj Yj) (assoc i luuChu) luuChu))
                            (setq luuChu (subst (list j SH_tmpi Xi Yi) (assoc j luuChu) luuChu))
                           );progn
                        );if
                    )
                );cond
                (setq j (+ j 1))
            );while j
            (setq i (+ i 1))
        );while i
        ; s¾p xÕp theo thø tù t¨ng dÇn cña sè hiÖu (SH) trong danh s¸ch luuSo
        (setq i 1)
        (while (<= i (- (length luuSo) 1))
            (setq j (+ i 1))
            (while (<= j (length luuSo))
                (setq SH_tmpi (cadr (assoc i luuSo)))
                (tachMoc SH_tmpi)
                (setq SHi (atoi tenmocChinh))
                (setq SH_tmpj (cadr (assoc j luuSo)))
                (tachMoc SH_tmpj)
                (setq SHj (atoi tenmocChinh))
                (cond
                    ((< SHj SHi); sè sau nhá h¬n sè tr­íc th× ®æi chç
                        (setq Xi (caddr (assoc i luuSo)))
                        (setq Yi (cadddr (assoc i luuSo)))
                        (setq Xj (caddr (assoc j luuSo)))
                        (setq Yj (cadddr (assoc j luuSo)))
                        (setq luuSo (subst (list i SH_tmpj Xj Yj) (assoc i luuSo) luuSo))
                        (setq luuSo (subst (list j SH_tmpi Xi Yi) (assoc j luuSo) luuSo))
                    )
                    ((= SHj SHi); cïng tªn mèc - > kiÓm tra mèc phô
                        (tachMoc SH_tmpi)
                        (setq ChisoPhu_i (ascii tenmocPhu))
                        (tachMoc SH_tmpj)
                        (setq ChisoPhu_j (ascii tenmocPhu))
                        (if (< ChisoPhu_j ChisoPhu_i);ký tù sau cã m·  ascii nhá h¬n sè tr­íc th× ®æi chç
                           (progn
                            (setq Xi (caddr (assoc i luuSo)))
                            (setq Yi (cadddr (assoc i luuSo)))
                            (setq Xj (caddr (assoc j luuSo)))
                            (setq Yj (cadddr (assoc j luuSo)))
                            (setq luuSo (subst (list i SH_tmpj Xj Yj) (assoc i luuSo) luuSo))
                            (setq luuSo (subst (list j SH_tmpi Xi Yi) (assoc j luuSo) luuSo))
                           );progn
                        );if
                    )
                );cond
                (setq j (+ j 1))
            );while j
            (setq i (+ i 1))
        );while i
        ; bæ sung tiªu ®Ò vµo danh s¸ch
        (setq luuChu (cons (list 0 "Mèc" "X" "Y") luuChu))
 
        ; KÎ b¶ng
        (setq os (getvar "OSMODE"))
        (setvar "OSMODE" 0)
        (setq n (length luuChu) m (length luuSo))
        (setq i 0 dem 0 test nil kc 15 objs (ssadd))
        (repeat (+ n m)
            (if (and (< dem n) (not test))
                (setq luu luuChu test nil)
               (progn
                (setq luu luuSo)
                (if (not test)
                    (setq test T dem 1)
                );if
               );progn
            );if
            ; ghi so hieu
            (setq start (list (car sp) (- (cadr sp) (* (getvar "TEXTSIZE") i 1.8))))
            (command "TEXT" "M" start "" "" (cadr (assoc dem luu)))
            (ssadd (entlast) objs)
            ; ghi X
            (setq start (list (+ (car start) (/ kc 1.5)) (cadr start)))
            (command "TEXT" "M" start "" "" (caddr (assoc dem luu)))
            (ssadd (entlast) objs)
            ; ghi Y
            (setq start (list (+ (car start) kc) (cadr start)))
            (command "TEXT" "M" start "" "" (cadddr (assoc dem luu)))
            (ssadd (entlast) objs)
            ; KÎ ®­êng n»m ngang phÝa trªn
            (command "LINE" (list (- (car sp) (/ kc 5)) (+ (cadr start) (* (getvar "TEXTSIZE") 0.9)))
                    "@35,0" "")
            (ssadd (entlast) objs)
            (setq i (+ i 1) dem (+ dem 1))
        );repeat
        ;vex ddwowngf ker cuoois cungf
        (command "LINE" (list (- (car sp) (/ kc 5)) (- (cadr start) (* (getvar "TEXTSIZE") 0.9)))
                    "@35,0" "")
        (ssadd (entlast) objs)
        ;VÏ ®­êng däc
        (command "LINE" (list (- (car sp) (/ kc 5)) (+ (cadr sp) (* (getvar "TEXTSIZE") 0.9)))
                (list (- (car sp) (/ kc 5)) (- (cadr start) (* (getvar "TEXTSIZE") 0.9)))  "")
        (ssadd (entlast) objs)
        (command "LINE" (list (- (car sp) (/ kc 5) -35) (+ (cadr sp) (* (getvar "TEXTSIZE") 0.9)))
                (list (- (car sp) (/ kc 5) -35) (- (cadr start) (* (getvar "TEXTSIZE") 0.9)))  "")
        (ssadd (entlast) objs)
        (cond
            ((= TableStatus "On Board")
                (COMMAND "BLOCK" "BANGTHONGKE" "Y" sp objs "")
            )
            ((= TableStatus "Hiding Block")
                (COMMAND "BLOCK" "BANGTHONGKE" "Y" sp objs "")
                (command "INSERT" "BANGTHONGKE" sp "1" "1" "0")
            )
            ((= TableStatus "Doesn't Exist")
                (COMMAND "BLOCK" "BANGTHONGKE" sp objs "")
                (command "INSERT" "BANGTHONGKE" sp "1" "1" "0")
            )
        );cond
        (setvar "OSMODE" os)
       );progn
    );if
    (command "UNDO" "E")
)

<<

Filename: 229035_toado_td.lsp

Trang 121/313

121