Jump to content
InfoFile
Tác giả: dinhthang8709
Bài viết gốc: 414896
Tên lệnh: bao
Viết Lisp Tạo Đường Bao

 

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

Bổ sung thêm...

>>

 

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

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

Quick code

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

Đúng ý mình rồi. Cảm ơn bạn nhiều nhé.!


<<

Filename: 414896_bao.lsp
Tác giả: duy782006
Bài viết gốc: 10923
Tên lệnh: lr
Dùng fím tắt để gọi 1 layer
Sao mà tùm lum.Mình thiết nghĩ dùng chuôt click còn nhanh hơn.

(defun C:lr (/ N)
 (setq N (getint "\nnhap thu tu layer can dung:"))
 (command ".clayer" N "")
...
>>
Sao mà tùm lum.Mình thiết nghĩ dùng chuôt click còn nhanh hơn.

(defun C:lr (/ N)
 (setq N (getint "\nnhap thu tu layer can dung:"))
 (command ".clayer" N "")
 )

 

 

Tùm lum nghĩa là nói ở nhiều nơi rồi.

Để giúp cho việc gỏ 1 chử thì chọn 1 layer thì dùng lisp sau nhưng phài tự gia công nhé:

 

(DEFUN C:tenlenh ()

(command "layer" "s" "tenlayer" "")

(princ)

)

 

Trong đó :

tenlenh là chử mà bạn muốn gỏ

tenlayer là ten chính xác của layer bạn muốn chuyển thành layer hiện hành

 

Vì nó phụ thuộc vào các layer có sẳn trong bản vẽ của bạn nên không phổ biến cho nhiều người là vì vậy


<<

Filename: 10923_lr.lsp
Tác giả: auduongphuc
Bài viết gốc: 68521
Tên lệnh: dcd
Nhờ các bác viết dùm Lisp đánh cao độ
Cám ơn anh giabach.

Em đang viết và cố gắng hoàn thành xong code này để giúp cho bạn auduongphuc.

Có gì trở ngại mong anh gia bách và mọi người hỗ trợ...

>>
Cám ơn anh giabach.

Em đang viết và cố gắng hoàn thành xong code này để giúp cho bạn auduongphuc.

Có gì trở ngại mong anh gia bách và mọi người hỗ trợ thêm.

Chào anh. Chúc anh thật nhiều sức khoẻ.

-----------

Tue_NV đã hoàn thành xong code này

Bạn auduongphuc chạy thử xem :

Chỉ Có 2 yêu cầu nhỏ khi chạy code :

1. Lisp chấp nhận bất cứ Block cao độ nào miễn là Block đó có 1 Atrtibute và Block đó phải có trên CAD để mà ta Pick chon Block mau

2. Điểm chèn Block đó nên nằm ngay cos cao độ chèn

Mong bạn auduongphuc hiểu

(defun c:dcd(/ tlv blm blname dmo cdm cd dm cdmi dmoc)
(setvar "attreq" 1)
(setvar "cmdecho" 0)
(setq oldim (getvar "DimZin"))
(setvar "Dimzin" 0)
(setq tlv (/ 1 (getreal "\n Nhap ti le ve : 1/")))
(setq blm (entget(car(entsel "\n Pick chon Block mau :"))))
(setq blname (cdr(assoc 2 blm)))
(setq TLX (cdr(assoc 41 blm)))
(setq TLY (cdr(assoc 42 blm)))
(setq dmo (getpoint "\n Pick diem moc : "))

(setq cdm (getreal "\n Nhap cao do cua diem moc :"))
(if (= cdm 0) (setq cd (strcat "%%p" (rtos cdm 2 3))))
(if (> cdm 0) (setq cd (strcat "+" (rtos cdm 2 3))))
(if (< cdm 0) (setq cd (rtos cdm 2 3)))
(command "insert" blname dmo TLX TLY "0" cd)
(setq dmoc dmo)
(while (setq dm (getpoint dmoc "\n Pick diem tiep theo :"))
(setq cdmi (* (- (cadr dm) cdm (cadr dmo)) tlv))
(if (= cdmi 0) (setq cdi (strcat "%%p" (rtos cdmi 2 3))))
(if (> cdmi 0) (setq cdi (strcat "+" (rtos cdmi 2 3))))
(if (< cdmi 0) (setq cdi (rtos cdmi 2 3)))
(command "insert" blname dm TLX TLY "0" cdi)
(setq dmoc dm)
)

(setvar "Dimzin" oldim)
(princ)
)

Cảm ơn bác Tue_NV rất nhiều, Lisp của bác rất đúng với ý em (đến 99%), nhưng còn bị 1 vấn đề rất nhỏ nữa, không biết là do em kém hay bác nhầm (hy vọng là do em) mà cốt cao độ bị nhân lên tới 10 lần. Khi cốt ở 0.000 thì ok, nhưng khi mình lên cao hơn hoặc xuống thấp hơn thì đúng số nhưng bị x10 lần, mong bác chỉnh sửa lại dùm em hoặc bác chỉ bảo dùm em. Thank's bác. em xin gửi kèm theo file để dễ hình dung http://www.cadviet.com/upfiles/2/cot_cao_do.dwg


<<

Filename: 68521_dcd.lsp
Tác giả: ngocdao tran
Bài viết gốc: 390929
Tên lệnh: cdx
Lisp điền cao độ bị lỗi!!!

 

- ngón này nhoc ko rành lắm, nhoc thử sữa lại theo ý bạn, bạn xem có đúng ko ^^, nhoc chỉ sợ lượt bớt nhiều quá làm...

>>

 

- ngón này nhoc ko rành lắm, nhoc thử sữa lại theo ý bạn, bạn xem có đúng ko ^^, nhoc chỉ sợ lượt bớt nhiều quá làm sai kết quả ^^

(defun DXFcn (code elist) (cdr (assoc code elist)))
;============================================================
(prompt "\n - GHI CAO DO DIEM TREN TRAC NGANG by Thaistreetz - huuthais@yahoo.com\n")
;============================================================
(defun c:Cdx (/ DZ pt  ptside ang OT sc1 scale tx ty tx1 ty1 y H0) ; 
(command "Undo" "BEGIN")
(if (= tx nil) 
	(setq tx 1))
(if (= ty nil) 
	(setq ty 1))
	(setq 		  tx1 (getreal (strcat "\nTy le theo phuong X <1/"(rtos tx 2 2)">: 1/")) 
		  ty1 (getreal (strcat "\nTy le theo phuong Y <1/"(rtos ty 2 2)">: 1/"))
	)
(if tx1 (setq tx tx1))
(if ty1 (setq ty ty1))
(setq ATLAST (getvar "Attreq"))
(setq CMLAST (getvar "cmdecho"))
(setq OSLAST (getvar "OSMODE"))
(setq DZ (getvar "DIMZIN"))
(setq OT (getvar "ORTHOMODE"))
(setvar "ORTHOMODE" 0)
(setvar "cmdecho" 0)
(command "osmode" 99)
(setq pt0 (osnap (getpoint "Diem tim TN tu nhien") "end")) (print)
(setq x0 (car pt0) y0 (cadr pt0))
;(setvar 'osmode 0)
(setq ed (entget (car (entsel "\nChon cao do tim: "))))
(setq H0 (read (DXFcn 1 ed))) 
(While (and (setq pt (getpoint "\nChon diem chuan : ")) (setq doitt (car (entsel "\nChon text de chinh sua: "))))
(Progn
	(setq y (- (cadr pt) y0 (- H0)))
(cond 
	((> y 0) (entmod (subst (cons 1 (strcat "+" (rtos (* y ty) 2 2))) (assoc 1 (entget doitt)) (entget doitt))))
	((< y 0) (entmod (subst (cons 1 (rtos (* y ty) 2 2)) (assoc 1 (entget doitt)) (entget doitt)))) 
	((= y 0) (entmod (subst (cons 1 "%%p0.00") (assoc 1 (entget doitt)) (entget doitt))))
)

);progn
);while 
(setvar "OSMODE" OSLAST)(setvar "ORTHOMODE" OT)(setvar "cmdecho" CMLAST)
(prompt "\n by Thaistreetz - huuthais@yahoo.com\n")
(command "Undo" "End")
(princ)
);end

1/ (setq ed (entget (car (entsel "\nChon cao do tim: "))))

      (setq cdd (atof (cdr(assoc 1 (entget(car(entsel "\n Pick chon Text cao do dau :")))))))

cho hỏi 2 câu lệnh này khác nhau như thế nào. không hiểu sao những lisp mình tải về xem thì đến bước chọn text cao độ ở câu lệnh 1 cho kết quả toàn bằng 0 hay trật lất còn câu 2 thì đúng. 

2/ file cdx.lsp mình tải về xài toàn cho kết quả bằng 0 . các bác chỉ dùm...


<<

Filename: 390929_cdx.lsp
Tác giả: tuanthunder
Bài viết gốc: 80639
Tên lệnh: brk
Lisp biến 1 phần của đoạn thẳng trở thành nét Hidden2.

Mạn phép anh giabach Tue_NV viết thêm vào đoạn Code của anh để giúp cho bạn tuanthunder

@ tuanthunder : Bạn sử dụng code này thử nhé :

(defun c:brk(/...
>>
Mạn phép anh giabach Tue_NV viết thêm vào đoạn Code của anh để giúp cho bạn tuanthunder

@ tuanthunder : Bạn sử dụng code này thử nhé :

(defun c:brk(/ cobj ent ov pt1 pt2 tmp vl str); brk -> Break Curve
 (vl-load-com)
 (command "undo" "be")
 (setq vl '("osmode" "orthomode" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl))              ; Get Old values
 (mapcar 'setvar vl '(545 0 0))
 (if (and (setq Ent (car (entsel "\nChon doi tuong can chia :")))
   (wcmatch (cdr (assoc 0 (entget ent))) "*LINE,ARC")
   (not (redraw ent 3))
   (setq pt1 (getpoint "\nDiem dau :"))
   (setq pt2 (getpoint "\nDiem cuoi :"))   )
   (progn
         (setq cObj (vlax-ename->vla-object Ent)
    pt1 (vlax-curve-getClosestPointto cObj (trans pt1 1 0))
    pt2 (vlax-curve-getClosestPointto cObj (trans pt2 1 0)))
     (if (> (vlax-curve-getParamAtPoint cObj pt1)
     (vlax-curve-getParamAtPoint cObj pt2))
(setq tmp pt1 pt1 pt2 pt2 tmp) )      
     (command "._break" ent "_non" (trans pt2 0 1) "_non" (trans pt2 0 1))
     (if (equal pt1 (vlax-curve-getStartPoint cObj) 0.001)
(command "change" ent "" "p" "LA" (lcurr) "")
(progn
  (command "._break" ent "_non" (trans pt1 0 1) "_non" (trans pt1 0 1))
  (command "change" (entlast) "" "p" "LA" (lcurr) "")
  )
)
     (redraw ent 4)
     (mapcar 'setvar vl ov) ; reset Sys Vars
     (command "undo" "e")
     )
   (alert "Khong hop le !"))
 (princ))
;
(defun lcurr(/ e)
    (setq str (getstring t "\n Nhap ten layer hoac Enter de pick vao doi tuong :"))
(if (= str "") 
(progn 
(while (null (setq e (entsel "\n pick vao doi tuong :"))))
(setvar "clayer" (cdr(assoc 8 (entget(car e)))))
)
(progn
(while (null (tblsearch "layer" str)) 
(setq str (getstring t "\n Nhap lai ten layer :"))
)
(setvar "clayer" str)
)
)
)

Cảm ơn bác đã viết Lisp rất hay. Nhưng bác có thể chỉnh lại Lisp để các nét đứt đó sẽ là Layer hiện hành(Tức layer đang được chọn). Chứ không phải qua bước nhập tên layer hay pick layer nữa. Cảm ơn bác.Chúc bác luôn khỏe và thành đạt


<<

Filename: 80639_brk.lsp
Tác giả: transduc
Bài viết gốc: 269253
Tên lệnh: c2e
(Nhờ vả) Lisp chuyển text từ cad sang excel dạng cột!

 

Thử lisp này xem

 

(defun c:c2e ( / ss lst fuzz fid sosanh)
  (defun sosanh    (e1 e2 / p1 p2)
    (setq p1...
>>

 

Thử lisp này xem

 

(defun c:c2e ( / ss lst fuzz fid sosanh)
  (defun sosanh    (e1 e2 / p1 p2)
    (setq p1 (car e1)      p2 (car e2)    )
    (if    (equal (car p1) (car p2) fuzz)
            (> (cadr p1) (cadr p2))
      (< (car p1) (car p2))
    )  )
 (setq   lst        (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "TEXT"))))))
     fuzz    (* (cdr (assoc 40 (entget (car lst)))) 10.0)   
                    lst    (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst)   
        lst (vl-sort lst 'sosanh)  
   fid     (open (getfiled "Chon file de save" "" "csv" 1) "w")  )  
  (foreach e lst
        (princ (strcat (cdr e)"\n") fid)              )    
  (close fid))

lisp bác gửi giống lisp e gửi kèm mà, kết quả không như mong đợi chứ, mãi mà không làm được.chán


<<

Filename: 269253_c2e.lsp
Tác giả: nguyenbakien
Bài viết gốc: 19658
Tên lệnh: cd
Mất OSNAP khi dùng LISP
Cái này là do trong file lisp của bác thiếu fần bẫy lôĩ . Bác để ý kỹ sẽ thấy ... trên dđ

vd 1 hàm bẫy lỗi, khi có lỗi xảy ra sẽ tự động gán các chế độ bắt...

>>
Cái này là do trong file lisp của bác thiếu fần bẫy lôĩ . Bác để ý kỹ sẽ thấy ... trên dđ

vd 1 hàm bẫy lỗi, khi có lỗi xảy ra sẽ tự động gán các chế độ bắt điểm, ortho ở trạng thái trước đó

;*******************************************************************************

(defun myerror (s)				  ; If an error (such as CTRL-C) occurs
								; while this command is active...
 (cond
((= s "quit / exit abort") (princ))
((/= s "Function cancelled") (princ (strcat "\nError: " s)))
 )
 (setvar "cmdecho" CMD)		; Restore saved modes
 (setvar "osmode" OSM)
 (setq *error* OLDERR)			 ; Restore old *error* handler
 (princ)
)

 

gán lại biến older vào ct khi bắt đầu & khi kết thúc

(DEFUN C:CD  ()
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
  *error* myerror)
....

 

....
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR)
(PRINC)
)

Có cách nàp dơn giản hơn hkông ban?

Mình thấy cách này cũng hay, nhưng nếu mình sử dụng một lúc nhiều lisp thi không có thời gian để ngồi kiểm tra hết các lỗi đó được:(


<<

Filename: 19658_cd.lsp
Tác giả: thanhduan2407
Bài viết gốc: 102583
Tên lệnh: rft
lisp Phun tọa độ các điểm từ file txt vào CAD
Cập nhật theo yêu cầu :

Lisp tạo ra 1 đ/tuợng POINT và 3 đ/tuợng TEXT như sau :

1. Lớp Point có kí hiệu điểm...

>>
Cập nhật theo yêu cầu :

Lisp tạo ra 1 đ/tuợng POINT và 3 đ/tuợng TEXT như sau :

1. Lớp Point có kí hiệu điểm (cột 2-3)

2. Lớp Sothutu : TEXT Số thứ tự (cột 1)

3. Lớp Caodo : TEXT Cao độ (cột 4)

4. Lớp Code : TEXT Code (cột 5)

 

với định dạng của file điểm đo : STT X Y Z Code ,

chấp nhận kí tự phân biệt giữa các giá trị trong file điểm đo : dấu cách, dấu Tab, dấu phẩy.

(defun c:RFT(/ code data f h line pt pxy spc txt stt ten);Read File Txt
 ;|  By : Gia Bach, gia_bach @  www.CadViet.com             |;    
 (vl-load-com)
(defun Split(str / i kitu line lst txtPhanbiet)
 (setq i 1 txtPhanbiet (strcat(chr 9)(chr 32)(chr 44)))
 (while (< i (strlen str))
   (setq kitu (substr str i 1))
   (if (vl-string-search kitu  txtPhanbiet)
     (progn
(if (null Lst)
  (setq Lst (list (substr Str 1 (- i 1))))
  (setq Lst (append Lst (list (read (substr Str 1 (- i 1)))))))
(setq Str (substr Str (+ i 1)) i 1))
     (setq i (1+ i)) )   )
 (setq Lst (append Lst (list Str)))  )
 (or *h* (setq *h* 2 ))
 (initget 6)
 (setq h (getdist (strcat "\nNhap chieu cao Text <" (rtos *h*) "> :")) )
 (if h (setq *h* h) (setq h *h*))
 (if (setq ten (getfiled "Chon File txt" (getvar "dwgprefix") "txt" 8))
   (progn
     (or (tblsearch "layer" "Point") (command "-layer" "n" "Point" "") )
     (or (tblsearch "layer" "Sothutu") (command "-layer" "n" "Sothutu" "c" 3 "Sothutu" "") )
     (or (tblsearch "layer" "Caodo") (command "-layer" "n" "Caodo" "c" 4 "Caodo" "") )
     (or (tblsearch "layer" "Code") (command "-layer" "n" "Code" "c" 2 "Code" "") )
     (setq spc (vla-get-ModelSpace (vla-get-ActiveDocument(vlax-get-Acad-Object))))
     (setq f (open (findfile ten) "r"))
     (while (setq Line (read-line f))
(if (wcmatch Line (strcat "*"(chr 9)"*,*"(chr 32)"*,*`"(chr 44)"*"))
  (progn
    (setq data (split Line) code (last data))
    (if (and
	  (= (vl-list-length data)5)
	  (setq pt (vl-remove code (cdr data)))
	  (not(vl-catch-all-error-p (vl-catch-all-apply 'vlax-3d-point pt))) )
      (progn
	(setq stt (car data) pXY (list (car pt)(cadr pt)))
	(vla-put-Layer (vla-addpoint spc (vlax-3d-point pXY)) "Point")
	(vla-put-Layer (setq txt (vla-addtext spc stt (vlax-3d-point (list 0 0 0)) h)) "Sothutu")
	(vla-put-Alignment txt 8)
	(vla-put-TextAlignmentPoint txt (vlax-3d-point pXY))
	(vla-put-Layer (setq txt (vla-addtext spc code (vlax-3d-point (list 0 0 0)) h)) "Code")
	(vla-put-Alignment txt 6)
	(vla-put-TextAlignmentPoint txt (vlax-3d-point (polar pXY 0 (* 0.2 h))))
	(vla-put-Layer (vla-addtext spc (caddr pt) (vlax-3d-point pXY) h) "Caodo")	))))) ) )
 (princ))

to : thanhduan2407

- Bạn tham khảo cách sử dụng hàm Split ở trên, chỉ đơn giản thay dòng (split Line "\t") bằng (split Line)

và dòng (vl-string-search "\t" Line) bằng (wcmatch Line (strcat "*"(chr 9)"*,*"(chr 32)"*,*`"(chr 44)"*"))

- Nếu bạn đã biết VB thì việc học LISP rất đơn giản (Ngôn ngữ chỉ là cách thể hiện, thuật toán mới là vấn đề)

- Bạn có thể tham khảo bài Hướng dẫn lập trình Lisp, Hãy tự mình khám phá... của bác SSG.

Cảm ơn bác rất nhiều

Cháu sẽ cố gắng nghiên cứu

Autolisp thật là món quà tuyệt diệu

Có chỗ nào không hiểu mong bác giúp đỡ cháu nhiều.

Cháu không biết bác bao nhiêu tuổi xưng hô cho phải phép

Cháu năm nay 27 tuổi

Cảm ơn bác đã quan tâm đến bài viết


<<

Filename: 102583_rft.lsp
Tác giả: thangsra
Bài viết gốc: 16771
Tên lệnh: scl
Thay đổi kích thước hang loạt của các đường line
Lệnh SCL - Scale Line dưới đây sẽ làm điều bạn muốn. Nó sẽ scale các line với điểm chèn là trung điểm và theo tỷ lệ bạn nhập vào.

 

>>
Lệnh SCL - Scale Line dưới đây sẽ làm điều bạn muốn. Nó sẽ scale các line với điểm chèn là trung điểm và theo tỷ lệ bạn nhập vào.

 

(defun c:scl ( / ss tyle)
 (defun sl(ent / tt p1 p2 p1m p2m)
   (setq
     tt (entget ent)
     p1 (cdr (assoc 10 tt))
     p2 (cdr (assoc 11 tt))
     p1m (polar p1 (angle p1 p2) (* (distance p1 p2) tyle))
     p2m (polar p2 (angle p2 p1) (* (distance p1 p2) tyle))
     tt (subst (cons 10 p1m) (cons 10 p1) tt)
     tt (subst (cons 11 p2m) (cons 11 p2) tt)
   )
   (entmod tt)
 )
 (setq
   ss	 (ssget '((0 . "LINE")))
   tyle (* (+ (getreal "\nTy le scale line: ") 1.0) 0.5)
 )
 (sudung sl ss)
 (princ)
)

(defun sudung (ham ss / sodt index entdt soapp)
 (setq	sodt  (cond
	(ss (sslength ss))
	(t 0)
      )
soapp 0
index 0
 )
 (repeat sodt
   (setq entdt	(ssname ss index)
  index	(1+ index)
   )
   (if	(ham entdt)
     (setq soapp (1+ soapp))
   )
 )
 soapp
)
(princ "\nSCL - Scale Line, free lisp from CADViet.com")
(princ)

Thanksss. Nhân đây cho hỏi bác luôn là cơ sở để tạo các lisp này là thế nào vậy. Em mới biết lấy của mấy bác về thôi chứ chưa biết bắt đầu như thế nào. Mấy bài về lisp của bác em cung xem rối nhưng không biết cụ thể lắm. Mong chỉ giáo! Em đi ngủ đây. Cảm ơn bác vì luôn nhiệt tình với anh em trong diễn đàn


<<

Filename: 16771_scl.lsp
Tác giả: luanpq86
Bài viết gốc: 414193
Tên lệnh: btk
Nhờ viết lisp dim kích thước các pline và xuất ra file cel

 

Nhờ các bác viết dùm lisp như này:

- Lisp 1: ghi kích thước theo dimstyle hiện hành

Có các thanh thép là các đường...

>>

 

Nhờ các bác viết dùm lisp như này:

- Lisp 1: ghi kích thước theo dimstyle hiện hành

Có các thanh thép là các đường pline, line như trong file đính kèm (phần "ban đầu"), em muốn đo các kích thước của các thanh thép đó như phần "Dùng lisp" có cả kích thước chiều dài cung tròn, kích thước bán kính cung tròn, góc nghiêng.

Chú ý là thanh X3 đo kích thước cung tròn bằng lệnh 'dar' thì không đẹp, các bác có thể viết lisp thay thế bằng lệnh đo góc 'dan' mà giá trị ghi vẫn là chiều dài cung đó được ko.

- Lisp 2: Tính chiều dài và điền vào text, xuất sang cel

Cụ thể là pick vào từng thanh một sẽ tính chiều dài thanh đó (có thể là line hoặc pline) rồi pick vào từng text sẽ điền giá trị chiều dài thanh đó vào phần cuối của text.

VD: pick vào hình vẽ thanh X1 sẽ hiện lên command "điền giá trị vào text" rồi pick vào text "x1-d25, l=" sẽ thành "x1-d25, l=4545", sau đó hiện lên command "chọn thanh tiếp theo" pick vào thanh x2 rồi pick vào text "x2-d16, l=" v.v.....

Kết thúc bằng lệnh enter sẽ xuất chiều dài các thanh vừa pick sang file excel với giá trị chiều dài các thanh nằm trên 1 cột như file đính kèm

 

http://www.cadviet.com/upfiles/3/83908_cotthep_1.rar

Mong các bác giúp đỡ, em xin cám ơn trước.

 

P/S: Em cũng tìm mấy hôm trên diễn đàn về lisp tính chiều dài pline và xuất sang excel thì chưa tìm được lisp đúng ý.

Lisp này thì tính chiều dài từng phần trong pline mà ko tính tổng, lại ko tính liên tục các pline được, nhờ các bác sửa giúp em

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=43033
(defun c:p2E(/ i ent ss lstV pt_lst nb)
; Polyline Vertex Length to Excel
; @ gia_bach
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "*POLYLINE"))))
    (progn
    (repeat (setq i (sslength ss))
	(setq ent (ssname ss (setq i (1- i))) 
		  nb (strcat "Pline " (rtos (- (sslength ss) i) 2 0)) 
		  lstV (append (list(list nb))(pll ent)))
	(foreach pt lstV
	  (setq pt_lst (append pt_lst (list pt)))
	))	  
      (if (vlax-get-or-create-object "Excel.Application")
	(WriteToExcel pt_lst)
	(WriteToCSV pt_lst) )))
  (princ))

(defun WriteToExcel (lst_data / col row x xlApp xlCells)
  (setq xlApp (vlax-get-or-create-object "Excel.Application")
	xlCells (vlax-get-property
		  (vlax-get-property
		    (vlax-get-property
		      (vlax-invoke-method
			(vlax-get-property xlApp "Workbooks")
			"Add")
		      "Sheets")
		    "Item" 1)
		  "Cells"))
  (setq row 3)
  (foreach pt lst_data
    (setq col 3)
    (foreach coor pt
      (vlax-put-property xlCells 'Item row col coor)
      (setq col (1+ col)))
    (setq row (1+ row)) )
  (vla-put-visible xlApp :vlax-true)
  (mapcar
    (function (lambda (x)
		(vl-catch-all-apply (function (lambda ()(if x (vlax-release-object x)))))))
    (list xlCells xlApp))
  (gc) (gc) )

(defun WriteToCSV (lst_data / fl)  
  (if (setq fl (getfiled "Output File" "" "csv" 1))
    (if (setq fl (open fl "w"))
      (progn
	(foreach pt lst_data 
	  (write-line (strcat (rtos (car pt)) "," (rtos (cadr pt)) "," (rtos (caddr pt))) fl) )
	(close fl) ) ) )
  (princ))
  
  
  
  (defun pll ( e / j)         
  (setq j (1- (vlax-curve-getStartParam e)) lst '())
  (while (<= (setq j (1+ j)) (vlax-curve-getEndParam e))
    (setq lst
        (cons 
          (list (- (vlax-curve-getDistatParam e j)
             (if (zerop j) 0
             (vlax-curve-getDistatParam e (1- j)))))
		lst
		)
	)
  )
	(setq lst (cdr (reverse lst)))
	lst
)

 

Hoặc lisp này thì lại chỉ tính được line:

(defun c:btk ( / plst e p0 p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 n i obj els pa pf ps len txt fn fw ans)
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq plst (list)  i 0)
(alert "\n Chon cac doan can thong ke")
(setq e  (entsel "\n Chon doan can thong ke"))
(While e
        (princ (strcat " 1 found. " (rtos (1+ i) 2 0) "total"))
        (setq plst (cons e plst)
                  e (entsel "\n Chon doan tiep theo")
                  i (1+ i)
        )
)
(setq plst (reverse plst))
(setq p1 (getpoint "\n Chon diem dat bang thong ke")
          p2 (polar p1 0 2.5)
          p3 (polar p2 0 5.5)
          p4 (polar p3 0 5.5)
          p5 (polar p4 0 5.5)
          n (length plst)
          p6 (polar p1 (* 1.5 pi) (* (1+ n) 1.5))
          p7 (polar p2 (* 1.5 pi) (* (1+ n) 1.5))
          p8 (polar p3 (* 1.5 pi) (* (1+ n) 1.5))
          p9 (polar p4 (* 1.5 pi) (* (1+ n) 1.5))
          p10 (polar p5 (* 1.5 pi) (* (1+ n) 1.5))
)
(command "line" p1 p5 p10 p6 p1 "")
(command "line" p2 p7 "")
(command "line" p3 p8 "")
(command "line" p4 p9 "")
(styleset)
(command "text" "j" "mc" (list (+ (car p1) 1.25) (- (cadr p1) 0.75)) 0.3 0 "TT  ÐO\\U+1EA0N" )
(command "text" "j" "mc" (list (+ (car p2) 2.75) (- (cadr p1) 0.75)) 0.3 0 "T\\U+1EEA  ÐI\\U+1EC2M" )
(command "text" "j" "mc" (list (+ (car p3) 2.75) (- (cadr p1) 0.75)) 0.3 0 "T\\U+1EDAI  ÐI\\U+1EC2M" )
(command "text" "j" "mc" (list (+ (car p4) 2.75) (- (cadr p1) 0.75)) 0.3 0 "CHI\\U+1EC0U  DÀI")
(command "text" "j" "mc" (list (+ (car p1) 9.5) (+ (cadr p1) 0.5 )) 0.5 0 "B\\U+1EA2NG XU\\U+1EA4T RA K\\U+1EBET QU\\U+1EA2")
(setq ans (getstring "\n Ban muon luu sang file cvs khong?? <Y or N>: "))
(if (= (strcase ans) "Y")
    (progn
            (setq fn (getfiled "Chon file de save" "" "csv" 1)
   	       fw (open fn "w"))
       	(princ  "BANG XUAT TOA DO RA FILE CSV \n" fw)
                  (princ " TT doan , Tu diem , Toi diem , Chieu dai \n" fw)
   )
)
(setq i 0)
(foreach a plst
   	(setq i (1+ i)
                obj (vlax-ename->vla-object (car a))
                els (entget (car a))
                p0 (polar p1 (* 1.5 pi) 1.5)
                p1 p0
   	)
   	(cond
         	( (or (= (cdr (assoc 0 els)) "LWPOLYLINE") (= (cdr (assoc 0 els)) "POLYLINE"))
                  (setq pa (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (cadr a)))
                            pf (vlax-curve-getpointatparam obj (fix pa))
                            ps (vlax-curve-getpointatparam obj (1+ (fix pa)))
                            len (- (vlax-curve-getdistatpoint obj ps) (vlax-curve-getdistatpoint obj pf))                          
                  ) )
         	( (= (cdr (assoc 0 els)) "LINE")
                  (setq pf (cdr (assoc 10 els))
                       	ps (cdr (assoc 11 els))
                       	len (distance pf ps)
                  ) )
         	( (or (= (cdr (assoc 0 els)) "SPLINE") (=  (cdr (assoc 0 els)) "ARC") )
                  (setq pf (vlax-curve-getstartpoint obj)
                       	ps (vlax-curve-getendpoint obj)
                       	len (vlax-curve-getdistatpoint obj ps)
                  ) )
         	(T nil)
   	)
   	(setq txt (strcat (rtos i 2 0) "," "X=" (rtos (car pf) 2 4) "  Y=" (rtos (cadr pf) 2 4) "," "X=" (rtos (car ps) 2 4) "  Y=" (rtos (cadr ps) 2 4) "," (rtos len 2 4) "\n"))
   	(command "line" p0 (polar p0 0 19) "")
   	(command "text" "j" "mc" (list (+ (car p0) 1.25) (- (cadr p0) 0.75)) 0.2 0 (rtos i 2 0) )
   	(command "text" "j" "mc" (list (+ (car p0) 5.25) (- (cadr p1) 0.75)) 0.2 0 (strcat "X=" (rtos (car pf) 2 4) "  Y=" (rtos (cadr pf) 2 4)) )
   	(command "text" "j" "mc" (list (+ (car p0) 10.75) (- (cadr p1) 0.75)) 0.2 0 (strcat "X=" (rtos (car ps) 2 4) "  Y=" (rtos (cadr ps) 2 4)) )
   	(command "text" "j" "mc" (list (+ (car p0) 16.25) (- (cadr p1) 0.75)) 0.2 0 (rtos len 2 4))
   	(if (= (strcase ans) "Y")
       	(princ txt fw)
   	)
)
(if fw
   (close fw)
)
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)
 
(defun styleset ()
(setq stl (getvar "textstyle")
     	h (getvar "textsize"))
(if (/= h 0) (command "style" stl "" 0 "" "" "" "" ""))
)                  

 

 

Nhờ các bác viết dùm lisp như này:

- Lisp 1: ghi kích thước theo dimstyle hiện hành

Có các thanh thép là các đường pline, line như trong file đính kèm (phần "ban đầu"), em muốn đo các kích thước của các thanh thép đó như phần "Dùng lisp" có cả kích thước chiều dài cung tròn, kích thước bán kính cung tròn, góc nghiêng.

Chú ý là thanh X3 đo kích thước cung tròn bằng lệnh 'dar' thì không đẹp, các bác có thể viết lisp thay thế bằng lệnh đo góc 'dan' mà giá trị ghi vẫn là chiều dài cung đó được ko.

- Lisp 2: Tính chiều dài và điền vào text, xuất sang cel

Cụ thể là pick vào từng thanh một sẽ tính chiều dài thanh đó (có thể là line hoặc pline) rồi pick vào từng text sẽ điền giá trị chiều dài thanh đó vào phần cuối của text.

VD: pick vào hình vẽ thanh X1 sẽ hiện lên command "điền giá trị vào text" rồi pick vào text "x1-d25, l=" sẽ thành "x1-d25, l=4545", sau đó hiện lên command "chọn thanh tiếp theo" pick vào thanh x2 rồi pick vào text "x2-d16, l=" v.v.....

Kết thúc bằng lệnh enter sẽ xuất chiều dài các thanh vừa pick sang file excel với giá trị chiều dài các thanh nằm trên 1 cột như file đính kèm

 

http://www.cadviet.com/upfiles/3/83908_cotthep_1.rar

Mong các bác giúp đỡ, em xin cám ơn trước.

 

P/S: Em cũng tìm mấy hôm trên diễn đàn về lisp tính chiều dài pline và xuất sang excel thì chưa tìm được lisp đúng ý.

Lisp này thì tính chiều dài từng phần trong pline mà ko tính tổng, lại ko tính liên tục các pline được, nhờ các bác sửa giúp em

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=43033
(defun c:p2E(/ i ent ss lstV pt_lst nb)
; Polyline Vertex Length to Excel
; @ gia_bach
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "*POLYLINE"))))
    (progn
    (repeat (setq i (sslength ss))
	(setq ent (ssname ss (setq i (1- i))) 
		  nb (strcat "Pline " (rtos (- (sslength ss) i) 2 0)) 
		  lstV (append (list(list nb))(pll ent)))
	(foreach pt lstV
	  (setq pt_lst (append pt_lst (list pt)))
	))	  
      (if (vlax-get-or-create-object "Excel.Application")
	(WriteToExcel pt_lst)
	(WriteToCSV pt_lst) )))
  (princ))

(defun WriteToExcel (lst_data / col row x xlApp xlCells)
  (setq xlApp (vlax-get-or-create-object "Excel.Application")
	xlCells (vlax-get-property
		  (vlax-get-property
		    (vlax-get-property
		      (vlax-invoke-method
			(vlax-get-property xlApp "Workbooks")
			"Add")
		      "Sheets")
		    "Item" 1)
		  "Cells"))
  (setq row 3)
  (foreach pt lst_data
    (setq col 3)
    (foreach coor pt
      (vlax-put-property xlCells 'Item row col coor)
      (setq col (1+ col)))
    (setq row (1+ row)) )
  (vla-put-visible xlApp :vlax-true)
  (mapcar
    (function (lambda (x)
		(vl-catch-all-apply (function (lambda ()(if x (vlax-release-object x)))))))
    (list xlCells xlApp))
  (gc) (gc) )

(defun WriteToCSV (lst_data / fl)  
  (if (setq fl (getfiled "Output File" "" "csv" 1))
    (if (setq fl (open fl "w"))
      (progn
	(foreach pt lst_data 
	  (write-line (strcat (rtos (car pt)) "," (rtos (cadr pt)) "," (rtos (caddr pt))) fl) )
	(close fl) ) ) )
  (princ))
  
  
  
  (defun pll ( e / j)         
  (setq j (1- (vlax-curve-getStartParam e)) lst '())
  (while (<= (setq j (1+ j)) (vlax-curve-getEndParam e))
    (setq lst
        (cons 
          (list (- (vlax-curve-getDistatParam e j)
             (if (zerop j) 0
             (vlax-curve-getDistatParam e (1- j)))))
		lst
		)
	)
  )
	(setq lst (cdr (reverse lst)))
	lst
)

 

Hoặc lisp này thì lại chỉ tính được line:

(defun c:btk ( / plst e p0 p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 n i obj els pa pf ps len txt fn fw ans)
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq plst (list)  i 0)
(alert "\n Chon cac doan can thong ke")
(setq e  (entsel "\n Chon doan can thong ke"))
(While e
        (princ (strcat " 1 found. " (rtos (1+ i) 2 0) "total"))
        (setq plst (cons e plst)
                  e (entsel "\n Chon doan tiep theo")
                  i (1+ i)
        )
)
(setq plst (reverse plst))
(setq p1 (getpoint "\n Chon diem dat bang thong ke")
          p2 (polar p1 0 2.5)
          p3 (polar p2 0 5.5)
          p4 (polar p3 0 5.5)
          p5 (polar p4 0 5.5)
          n (length plst)
          p6 (polar p1 (* 1.5 pi) (* (1+ n) 1.5))
          p7 (polar p2 (* 1.5 pi) (* (1+ n) 1.5))
          p8 (polar p3 (* 1.5 pi) (* (1+ n) 1.5))
          p9 (polar p4 (* 1.5 pi) (* (1+ n) 1.5))
          p10 (polar p5 (* 1.5 pi) (* (1+ n) 1.5))
)
(command "line" p1 p5 p10 p6 p1 "")
(command "line" p2 p7 "")
(command "line" p3 p8 "")
(command "line" p4 p9 "")
(styleset)
(command "text" "j" "mc" (list (+ (car p1) 1.25) (- (cadr p1) 0.75)) 0.3 0 "TT  ÐO\\U+1EA0N" )
(command "text" "j" "mc" (list (+ (car p2) 2.75) (- (cadr p1) 0.75)) 0.3 0 "T\\U+1EEA  ÐI\\U+1EC2M" )
(command "text" "j" "mc" (list (+ (car p3) 2.75) (- (cadr p1) 0.75)) 0.3 0 "T\\U+1EDAI  ÐI\\U+1EC2M" )
(command "text" "j" "mc" (list (+ (car p4) 2.75) (- (cadr p1) 0.75)) 0.3 0 "CHI\\U+1EC0U  DÀI")
(command "text" "j" "mc" (list (+ (car p1) 9.5) (+ (cadr p1) 0.5 )) 0.5 0 "B\\U+1EA2NG XU\\U+1EA4T RA K\\U+1EBET QU\\U+1EA2")
(setq ans (getstring "\n Ban muon luu sang file cvs khong?? <Y or N>: "))
(if (= (strcase ans) "Y")
    (progn
            (setq fn (getfiled "Chon file de save" "" "csv" 1)
   	       fw (open fn "w"))
       	(princ  "BANG XUAT TOA DO RA FILE CSV \n" fw)
                  (princ " TT doan , Tu diem , Toi diem , Chieu dai \n" fw)
   )
)
(setq i 0)
(foreach a plst
   	(setq i (1+ i)
                obj (vlax-ename->vla-object (car a))
                els (entget (car a))
                p0 (polar p1 (* 1.5 pi) 1.5)
                p1 p0
   	)
   	(cond
         	( (or (= (cdr (assoc 0 els)) "LWPOLYLINE") (= (cdr (assoc 0 els)) "POLYLINE"))
                  (setq pa (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (cadr a)))
                            pf (vlax-curve-getpointatparam obj (fix pa))
                            ps (vlax-curve-getpointatparam obj (1+ (fix pa)))
                            len (- (vlax-curve-getdistatpoint obj ps) (vlax-curve-getdistatpoint obj pf))                          
                  ) )
         	( (= (cdr (assoc 0 els)) "LINE")
                  (setq pf (cdr (assoc 10 els))
                       	ps (cdr (assoc 11 els))
                       	len (distance pf ps)
                  ) )
         	( (or (= (cdr (assoc 0 els)) "SPLINE") (=  (cdr (assoc 0 els)) "ARC") )
                  (setq pf (vlax-curve-getstartpoint obj)
                       	ps (vlax-curve-getendpoint obj)
                       	len (vlax-curve-getdistatpoint obj ps)
                  ) )
         	(T nil)
   	)
   	(setq txt (strcat (rtos i 2 0) "," "X=" (rtos (car pf) 2 4) "  Y=" (rtos (cadr pf) 2 4) "," "X=" (rtos (car ps) 2 4) "  Y=" (rtos (cadr ps) 2 4) "," (rtos len 2 4) "\n"))
   	(command "line" p0 (polar p0 0 19) "")
   	(command "text" "j" "mc" (list (+ (car p0) 1.25) (- (cadr p0) 0.75)) 0.2 0 (rtos i 2 0) )
   	(command "text" "j" "mc" (list (+ (car p0) 5.25) (- (cadr p1) 0.75)) 0.2 0 (strcat "X=" (rtos (car pf) 2 4) "  Y=" (rtos (cadr pf) 2 4)) )
   	(command "text" "j" "mc" (list (+ (car p0) 10.75) (- (cadr p1) 0.75)) 0.2 0 (strcat "X=" (rtos (car ps) 2 4) "  Y=" (rtos (cadr ps) 2 4)) )
   	(command "text" "j" "mc" (list (+ (car p0) 16.25) (- (cadr p1) 0.75)) 0.2 0 (rtos len 2 4))
   	(if (= (strcase ans) "Y")
       	(princ txt fw)
   	)
)
(if fw
   (close fw)
)
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)
 
(defun styleset ()
(setq stl (getvar "textstyle")
     	h (getvar "textsize"))
(if (/= h 0) (command "style" stl "" 0 "" "" "" "" ""))
)                  

Mình muốn lấy chiều dài đường polyline sau khi vẽ trên cad chuyển đến ô cell mà con trỏ hiện hành trong file excel mình đang mở sẵn rồi chứ không phải là book mới thì làm sao bạn?? thanks


<<

Filename: 414193_btk.lsp
Tác giả: qh2qa06
Bài viết gốc: 316760
Tên lệnh: ttl
Xin lisp tính chiều dài trung bình và DL của thanh thép biến thiên

 

- hi hi lâu lâu nhóc thử tự viết lsp theo y/c ko chỉnh sửa lsp cũ xem thế nào, bạn dùng thử cho nhoc ý kiến hen ^^

>>

 

- hi hi lâu lâu nhóc thử tự viết lsp theo y/c ko chỉnh sửa lsp cũ xem thế nào, bạn dùng thử cho nhoc ý kiến hen ^^

(defun c:TTL (/ old lmax lmin ename1 ename2 info1 info2 dai1 dai2 ltb ldelta e1 e2) ;
(setq old (getvar "osmode"))
(setvar "osmode" 0)
(prompt "Chon thanh co chieu dai be nhat:")
(setq lmin (ssget "+.:E:S" '((0 . "LINE"))))
(if lmin
 (progn
    (setq ename1 (ssname lmin 0)
	      info1 (entget ename1)
		  dai1 (distance (cdr (assoc 10 info1)) (cdr (assoc 11 info1)))
	 )
  )
)  
 ;=========================================================
(prompt "Chon thanh co chieu dai lon nhat:")
(setq lmax (ssget "+.:E:S" '((0 . "LINE"))))
(if lmax
 (progn
    (setq ename2 (ssname lmax 0)
	      info2 (entget ename2)
		  dai2 (distance (cdr (assoc 10 info2)) (cdr (assoc 11 info2)))
	 )
  )
)  
;===========================================================
(setq sl (getint "\nSo luong thanh mun tinh:"))
(setq ltb (* (/ (+ dai1 dai2) 2.0) 1000))
(setq ldelta (* (/ (- dai2 dai1) (- sl 1)) 1000))
(setq e1 (entget (car (entsel "\nchon text ghi ket qua L trung binh:"))))
(entmod (subst (cons 1 (strcat (itoa (- sl 1)) ",L = " (rtos ltb 2 0))) (assoc 1 e1) e1))
;===============================================================
(setq e2 (entget (car (entsel "\nchon dim ghi ket qua L delta:"))))
(entmod (subst (cons 1 (strcat (rtos (* dai1 1000) 2 0) "~" (rtos (* dai2 1000) 2 0) ", \U+0394L=" (rtos ldelta 2 0))) (assoc 1 e2) e2))
(setvar "osmode" old)
(princ "\n")
(princ)
)

Bạn ơi Lsp bạn viết cho mình tính đủ hết rồi, nhưng mình muốn sửa dòng ghi giá trị trung bình là: Số thanh rồi đến dấu ` rồi mới là 14,L=chiều dài trung bình. Hiện Lsp viết ra thiếu tiền tố Số thanh`. Bạn thêm tiền tố đó vào giúp mình được không?

Cảm ơn bạn!


<<

Filename: 316760_ttl.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 339665
Tên lệnh: xkl
Xuẩt khối lượng trắc ngang qua excel

Bạn update lại Lisp nhé. Tks

Lisp đây bạn:
(defun c:xkl (/ dem1...
>>

Bạn update lại Lisp nhé. Tks

Lisp đây bạn:
(defun c:xkl (/ dem1 lstkm point kcach point1 pointtim diemtam xuongdong kt)
(setvar "CMDECHO" 0)
(defun sosanh (e1 e2 / p1 p2)
(setq p1 (car e1)
p2 (car e2)
)
(if (equal (cadr p1) (cadr p2) fuzz)
(< (car p1) (car p2))
(> (cadr p1) (cadr p2))
)
   )
   
(defun inra(lst)
(setq index 1
 oldy nil)
(foreach en lst
(if (equal oldy (cadr (car en)) fuzz)
(progn 
(if (< index 4)
 (progn 
	(princ "," fid) 
	(setq index (1+ index))
	)
 	(progn 
	(setq index 1) 
	(princ "\n" fid)
	)
 )
    )
(progn  
(if hangdau
 (progn (setq index 1) 
(princ "\n" fid))
 (setq hangdau t))
  )
      )
      (princ (cdr en) fid)
      (setq oldy (cadr (car en)))
 )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (prompt "\nChon doi tuong coc hoac ly trinh lam lop chuan.")  
  (setq dtltc (car (entsel)))
  (setq lop1 (cdr (assoc 8 (entget dtltc))))
  (prompt "\nChon doi tuong ghi dien tich lam lop chuan.")
  (setq lop2 (car (entsel)))
  (setq lop2 (cdr (assoc 8 (entget lop2))))
  (prompt "\nChon trac ngang.")
  (setq danhsachkm (acet-ss-to-list (ssget (list (cons 8 lop1) (cons 1 "K*")))))
  (setq lstkm (mapcar '(lambda (e) (cons (cdr (assoc 11 (entget e))) (cdr (assoc 1 (entget e))))) danhsachkm))
  (setq lstkm (vl-sort lstkm '(lambda(x y / tmx tmy) (setq tmx (timlt x) tmy (timlt y))
                 (or (< (car tmx) (car tmy))
    (and (= (car tmx) (car tmy)) (< (last tmx) (last tmy)))))))
  (setq ss (acet-ss-to-list (ssget "X" '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq fn (getfiled "Chon file de save" "" "csv" 1))
  (setq fid (open fn "w"))
(setq dem1 1)
(setq sodt (length danhsachkm)
ta 
            (chr 8)
stxoa (strcat ta ta ta ta ta ta ta ta ta ta ta ta ta ta 
            ta ta ta ta ta ta)
stxuly "Xu ly duoc: "
ptcu nil
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (foreach ent lstkm
    (setq point (car ent))
    (setq kcach (distance point (cdr (assoc 11 (entget (nth 0 ss))))))
    (foreach enxt ss
      (setq point1 (cdr (assoc 11 (entget enxt))))
      (setq toay (cadr point1))
      (if (and (< (distance point1 point) kcach) (< toay (cadr point)) (equal (car point1) (car point) 1))
(progn
 (setq pointtim (cdr (assoc 11 (entget enxt))))
 (setq kcach (distance pointtim point))
)
      )
    )
    (setq diemtam (polar pointtim (/ pi 2) (/ kcach 2)))
;;; zoom den tung trac ngang nhung khong thay no chay 
;;;; 
    (vla-ZoomCenter (vlax-get-acad-object) (vlax-3D-point diemtam) (+ kcach 20))
	;(command "ZOOM" "C" diemtam (+ kcach 20))
    (setq dd (acet-ss-to-list (ssget "C" (polar pointtim (/ pi 4) 0.1 ) (polar pointtim (/ pi -4) 0.1 ) '((0 . "LINE")(8 . "ENTTNTUNHIEN")))))
    (setq diemdau (cdr (assoc 10 (entget (car dd)))))
    (setq diemcuoi (cdr (assoc 11 (entget (car dd)))))
    (setq diemtren (polar point (/ pi 2) 10))
    (command ".RECTANGLE" diemdau diemtren)
    (setq text (ssget "C" diemdau diemtren (list (cons 0 "text"))))
    (setq lst0 (ss2ent text lop1))
    (setq lst0 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst0))
    (setq lst2 (ss2ent text lop2))
    (setq lst2 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst2))
    (setq
caotext (cdr (assoc 40 (entget (ssname text 0))))
fuzz (* caotext 1.0)
lst0 (vl-sort lst0 'sosanh)
lst2 (vl-sort lst2 'sosanh)
    )
(setq xuongdong 0)
(if (= kt nil) (setq kt 0))
(foreach em lst0
(if (= kt 0)
(if (= xuongdong 0)
(progn 
(princ (cdr em) fid) 
(princ "\n" fid)
(setq xuongdong 1))
 (if (= xuongdong 1)
   (progn 
	(princ (cdr em) fid) 
	(setq xuongdong 2)
	)
)
)
(if (= xuongdong 0)
(progn 
(princ "\n" fid)
(princ (cdr em) fid) 
(princ "\n" fid)
(setq xuongdong 1))
 (if (= xuongdong 1)
   (progn 
	(princ (cdr em) fid) 
	(setq xuongdong 2)
	)
)
)
)
)
(setq kt 1)
    (inra lst2)
 
    (command ".RECTANGLE" diemcuoi diemtren)
    (setq text1 (ssget "C" diemcuoi diemtren (list (cons 0 "text"))))
    (setq lst3 (ss2ent text1 lop2))
    (setq lst3 (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst3))
    (setq lst3 (vl-sort lst3 'sosanh))
    (inra lst3)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; xu ly phan tram chay o duoi
(setq pt (* (/ (* dem1 1.0) sodt) 100.0)
dem1 (+ dem1 1)
)
(if (/= pt ptcu)
(progn
(princ (strcat stxoa stxuly (rtos pt 2 0) "%"))
(setq ptcu pt)
)
)
;(princ "\nDang xu ly")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setvar "MODEMACRO" "DANG CHUYEN DU LIEU CHO TRONG GIAY LAT")  
)
  (if fid (close fid))
(setvar "CMDECHO" 1)
(thoi)
)
 
(defun timlt (st / tm)
  (setq tm (vl-string->list (substr (strcase (cdr st)) (+ 3 (vl-string-search "KM" (strcase (cdr st)))))))
  (read (strcat "(" (vl-list->string (subst 32 43 (subst 32 58 tm))) ")"))
)
 
(defun ss2ent (ss lop / sodt index lstent)
  (setq sodt (if ss (sslength ss) 0)
index 0)
  (repeat sodt
    (setq ent (ssname ss index))
    (setq index (1+ index))
    (if (= (cdr (assoc 8 (entget ent))) lop)
      (setq lstent (cons ent lstent))
    )
  )
  (reverse lstent)
)


<<

Filename: 339665_xkl.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 397500
Tên lệnh: hh
Lisp hatch nhanh.

 

Nhờ các anh giúp em sửa đoạn code dưới đây có lực nét của Hatch (lineweight = 0.9) giúp em với. em tìm mọi cách mà...

>>

 

Nhờ các anh giúp em sửa đoạn code dưới đây có lực nét của Hatch (lineweight = 0.9) giúp em với. em tìm mọi cách mà không được!

(defun c:Hh(/)  (vl-load-com)
 (command "-boundary" "") (SETQ A (GETPOINT "==> PICK DIEM : "))
(command "-layer" "m" "Hatch" "c" "8" "" "") 
 (command "bhatch" "P" "ANSI31" "20" "0" A "")
 (princ))

Bạn sửa lại dòng 

(command "-layer" "m" "Hatch" "c" "8" "" "")

thành

(command "-layer" "m" "Hatch" "c" "8" "" "LWeight" 0.09 "" "") 


<<

Filename: 397500_hh.lsp
Tác giả: 840244
Bài viết gốc: 183601
Tên lệnh: test
Đặt chiều cao text, mtext và chỉnh Linetype scale ?

840244 chú ý quy định về đặt yêu cầu ở box...

>>

840244 chú ý quy định về đặt yêu cầu ở box nhé!

 

Đặt Linetype:

(defun C:test ( / ss d);
(grtext -1 "Free Lisp from Cadviet @Ketxu")
(cond ( (and (setq  ss (ssget (list (cons 0 "*LINE,ARC,CIRCLE"))))
(setq d (getreal "\nLineType Scale :"))
(vl-load-com)
(setq ss (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
 )
 (vlax-for obj ss (vla-put-LinetypeScale obj d))
)
((princ "\nError!"))
)
(princ)
)

Thanks anh KETXU nhìu nhé !


<<

Filename: 183601_test.lsp
Tác giả: vantuan18nd
Bài viết gốc: 243779
Tên lệnh: as
Lisp cộng thêm hằng số K

(defun c:as()

 

 

(setq i 0 s1 0)

 

(if (= n nill) (setq n (getreal "\nnhap so bi tru hoac so de cong:...

>>

(defun c:as()

 

 

(setq i 0 s1 0)

 

(if (= n nill) (setq n (getreal "\nnhap so bi tru hoac so de cong: ")))

(prompt "\nchon cac so can sua ...")

 

(setq txt (ssget '((0 . "TEXT"))))

 

(repeat (sslength txt)

 

(setq txt_name (ssname txt i))

 

(setq txt_ent (entget txt_name))

 

(setq cont (cdr(assoc 1 txt_ent)))

 

(setq cont (atof cont))

 

(setq s (+ cont n))

 

(setq txt_ent (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))

 

(entmod txt_ent)

 

(setq i (+ i 1))

 

);repeat

 

);defun

Hàm này làm có thể đúng ý bạn, nhưng chưa khắc phục được việc bạn muốn nhập lại hằng số mới thay vì số đã nhập, vì không biết bạn có muốn yêu cầu này hay không

Hì, Thanks bạn cd2k44 , Mình dùng được, đáp ứng được công việc hiện tại.

Bạn có thể cho nó hỏi nhập số cần cộng là K sau mỗi lần chạy lênh mới không ? như thế mới hoàn hảo. vì nó cứ im ỉm nhớ số thế, khi mình muốn nhập số mới vào thì lại không được


<<

Filename: 243779_as.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 174964
Tên lệnh: chbl
lisp đổi tên blog được chọn

Hề hề hề,

Nếu chê cái của bác Ketxu thì có thể dùng thử cái này coi sao, Tuy chả hay được như của bác ket nhưng may ra...

>>

Hề hề hề,

Nếu chê cái của bác Ketxu thì có thể dùng thử cái này coi sao, Tuy chả hay được như của bác ket nhưng may ra lại là hay với bạn hỉ????


(defun c:chbl (/ m old pc new sbl p)
(vl-load-com)
(command "undo" "be")
(setq m (car (entsel "\n chon block mau can thay "))
       old (cdr (assoc 2 (entget m)))
       pc (cdr (assoc 10 (entget m)))
       new (getstring t "\n Nhap ten thay the: ")
)
(if (= (tblsearch "block" new) nil)
   (command "block" new pc m "")
)
(command "insert" old pc 1 "" "")
(prompt "\n Chon tap cac block can thay ten ")
(setq sbl (acet-ss-to-list (ssget (list (cons 0 "insert") (cons 2 old)))))
(foreach x sbl
  	(setq p (cdr (assoc 10 (entget x))))
  	(command "erase" x "")
  	(command "insert" new p 1 "" "")
)
(command "undo" "e")
(princ)
)

Hề hề hề,.....

Trúng hay trật xin chớ cười chê....

Nhớ là cái trình tự thao tác không giống như bạn mô tả đâu.

Khi chạy lisp sẽ yêu cầu bạn chọn 1 block bất kỳ cùng tên với các block muốn đổi tên gọi là block mau.

Sau đó yêu cầu nhập cái tên mà bạn muốm đổi thành.

Lisp sẽ tạo một block mới toe mang cái tên mà bạn muốn, có hình hài giống y cái cũ.

Sau đó lisp yêu cầu bạn chọn tập hợp các block cần đổi tên.

Thế là nó sẽ tự đưa các block với tên mới vào thay thế cho các block tên cũ.

Hề hề hề,.

Nhìn thì thấy giống nhưng thật ra nó là hai block có cấu trúc khác nhau đấy. Hãy cẩn thận kẻo mà bé cái nhầm.....

Hy vọng gãi đúng chỗ bạn ngứa.

Hề hề hề,....

Hề hề hề... Bệnh nghề nghiệp (tôi đã từng mắc)... Hề hề hề... Dùng (vl-load-com) để mần chi mô? Hề hề hề.


<<

Filename: 174964_chbl.lsp
Tác giả: duy782006
Bài viết gốc: 175032
Tên lệnh: chbl
lisp đổi tên blog được chọn

Hề hề hề,

Nếu chê cái của bác Ketxu thì có thể dùng thử cái này coi sao, Tuy chả hay được như của bác ket nhưng may ra...

>>

Hề hề hề,

Nếu chê cái của bác Ketxu thì có thể dùng thử cái này coi sao, Tuy chả hay được như của bác ket nhưng may ra lại là hay với bạn hỉ????


(defun c:chbl (/ m old pc new sbl p)
(vl-load-com)
(command "undo" "be")
(setq m (car (entsel "\n chon block mau can thay "))
       old (cdr (assoc 2 (entget m)))
       pc (cdr (assoc 10 (entget m)))
       new (getstring t "\n Nhap ten thay the: ")
)
(if (= (tblsearch "block" new) nil)
   (command "block" new pc m "")
)
(command "insert" old pc 1 "" "")
(prompt "\n Chon tap cac block can thay ten ")
(setq sbl (acet-ss-to-list (ssget (list (cons 0 "insert") (cons 2 old)))))
(foreach x sbl
  	(setq p (cdr (assoc 10 (entget x))))
  	(command "erase" x "")
  	(command "insert" new p 1 "" "")
)
(command "undo" "e")
(princ)
)

Hề hề hề,.....

Trúng hay trật xin chớ cười chê....

Nhớ là cái trình tự thao tác không giống như bạn mô tả đâu.

Khi chạy lisp sẽ yêu cầu bạn chọn 1 block bất kỳ cùng tên với các block muốn đổi tên gọi là block mau.

Sau đó yêu cầu nhập cái tên mà bạn muốm đổi thành.

Lisp sẽ tạo một block mới toe mang cái tên mà bạn muốn, có hình hài giống y cái cũ.

Sau đó lisp yêu cầu bạn chọn tập hợp các block cần đổi tên.

Thế là nó sẽ tự đưa các block với tên mới vào thay thế cho các block tên cũ.

Hề hề hề,.

Nhìn thì thấy giống nhưng thật ra nó là hai block có cấu trúc khác nhau đấy. Hãy cẩn thận kẻo mà bé cái nhầm.....

Hy vọng gãi đúng chỗ bạn ngứa.

Hề hề hề,....

đọc lisp thì thấy bác xoá cái block đi rồi insert cái mới vào như thề hông ổn bác ơi. Còn layer, góc, tỉ lệ và linh tinh cái nửa.


<<

Filename: 175032_chbl.lsp
Tác giả: huycad
Bài viết gốc: 46047
Tên lệnh: ltt
Lisp làm tròn số ( là Text) trong CAD ???????

Cho mình hỏi có thể sửa Lisp này thành dạng làm tròn đến 5, 10,...tùy chọn như trong Dim ko nhỉ ?

Thanks a lot

 

Bạn dùng lisp này thử xem. Lệnh...
>>

Cho mình hỏi có thể sửa Lisp này thành dạng làm tròn đến 5, 10,...tùy chọn như trong Dim ko nhỉ ?

Thanks a lot

 

Bạn dùng lisp này thử xem. Lệnh LTT:

 

;;;-------------------------------------------------------
(defun etype (e) ;;;Entity Type
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------------
(defun C:LTT( / ss n i oldDimzin e d v S)
(if (not n0) (setq n0 2))
(setq
   ss (ssget '((0 . "TEXT,MTEXT")))
   n (getint (strcat "\nSo chu so thap phan <" (itoa n0) ">:"))
   i 0
   oldDimzin (getvar "dimzin")
)
(if n (setq n0 n) (setq n n0))
(setvar "dimzin" 1)
(repeat (sslength ss)
   (setq e (ssname ss i))
   (if (= (etype e) "MTEXT") (progn
       (command "explode" e "")
       (setq e (entlast))
   ))
   (setq
       d (entget e)
       v (atof (cdr (assoc 1 d)))
       S (rtos v 2 n)
       d (subst (cons 1 S) (assoc 1 d) d)
   )
   (entmod d)
   (setq i (1+ i))
)
(setvar "dimzin" oldDimzin)
(princ)
)
;;;-------------------------------------------------------

@Tue_NV

Ssg đã xem lại vấn đề hôm nọ. Trong các system var liên quan, chỉ có dimzin ảnh hưởng trực tiếp, các "thằng" khác không thấy tác dụng gì khi dùng (rtos value 2 n). Có lẽ do số 2 đã xác định kiểu decimal. Nếu vậy, ta cứ "chơi" như trên đơn giản hơn.


<<

Filename: 46047_ltt.lsp
Tác giả: manhtruong2111
Bài viết gốc: 300511
Tên lệnh: ha
Lisp Ghép Text Cần Giúp Đỡ

 

Lisp ghép từng cặp 2 text rời (dạng số) có khoảng cách 2 điểm chèn 1 hằng số, thành 1 text, thêm dấu chấm thập...

>>

 

Lisp ghép từng cặp 2 text rời (dạng số) có khoảng cách 2 điểm chèn 1 hằng số, thành 1 text, thêm dấu chấm thập phân.

;Doan Van Ha - CADViet.com - Ngay 11-6-2012
;Muc dich: Noi tung cap text kieu num gan nhau nhat, bang dau ".". VD: noi "5" va "32" thanh "5.32".
;Doi tuong chon va phan nhom theo tung cap co khoang cach giua 2 diem chen text la hang so.
(defun C:HA(/ ent1 ent2 lay1 lay2 kc ss lst x1 x2)
(while (not (setq ent1 (car (entsel "\nChon text so lon lam mau: ")))))
(while (not (setq ent2 (car (entsel "\nChon text so nho lam mau: ")))))
(princ "\nChon tap hop cac Text can noi...")
(setq lay1 (cdr (assoc 8 (entget ent1))) lay2 (cdr (assoc 8 (entget ent2))))
(setq kc (- (car (cdr (assoc 10 (entget ent1)))) (car (cdr (assoc 10 (entget ent2))))))
(setq ss (ssget (list (cons -4 "<AND") (cons 0 "TEXT") (cons -4 "<OR") (cons 8 lay1) (cons 8 lay2) (cons -4 "OR>") (cons -4 "AND>"))))
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(if (/= (rem (length lst) 2) 0)
  (alert "Yeu cau so luong 2 nhom Text phai bang nhau!")
  (foreach ent1 lst
   (setq x1 (car (cdr (assoc 10 (entget ent1)))))
   (foreach ent2 lst
	(setq x2 (car (cdr (assoc 10 (entget ent2)))))
	(if (equal (- x1 x2) kc 1E-8)
	(progn
  	(entmod (subst (cons 1 (strcat (cdr (assoc 1 (entget ent1))) "." (cdr (assoc 1 (entget ent2))))) (assoc 1 (entget ent1)) (entget ent1)))
  	(entdel ent2)
  	(setq lst (vl-remove ent1 (vl-remove ent2 lst))))))))
(princ))

Chân thành cám ơn bác :D. Nhờ lisp của bác mà em làm được việc

 


<<

Filename: 300511_ha.lsp
Tác giả: jangzang
Bài viết gốc: 401705
Tên lệnh: hat
Hatch Scale Khác Nhau Ở 2 Bản Vẽ

 

Cái này là do biến MEASUREMENT, do khi tạo file bạn chọn acadiso.dwt hay acad.dwt thì units sẽ là english hay metric.

Nếu bạn muốn...

>>

 

Cái này là do biến MEASUREMENT, do khi tạo file bạn chọn acadiso.dwt hay acad.dwt thì units sẽ là english hay metric.

Nếu bạn muốn sửa lại theo cái hatch to thi dùng lisp này xem sao.

(defun c:hat ()
(setvar 'measurement 1)
(foreach x (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "hatch"))))))
(command "-hatchedit" x "" "p"  "" (cdr (assoc 41 (entget x))) "" )
)
)

 

Đúng ý em rồi ạ, cảm ơn bác nhiều


<<

Filename: 401705_hat.lsp

Trang 248/330

248