Jump to content
InfoFile
Tác giả: gia_bach
Bài viết gốc: 47920
Tên lệnh: thu
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
Nhờ các bác giúp em gán lệnh While vào lisp này với.

 

(defun c:thu()

.........................

)

 

Em xin giải thích đôi chút, kiểu...

>>
Nhờ các bác giúp em gán lệnh While vào lisp này với.

 

(defun c:thu()

.........................

)

 

Em xin giải thích đôi chút, kiểu cắt X là cắt theo phương X, kiểu cắt Y là cắt theo phương Y. Do đó kiểu cắt X thì chọn đối tượng cũng theo phương X, Y cũng vậy.

Ở đây em muốn dùng hàm While để sau khi lisp break xong 1 đối tượng rồi sẽ quay lại lúc chọn điểm " (setq diem (getpoint "\nChon diem: ")) " để làm việc tiếp.

.............

Bạn dùng thử LISP này xem đúng ý bạn không nhé?

(defun c:thu(/ dt pt1 pt2)
 (setq kieu (strcase(getstring "\nNhap kieu cat: ")))
 (while (and (/= kieu "X") (/= kieu "Y"))
   (alert "Chi chap nhan kieu = x,X,y,Y !")
   (setq kieu (strcase(getstring "\nNhap kieu cat: ")))
   )
 (setq osn (getvar "osmode"))

 (while (setq dt (car (entsel "\nChon doi tuong: ")))
   (redraw dt 3)    
   (setvar "osmode" 32);giao diem
   (setq diem (getpoint "\nChon diem: "))
   (if (= kieu "X")
     (setq pt1(list (+ (car diem) 100) (+ (cadr diem) 0) 0)
    pt2(list (- (car diem) 100) (+ (cadr diem) 0) 0))
     )
   (if (= kieu "Y")
     (setq pt1(list (+ (car diem) 0) (+ (cadr diem) 100) 0)
    pt2(list (+ (car diem) 0) (- (cadr diem) 100) 0))
     )    
   (setvar "osmode" 0)
   (command ".break" dt pt1 pt2)
   (redraw dt 4)
   )
 (setvar "osmode" osn)
 (princ)
 )

Chú ý :

1.Sau khi lisp break xong đối tượng rồi, bạn phải chọn lại đối tượng rồi chọn điểm.

 

kiểu cắt X là cắt theo phương X, kiểu cắt Y là cắt theo phương Y. Do đó kiểu cắt X thì chọn đối tượng cũng theo phương X, Y cũng vậy.

.............

2.Bạn thử chọn ngược lại, VD: với kiểu cắt là X -> chọn đối tượng theo phương Y -> nhận xét kết quả.
<<

Filename: 47920_thu.lsp
Tác giả: Tue_NV
Bài viết gốc: 194538
Tên lệnh: ha
Lấy FontFile của Font Name bất kỳ

Việc đặt Text Style bằng Dialoge là đã rõ ràng.

Tuy nhiên, việc đặt Text Style bằng lisp, dùng hàm (command "style"...), thường...

>>

Việc đặt Text Style bằng Dialoge là đã rõ ràng.

Tuy nhiên, việc đặt Text Style bằng lisp, dùng hàm (command "style"...), thường gặp trở ngại vì cần phải biết chính xác FontFile.

Chẳng hạn, Font Name là .VnArial NarrowH thì FontFile là gì? Trả lời: nó là Vharialn_0.ttf

Hoặc, Font Name là Times New Roman thì FontFile là gì? Trả lời: nó là times.ttf

Làm sao để biết được? Lisp này giúp chúng ta lấy được FontFile chính xác ứng với từng Font Name.

Cách dùng:

1). Dùng lệnh Style để đặt 1 kiểu nào đó ứng với Font Name mà ta muốn biết FontFile.

2). Viết 1 Text ứng với kiểu đó ra screen.

3). Dùng lisp này để xác định FontFile của nó.

;----- Lay FontFile cua Text duoc chon
(defun C:HA( / sty ff)
(setq sty (cdr (assoc 7 (entget (car (entsel "\nChon 1 Text de lay FontFile: "))))))
(foreach ass (VxGetTextStyles)
 (if (= (car ass) sty) (setq ff (cdr ass))))
(alert ff)
ff)
(defun VxGetTextStyles ( / StyLst)
(vlax-for Sty (vla-get-TextStyles (vla-get-ActiveDocument (vlax-get-acad-object)))
 (setq StyLst (cons (cons (vla-get-Name Sty) (vla-get-FontFile Sty)) StyLst)))
(reverse StyLst))

Hoặc là :

 

(alert (cdr(assoc 3 (tblsearch "STYLE" (cdr (assoc 7 (entget (car (entsel "\nChon 1 Text de lay FontFile: ")))))))))


<<

Filename: 194538_ha.lsp
Tác giả: duy782006
Bài viết gốc: 428518
Tên lệnh: dml
Xin Lisp Thống Kê Chiều Dài Mline

-Lisp tính tổng chiều dài mline theo style, scale, layer. Tên lệnh DML

-Về lý thuyết thì thống kê các đường Mline có đủ các thuộc tính là làm được nhưng đề ko rỏ nên không giải.

(defun c:dml ( / txt)

 (initget "ST LA SA")
 (setq txt (getkword "\nLoc MLINE theo  <ST>: "))
 (cond
   ((not txt)
 ...
>>

-Lisp tính tổng chiều dài mline theo style, scale, layer. Tên lệnh DML

-Về lý thuyết thì thống kê các đường Mline có đủ các thuộc tính là làm được nhưng đề ko rỏ nên không giải.

(defun c:dml ( / txt)

 (initget "ST LA SA")
 (setq txt (getkword "\nLoc MLINE theo  <ST>: "))
 (cond
   ((not txt)
   (setq kieu " thuoc STYLE: <") (setq mdxf 2))
   ((= "ST" txt)
   (setq kieu " thuoc STYLE: <") (setq mdxf 2))
   ((= "LA" txt)
   (setq kieu " thuoc LAYER: <") (setq mdxf 8))
   ((= "SA" txt)
   (setq kieu " co SCALE: <") (setq mdxf 40))
 )

(setq ketqua (cdr (assoc mdxf (entget (car (chonmotmline))))))
(setq ss (ssget (list (cons 0 "MLINE") (cons mdxf ketqua))))
  (setq tot_len 0.0)
  (setq sml (sslength ss))

  (while (> (sslength ss) 0)
    (setq e_name (ssname ss 0))
    (setq e_record (entget e_name))
    (setq e_type (cdr (assoc '0 e_record)))
    (cond ((wcmatch e_type "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
	   (command "lengthen" e_name "")
	   (setq tot_len (+ tot_len (getvar "PERIMETER")))
	   (ssdel e_name ss)
	  )
	  ((wcmatch e_type "MLINE") (add_mline))
	  (e_type (ssdel e_name ss))
    )
  )

  (cond ((= "SA" txt) (setq ketqua (rtos ketqua 2 2)) ))
  (prompt (strcat "\nTim thay: " (itoa sml) " doi tuong MLINE" kieu ketqua "> tong chieu dai=" (rtos tot_len 2 2)))


(princ))
;;;;;;;;;;;;;;
(defun chonmotmline ( / dchon)
(setq dchon (entsel "\nChon Mline chuan:"))
(while
(or
(null (car dchon))
(and (/= "MLINE" (cdr (assoc 0 (entget (car dchon)))))
)
)
(princ "\nDoi tuong khong phai MLINE. Chon lai !")
(setq dchon (entsel))
)
dchon)
;;;;;;;;;;;;;;
(defun add_mline ()
  (foreach e_record_sub	e_record
    (cond ((= 10 (car e_record_sub))
	   (setq pt1	   (cdr e_record_sub)
		 mline_len 0.0
	   )
	  )
	  ((= 11 (car e_record_sub))
	   (setq pt2	   (cdr e_record_sub)
		 mline_len (+ mline_len (distance pt2 pt1))
		 pt1	   pt2
	   )
	  )
    )
  )
  (setq tot_len (+ tot_len mline_len))
  (ssdel e_name ss)
)

(lisp có sử dụng phần tính tổng mline của kexu)


<<

Filename: 428518_dml.lsp
Tác giả: Trà Đá
Bài viết gốc: 201893
Tên lệnh: test
LISP tạo đường viền cho text

Sửa lại cho bạn đây :

(defun c:test ( / e ss) (vl-load-com)
(setq i -1)
(if (setq ss (ssget '((0 . "*TEXT"))))
(while (setq e...
>>

Sửa lại cho bạn đây :

(defun c:test ( / e ss) (vl-load-com)
(setq i -1)
(if (setq ss (ssget '((0 . "*TEXT"))))
(while (setq e (ssname ss (setq i (1+ i))))
(entmakex
  (append
   (list
      (cons 0 "LWPOLYLINE")
      (cons 100 "AcDbEntity")
      (cons 100 "AcDbPolyline")
      (cons 90 4)
      (cons 70 1))
   (mapcar '(lambda ( p ) (cons 10 p)) (LM:BoundingBox (vlax-ename->vla-object e)))))))
 (princ))
(defun LM:BoundingBox ( object / lowerleft upperright )
 (if (vlax-method-applicable-p object 'GetBoundingBox)
((lambda ( boundingbox )
   (mapcar
      (function
     (lambda ( _functionlist )
 	     (mapcar
	     (function
 		     (lambda ( _function ) ((eval _function) boundingbox)))
	     _functionlist)))
  '((caar   cadar) (caadr  cadar)
     (caadr cadadr) (caar  cadadr))))
  (mapcar 'vlax-safearray->list
   (progn
      (vla-getBoundingBox object 'lowerleft 'upperright) (list lowerleft upperright))))))

Em muốn lisp thêm một dòng lệnh cho phép hỏi : Hình bao đường viền là hình Elip, Hình tròn , hình chữ nhật , hình đa giác và thực hiện các chức năng trên được không ạ?


<<

Filename: 201893_test.lsp
Tác giả: whatcholingon
Bài viết gốc: 244030
Tên lệnh: dmla1
Lisp chuyển Layer về thành Bylayer

 

Đây bạn!

 

(defun c:dmla1 ( / ss)
(command "undo" "begin") (setq cmd (getvar 'cmdecho)) (setvar...
>>

 

Đây bạn!

 

(defun c:dmla1 ( / ss)
(command "undo" "begin") (setq cmd (getvar 'cmdecho)) (setvar 'cmdecho 0)
(while (setq ent (car (entsel "\nChon doi tuong mau...")))
 (setq lay (cdr (assoc 8 (entget ent))))
 (setq ss (ssget "X" (list (cons 8 lay))))
 (command "change" ss "" "p" "c" "bylayer" "LT" "bylayer" "LW" "bylayer" ""))
 (setvar 'cmdecho cmd) (command "undo" "end")
(princ))

 

Tuyệt vời!

Cám ơn bạn nhiều


<<

Filename: 244030_dmla1.lsp
Tác giả: Han Tinh
Bài viết gốc: 388681
Tên lệnh: vmb
Nhờ Viết Lisp: Mặt Bích Trong Kết Cấu Thép

 

Thử xem sao: Lệnh là VMB

>>

 

Thử xem sao: Lệnh là VMB

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun duy:xd_listngngancach<kytu (chuoi kytu / chuoi kytu ckq) 
(setq lkq nil)
(setq bdd 1) 
(setq b 1)
(setq l (fix (strlen chuoi)))
(repeat l
(setq a (substr chuoi b 1))
(cond
((= a kytu) 
(setq dkt (substr chuoi bdd (- b bdd)))
(setq lkq (append lkq (list dkt)))
(setq bdd (+ b 1)) 
)
)
(setq b (+ b 1))
)
(setq dkt (substr chuoi bdd (+ (- l bdd) 1)))
(setq lkq (append lkq (list dkt)))
lkq)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:vmb ()
(setq matbich (getstring "\nNhap kich thuoc mat bich <Cao * Rong>"))
(setq daimatbich (atoi (car (duy:xd_listngngancach<kytu matbich "*"))))
(setq rongmatbich (atoi (cadr (duy:xd_listngngancach<kytu matbich "*"))))
(setq diemve (getpoint "Diem tren ben trai mat bich"))
(command ".RECTANG" "_non" diemve "_non" (list (+ (car diemve) rongmatbich) (- (cadr diemve) daimatbich)) )
(or canhngang (setq canhngang 100))
(setq canhngang (cond ((getreal (strcat "\nKhoang cach ngang giua 2 cot bolon < " (rtos canhngang 2 2) " >:")))(canhngang)))
(setq bulong (getstring "\nNhap khoang cach doc tinh tu tren xuong <khoang1 + khoang2 +...+ khoangn"))
(setq khoangbulong (duy:xd_listngngancach<kytu bulong "+"))
(setq khoangvebulong 0.0)
(foreach khoangbulonghh khoangbulong 
(setq khoangvebulong (+ khoangvebulong  (atoi khoangbulonghh)))
(command ".insert" "BU LONG" "_non"  (list (+ (+ (car diemve) (/ rongmatbich 2)) (/ canhngang 2)) (- (cadr diemve) khoangvebulong)) 0.01 0.01 0)
(command ".insert" "BU LONG" "_non"  (list (- (+ (car diemve) (/ rongmatbich 2)) (/ canhngang 2)) (- (cadr diemve) khoangvebulong)) 0.01 0.01 0)
)
(princ)
)

Đây là lsp được ứng dụng nhiều trong lĩnh vực cơ khí, tuy nhiên nếu ứng dụng lsp trong trong  bv bất kì(không có block "bulong" sẵn) thì lsp không chạy được. Nếu bạn thêm chọn luôn chọn đường kính nữa thì tuyệt lắm! 

 
 
 

<<

Filename: 388681_vmb.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 74501
Tên lệnh: shbv
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
Các bạn cho mình hỏi. Trong lisp muốn sử dụng dấu cách thì phải thể hiện như thế nào. Cảm ơn tất cả.

Cụ thể trong lisp dưới đây (lisp đánh số hiệu bản...

>>
Các bạn cho mình hỏi. Trong lisp muốn sử dụng dấu cách thì phải thể hiện như thế nào. Cảm ơn tất cả.

Cụ thể trong lisp dưới đây (lisp đánh số hiệu bản vẽ - VD: KT:01/1; CN:01/1)

Mình muốn giữa ký tự chữ và số có dấu cách (KT: 01/1; CN: 01/1)

Đây là lisp:

;; copyright by Tue_NV
(defun c:shbv(/ dau tong po po1 ent i pre cao)
(prompt "\n Danh so hieu ban ve dang n/m ")
(setvar "cmdecho" 0)

(command "style" "CADVIET" "Vhelven.TTF" "2" "1" "0" "n" "n")
(setq cao (getreal "\n Nhap chieu cao chu :"))
(setq pre (getstring 5"\n Nhap ky hieu ban ve : "))
(setq dau (getint "\n Danh so bat dau (n):"))
(setq tong (getint "\n Danh so tong (m):") i 1)

(setq po (getpoint 
(strcat "\n Cho diem chen cua so: " (if ((wtxt (strcat (if (
(Repeat (- tong dau)
(setq po1 (getpoint po 
(strcat "\n Cho diem chen cua so: " (if (
(command "copy" "L" "" po po1) 
(setq ent (entget(entlast)))
(setq ent 
(subst 
(cons 1 (strcat (if ((entmod ent)
(setq i (1+ i))
(setq po po1)
)
(princ)
)
;
(defun wtxt (txt p / sty d h)
(setq sty (getvar "textstyle")
d (tblsearch "style" sty)
h (cdr (assoc 40 d)))
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 11 p) 
(cons 72 1) (cons 73 2)
(if (> h 0) (cons 40 h) (assoc 40 d)) (assoc 41 d))
)
)

Chào bạn HoangSon 614,

Việc thêm các khoảng trắng vào trong chuỗi chỉ đơn giản là bạn thêm một chuỗi chứa khoảng trắng " " vào chỗ bạn muốn thêm mà thôi.

Trong lisp bạn gửi giá trị của chuỗi là do hàm (strcat pre "0" (itoa dau)) (itoa dau)) "/" (itoa tong)) tạo ra. Do vậy để thêm khoảng trắng vào giữa ký tự chữ và số như bạn mô tả tức là thêm chuỗi chứa khoảng trắng vào giữa biến pre và chuỗi "0". Có hai cách làm

a/- Thay chuỗi "0" bằng chuỗi " 0" (có chứa một khoảng trắng trước số 0)

b/- Thêm chuỗi " " (chuỗi chứa khoảng trắng) vào trứơc chuỗi "0"

 

Thực ra mình chưa hiểu bạn làm vậy để làm chi vì trong biến pre của bác Tue_NV đã có chứa một khoảng trắng sau dấu hai chấm rồi mà, chả nhẽ bạn lại muốn cho nó cách xa ra tí nữa à???

 

Chúc bạn thành công.


<<

Filename: 74501_shbv.lsp
Tác giả: quan_elec
Bài viết gốc: 96012
Tên lệnh: tag link
viết lisp thống kê bản vẽ
Bạn dùng nút Up - Down để sắp xếp theo thứ tư mong muốn.

Gửi Tue_NV Lisp tạo Link field thuộc tính đầu...

>>
Bạn dùng nút Up - Down để sắp xếp theo thứ tư mong muốn.

Gửi Tue_NV Lisp tạo Link field thuộc tính đầu tiên của Block Att

(defun C:Tag_link(/ att att1 blk_name ent field i obj obj1 source ss ss1)
;|  By : Gia Bach, gia_bach @  www.CadViet.com             |;
 (princ "\nChon Block thuoc tinh nguon :" )
 (if (setq ss1 (ssget "+.:S:N" (list (cons 0 "INSERT")(cons 66 1))))
   (progn
     (setq source (ssname ss1 0)
    blk_name (cdr (assoc 2 (entget source))))
     (princ "\nChon Block thuoc tinh can Link :" )
     (if (setq ss (ssget (list (cons 0 "INSERT")(cons 2 blk_name)(cons 66 1))))
(progn
  (setq i -1
	obj1 (vlax-Ename->Vla-Object source)
	Att1 (car (append (vlax-invoke Obj1 'GetAttributes)
			  (vlax-invoke Obj1 'GetConstantAttributes)))
	field (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-Objectid Att1)) ">%).TextString>%"))
  (while (setq ent (ssname ss (setq i (1+ i))))
    (setq obj (vlax-Ename->Vla-Object ent)
	  Att (car (append (vlax-invoke Obj 'GetAttributes)
			   (vlax-invoke Obj 'GetConstantAttributes))) )
    (vla-put-TextString Att field) ) ))
     (vl-cmdf "regen" ) ))
 (princ))

Chào bác Gia_bach và Tue_NV , lại làm phiền 2 bác nữa rồi . Lisp truy xuất thuộc tính Block của bác Gia_bach có lỗi về sắp xếp thứ tự khi truy xuất . 2 bác xem qua bản vẽ theo link sau nhé http://www.mediafire.com/?wnq22qmc0nm .Cám ơn 2 bác trước , hii :rolleyes:


<<

Filename: 96012_tag_link.lsp
Tác giả: laivanyen
Bài viết gốc: 122524
Tên lệnh: srt
Lisp cộng - trừ - nhân - chia 2 hàng số cho ra hàng thứ 3
Cái này mình viết hồi mới tập tọe Lisp, dùng có mấy lần rồi chẳng bao giờ dùng nữa. có thể có những lỗi người viết không lường trước vì hồi đó còn...
>>
Cái này mình viết hồi mới tập tọe Lisp, dùng có mấy lần rồi chẳng bao giờ dùng nữa. có thể có những lỗi người viết không lường trước vì hồi đó còn gà. Nếu dùng nó gặp lỗi gì thì thông báo lại để mình sửa.

;===========================================================================
(prompt"\nCmd:SRT-  by Thaistreetz - huuthais@yahoo.com\n")
;===========================================================================
(defun c:srt (/ cmd ss lst data i lst1 lst2)
(setq ctnc (cond (ctnc) ("Cong")))
(initget "Cong Tru Nhan CHia")
(setq ctnc (cond ((getkword (strcat "\nChon phep tinh:  <" ctnc ">"))) (ctnc)))
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "ucs" "world")
(prompt"\nChon hang-cot text thu nhat\n")
(if (setq ss1 (ssget (list (cons 0 "TEXT"))))
(progn
(setq lst1 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1))))
		   '(lambda (x y) (if (equal (car(setq x1 (cdr (assoc 10 x)))) (car(setq y1 (cdr (assoc 10 y)))))
				      (> (cadr x1) (cadr y1)) (< (car x1) (car y1))))))))
(prompt"\nChon hang-cot text thu 2\n")
(if (setq ss2 (ssget (list (cons 0 "TEXT"))))
(if (< (- (cadr (cdr(assoc 10 (nth 0 lst1)))) (cadr (cdr(assoc 10 (nth 1 lst1))))) 
                (- (car (cdr(assoc 10 (nth 1 lst1)))) (car (cdr(assoc 10 (nth 0 lst1))))))
	(setq lst2 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
                       '(lambda (x y) (if (equal (car(setq x2 (cdr (assoc 10 x)))) (car(setq y2 (cdr (assoc 10 y)))))
                        (> (cadr x2) (cadr y2))  (< (car x2) (car y2))))))
	(setq lst2 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
                       '(lambda (x y) (if (equal (car(setq x2 (cdr (assoc 10 x)))) (car(setq y2 (cdr (assoc 10 y)))))
                        (< (cadr x2) (cadr y2)) (> (car x2) (car y2))))))
	))
(if (/= (sslength ss2) (sslength ss1)) (alert "\n    Hai tap hop text co so \ndoi tuong khong bang nhau!")
(progn
 (setq ptkq (getpoint "\nChon diem ghi ket qua hoac enter de ghi ket qua vao hang-cot text khac\n"))
 (if (= ptkq nil) 
 (progn
(prompt"\nChon hang-cot text ghi ket qua\n")
(if (setq ss3 (ssget (list (cons 0 "TEXT"))))
(progn
(setq lst3 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss3))))
		   '(lambda (x y) (if (equal (car(setq x3 (cdr (assoc 10 x)))) (car(setq y3 (cdr (assoc 10 y)))))
				      (> (cadr x3) (cadr y3))  (< (car x3) (car y3))))))))
(if (/= (sslength ss2) (sslength ss3)) (alert "\nTap hop text ghi ket qua \nthua hoac thieu doi tuong!"))
 );progn
 );if
);progn
);if
;----------------------------------
(command "undo" "be")
(setq angbs (getvar "angbase"))
(setq oldos (getvar "osmode"))
(setq Ladim (getvar "Dimzin"))
(setq olstyle (getvar "textstyle"))
(setq olcol (getvar "CEColor"))
(setvar "Dimzin" 0)
(setq txti 0)

(while (< txti (sslength ss1))
(if (eq ctnc "Cong") (setq kqi (+ (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if (eq ctnc "Tru")  (setq kqi (- (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if (eq ctnc "Nhan") (setq kqi (* (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if (eq ctnc "CHia") (setq kqi (/ (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if ptkq
 (progn
 (if (< (- (cadr (cdr(assoc 10 (nth 0 lst1)))) (cadr (cdr(assoc 10 (nth 1 lst1))))) 
    (- (car (cdr(assoc 10 (nth 1 lst1)))) (car (cdr(assoc 10 (nth 0 lst1)))))) 
 (setq ptkqi (list (car (cdr(assoc 10 (nth txti lst1)))) (cadr ptkq)))
 (setq ptkqi (list (car ptkq) (cadr (cdr(assoc 10 (nth txti lst1)))))))
 (command "textstyle" (cdr(assoc 7 (nth txti lst1))) "osmode" 0 "angbase" 0 "color" 1)
 (command "text" ptkqi (cdr(assoc 40 (nth txti lst1))) (/ (* 180 (cdr(assoc 50 (nth txti lst1)))) pi) (rtos kqi 2 2))
 );progn
 (entmod (subst (cons 1 (rtos kqi 2 2)) (assoc 1 (nth txti lst3)) (nth txti lst3)))
);if
(setq txti (1+ txti))
);while
;----------------------------------
(command "ucs" "p")
(setvar "textstyle" olstyle)
(setvar "Dimzin" Ladim)
(setvar "CECOLOR" olcol) 
(setvar "angbase" angbs)
(setvar "osmode" oldos)
(command "undo" "e")
(setvar "cmdecho" cmd)
(princ)
)

 

Tiện Bác giúp em viết lisp co yêu cầu như sau ạ:

 

Khi em lấy bản vẽ mẫu để chỉnh sửa thì các Hatch bản vẽ mẫu không có ASSOCIATIVE nên khi em Stretch co kéo thường phải bỏ Hatch và hach lại. Bác giúp em làm sao để Hatch cũ có chế độ ASSOCIATIVE để Stretch thì Hatch theo luôn ạ !


<<

Filename: 122524_srt.lsp
Tác giả: pphung183
Bài viết gốc: 388342
Tên lệnh: tdt tcd
Đo tổng chiều dài đối tượng trên Autocad 2015

 

Tình hình là sau khi thay dòng lệnh như bác pphung183 thì ok rồi. Em cảm ơn bác nhiều nhé.

Em up lại để mọi người...

>>

 

Tình hình là sau khi thay dòng lệnh như bác pphung183 thì ok rồi. Em cảm ơn bác nhiều nhé.

Em up lại để mọi người dùng

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/120974-nho-sua-lisp-do-tong-chieu-da-i-doi-tuong-tra-n-autocad-2015/page-2
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/59317-nho-chi-nh-su-a-lisp-ti-nh-to-ng-die-n-ti-ch-va-chu-vi-ca-c-hi-nh/
(defun c:tdt(/ dt sdt gt tgt id pt1)
  (setq dt (ssget
  	'((-4 . "<OR")
   (0 . "CIRCLE")
   (0 . "*POLYLINE")
   (-4 . "OR>")
     	))
 )
  (setq
 sdt (sslength dt)
 id 0
 tgt 0)
(testcaochu)
  (repeat sdt
	(setq ent (ssname dt id)
   id (1+ id)
   )
	(command "area" "o" ent "")
	(setq gt (getvar "area"))
	(setq tgt (+ tgt gt))
	(princ)
	)
(setq pt1 (getpoint "\nchon diem ghi chu:"))
  (command "text" "j" "mc" pt1 (rtos caochu) "0" (strcat(rtos (/ tgt 1000000) 2 1) "m2"))
  (princ)
  )
;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:tcd(/ DT SDT TCD PT1)
  (setq dt (ssget '((-4 . "<OR")
   (0 . "CIRCLE")
   (0 . "ELLIPSE")
   (0 . "SPLINE")
   (0 . "ARC")
   (0 . "LINE")
   (0 . "*POLYLINE")
   (-4 . "OR>")
		))
)
(testcaochu)
  (setq sdt (sslength dt))
  (setq
  	index 0
  	tcd 0
  	)
  (repeat sdt
	(setq
  	ent (ssname dt index)
  	index (1+ index)    
  	)    
	(command "area" "o" ent)
	(setq cd (getvar "perimeter"))
	(setq tcd (+ tcd cd))
	)
  (setq pt1 (getpoint "\nchon diem ghi chu:"))
  (command "text" "j" "mc" pt1 (rtos caochu) "0" (strcat(rtos (/ tcd 1000) 2 1) "m"))
  (princ)
  )
;;;;;;;;;;;;;;;;;;
(defun testcaochu()
  (if (not caochu1)
	(setq caochu (getdist "\nchieu cao chu? :"))
	(setq caochu (getdist (strcat "chieu cao chu <" (rtos caochu1) ">:")))
	)
  (if (= caochu nil) (setq caochu caochu1))
  (setq caochu1 caochu)

Trời  :unsure:  !!!! Tôi bảo bạn thay (command "lengthen" ent "") bằng (command "area" "o" ent)  để biết có phải vậy không chứ không phải thay là dùng -_- .

Muốn dùng thì phải xét thêm các trường hợp không có diện tích như Line, arc chẳng hạn ...Because khi đối tượng là Line or arc thì (command "area" "o" ent)

trả về Nil và (getvar "perimeter") trả vể thông số chu vi không phải của Line or arc và kết quả sẽ sai :D


<<

Filename: 388342_tdt_tcd.lsp
Tác giả: toai
Bài viết gốc: 69938
Tên lệnh: ckc
LISP tự động cộng liên tiếp khoảng cách giữa các điểm bất kỳ
Xin lỗi bạn, code trên Tue_NV nhầm, xin chỉnh lại :

(defun c:ckc()
(setq po1 (getpoint "\n Pick diem A :"))
(setq po2 (getpoint po1 "\n Pick diem B :"))
(setq po3 (getpoint...
>>
Xin lỗi bạn, code trên Tue_NV nhầm, xin chỉnh lại :

(defun c:ckc()
(setq po1 (getpoint "\n Pick diem A :"))
(setq po2 (getpoint po1 "\n Pick diem B :"))
(setq po3 (getpoint po2 "\n Pick diem C :"))
(setq S (+ (distance po1 po2) (distance po2 po3)))
(while 
(setq po4 (getpoint po3 "\n Pick diem tiep theo de tinh khoang cach/ Enter de ket thuc :"))
(setq S (+ S (distance po3 po4)) po3 po4)
)
(alert (strcat "Tong S = " (rtos S)))
(princ)
)

Các bác ơi, nếu đoạn code trên được bổ sung thêm tính năng ghi kết quả đo ra bản vẽ thì sẽ càng tiện lợi hơn. Tôi có ý kiến như vậy thì khác gì nhờ giúp đỡ rồi đúng không ạ? :bigsmile:


<<

Filename: 69938_ckc.lsp
Tác giả: hoangkimoanh
Bài viết gốc: 280462
Tên lệnh: cpi
lisp copy text tăng dần

Không can thiệp nội dung

(defun c:CPI (/ Block ent Numtext Blk Symbol sym ans pt1 pt2 gr code data NewObj end)
;;; pBe 23 June 2012...
>>

Không can thiệp nội dung

(defun c:CPI (/ Block ent Numtext Blk Symbol sym ans pt1 pt2 gr code data NewObj end)
;;; pBe 23 June 2012 ;;;
;;;http://forums.autode.../3507198/page/2	;;;

(setvar 'cmdecho 0)
(prompt "\rSelect Block/Text:")
(cond
	((and
		(setq Block (ssget "_+.:S:L" '((0 . "INSERT,*TEXT"))))
		(setq Block (ssname Block 0))
		(setq NumText
			(if 
				(and 
					(eq (cdr (assoc 0(entget Block)))"INSERT")
					(setq Blk (member '(66 . 1)(entget Block)))
				)
				(cdr (assoc 1 (entget (entnext Block))))
				(cdr (assoc 1 (entget Block)))
			)
		)
(progn
	(if (not Symbol)(setq Symbol "+"))
	(initget "+ -")
	(setq Symbol
		(cond	((getkword	(strcat "\nChoose : <" Symbol ">: ")))
		(Symbol))
	)
	(initget "Y N")
	(setq ans (cond ( (getkword "\nPrefix  <No>: ") ) ( "N" )))
)
(setq sym (eval (read symbol)))
(setq ent (vlax-ename->vla-object Block))
(setq end nil pt1 (vlax-get ent 'insertionpoint))
(setq NewObj (vla-copy ent))
(while (null end)
(while
(progn
	(prompt "\rPick Next Point/Press  / Right Click to Increase / Any key to Exit")
	(setq gr (grread t 15 0)
	code (car gr)
	data (cadr gr)
)
(cond
((= 5 code)
(vlax-invoke NewObj 'Move pt1 (setq pt2 data))
(setq pt1 pt2))
((= 2 code)
(setq sym (cond
((= data 43) +)
((= data 45) -)
((= data 61) *)
((setq end T) (entdel (entlast)))))
nil)
((= 3 code)
(vlax-invoke NewObj 'Move pt1 (setq pt2 data))
(vla-put-textstring
(if (not Blk)
NewObj
(car (vlax-invoke
NewObj
'GetAttributes))
)
(progn
(setq NumText
(itoa (eval (sym (atoi Numtext) 1
))))
(if (and (< (strlen NumText) 2)
(eq ans "Y"))
(strcat "0" NumText)
Numtext)
)
)
(setq ent NewObj)
(setq NewObj (vla-copy ent))

nil)
((= 25 code)(setq NumText (itoa (1+ (atoi NumText)))))
)
)
)
)
)
)
)
(princ)
)

anh ketxu ơi, trong phần này anh giúp em là pick chuột phải để tăng nhưng sao em pick chuột phải nó không có tác dụng tăng mà nó cứ ì ra đấy nhỉ, pick chuột trái nó lại vẫn là số tăng tiếp theo của số cũ!


<<

Filename: 280462_cpi.lsp
Tác giả: Hoangvulandscape
Bài viết gốc: 153335
Tên lệnh: tkh
Lisp thống kê diện tích Hatch theo Layer

Yêu cầu đã được chấp thuận ^^. Nếu có Express Tool trong CAD bạn có thể dùng bản này, trau chuốt hơn 1 tí ^^ Cho phép đặt kết quả tại...

>>

Yêu cầu đã được chấp thuận ^^. Nếu có Express Tool trong CAD bạn có thể dùng bản này, trau chuốt hơn 1 tí ^^ Cho phép đặt kết quả tại chỗ tùy ý để bạn tiện ghi chú

 

(defun c:tkh (/ lst msp pt ss lay ar txtsiz pt)
 (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
 (progn  
 (vl-load-com)
 (acet-sysvar-set (list "cmdecho" 0))
 (grtext -1 "S\U+01A1n T\U+00F9ng' Lisp")
 (Princ "\nCh\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Hatch \U+0111\U+1EC3 t\U+00EDnh di\U+1EC7n t\U+00EDch :  ")
 (if (setq ss (ssget(list (cons 0 "HATCH"))))
   (progn
     (foreach e (mapcar 'vlax-ename->vla-object (st-ss->ent ss))
	(setq lay (vlax-get-property e 'Layer))	
       (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area (list e))))
		(setq ar (*  0.000001 (vlax-get-property e 'Area)))
		(progn
			(setq ar 0)(princ (strcat "\nC\U+00F3 Hatch thu\U+1ED9c layer " lay " kh\U+00F4ng t\U+00EDnh \U+0111\U+01B0\U+1EE3c di\U+1EC7n t\U+00EDch.\n\U+0110\U+00E3 highlight v\U+00E0 t\U+00EDnh di\U+1EC7n t\U+00EDch b\U+1EB1ng 0"))
			(redraw (vlax-vla-object->ename e) 3)
		)
	)			
       (if (not (assoc lay lst))
         (setq lst (cons (cons lay ar) lst))
         (setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
                          (assoc lay lst) lst))))
     (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))            
           txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
           msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) i -1)
     (while (setq e (nth (setq i (1+ i)) lst))		
       (vla-addtext msp (strcat (car e) " : " (rtos (cdr e) 2 2) "m2") (vlax-3d-point '(0 0 0)) txtsiz)
	(setq pt (ACET-SS-DRAG-MOVE (ssadd (entlast)) '(0 0 0) (strcat "\n\U+0110i\U+1EC3m \U+0111\U+1EB7t ghi ch\U+00FA t\U+1ED5ng di\U+1EC7n t\U+00EDch Hatch thu\U+1ED9c layer " (car e))))
	(command ".move" (entlast) "" '(0 0 0) pt)
	)
		(princ "\n\U+0110\U+00E3 th\U+1EF1c hi\U+1EC7n xong !")
)
   (alert "Kh\U+00F4ng c\U+00F3 Hatch n\U+00E0o \U+0111\U+01B0\U+1EE3c ch\U+1ECDn !"))
)
(alert "Phi\U+00EAn b\U+1EA3n CAD c\U+1EE7a b\U+1EA1n kh\U+00F4ng h\U+1ED7 tr\U+1EE3 t\U+00EDnh di\U+1EC7n t\U+00EDch Hatch !")
)
 (acet-sysvar-restore)(princ))
 (defun st-ss->ent	(ss / n e l)
 (setq n -1)
 (while (setq e (ssname ss (setq n (1+ n))))
   (setq l (cons e l))
 )
)

 

Lại làm phiền các bạn nữa rồi. Lisp xài rất ổn tuy nhiên khi sử dụng lại nảy sinh một vấn đề nho nhỏ. Đó là ra text Diện tích rồi thì khi mình Move vào gắn trên các Leader (chỉ vào mảng Hatch) thì rất khó để canh chỉnh cho đều được, nên rất lâu.

Mình hy vọng lisp này có thể sửa thêm thành 1 bản có tính năng chọn vào text có sẵn khi ra diện tích (giống như cái lisp udt.lisp vậy). Khi đó mình có thể click vào các text có sẵn của Qleader thì sẽ rất sễ dàng chỉnh sửa, định dạng.

Mong các bạn giúp đỡ mình hén. Xin Cảm ơn trước!


<<

Filename: 153335_tkh.lsp
Tác giả: phuongkq
Bài viết gốc: 185060
Tên lệnh: btk
Đo chiều dài và ghi ra text

Hề hề hề,

Không biết cái này đã vừa ý bạn chưa?? Cần nhắc lại để bạn nhớ là cái yêu cầu của bạn hoàn toàn...

>>

Hề hề hề,

Không biết cái này đã vừa ý bạn chưa?? Cần nhắc lại để bạn nhớ là cái yêu cầu của bạn hoàn toàn khác với yêu cầu của bạn chủ thớt nên mình không thể cải chỉnh cái lisp của bác Ketxu cho bạn mà phải cấu trúc lại lisp mới. nếu bạn không post file dwg lên thì chắc hẳn sẽ có nhiều người lầm lẫn và sẽ phải làm đi làm lại mà vẫn không thể như ý bạn được. bạn hãy rút kinh nghiệm cho các lần post bài sau nhé.

Chúc bạn vui.

Đây là code:


(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 plst (list)  i 0)
(alert "\n Chon cac doan can thong ke")
(setq e  (entsel "\n Chon doan can thong ke"))
(While e
       (setq plst (cons e plst)
                 e (entsel "\n Chon doan tiep theo")
       )
)
(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)
  )
)
(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)
  	)
)
(close fw)
(command "undo" "e")
(princ)
)

(defun styleset ()
(setq stl (getvar "textstyle")
		h (getvar "textsize"))
(if (/= h 0) (command "style" stl "" 0 "" "" "" "" ""))
)                  

Hề hề hề.

Cám ơn anh rất nhiều, Lisp này em dùng thử thấy có một số điểm đó là điểm thứ 11 tọa độ bị lỗi , nhờ anh kiểm tra giúp em với nhé. Thanks you very much

 

Nhưng khi bắt điểm theo thứ tự đoạn D1->D2->D3->D4->D5->D6->D7->D8->D9->D10->D11->D12->D13 thì bị lỗi đoạn thứ 11 (tức là D11 theo hình vẽ) . Còn khi bắt điểm theo thứ tự không lần lượt theo cách chọn đoạn D1->D2->D3->D9->D10->D11->D12->D13 thì cũng bị lỗi đoạn thứ 7 (cũng tức là D11 theo hình vẽ), và bảng xuất ra bị xô lệch như của bạn sumi gặp phải.

 

Anh có thể xem lại một chút không?

Theo em thấy hình như khi chọn đoạn gặp đường cung tròn ở chỗ này thì có vẻ tọa độ bị sai ạ.


<<

Filename: 185060_btk.lsp
Tác giả: hoavien248
Bài viết gốc: 186740
Tên lệnh: dimblk
Lisp dim các block không thẳng hàng!

Bác PTB xui quá, lần nào up bài thì CV cũng bị lỗi. Tôi sửa giùm cho bác luôn để giúp bạn Hoavien nhé!

@Hoavien: dùng lisp sửa...

>>

Bác PTB xui quá, lần nào up bài thì CV cũng bị lỗi. Tôi sửa giùm cho bác luôn để giúp bạn Hoavien nhé!

@Hoavien: dùng lisp sửa lỗi của bác ấy xem sao.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=61313
(defun c:dimblk (/ bln pln h ssbl i p1 p2)
(vl-load-com)
(command "undo" "be")
(acet-sysvar-set (list "osmode" 0 "cmdecho" 0))
(defun tamblk ( blken / p1 p2)
(setq p1 (car (acet-ent-geomextents blken))
     	p2 (cadr (acet-ent-geomextents blken))
     	pt (mapcar '(lambda (x y) (/ (+ x y) 2)) p1 p2)
)
pt
)
(setq bln (cdr (assoc 2 (entget (car (entsel "\n Chon block mau can dim")))))
	pln (vlax-ename->vla-object (car (entsel "\n Chon polyline dan ")))
     	h (getreal "\n Nhap khoang cach toi duong dat kich thuoc: ")
	ssbl (vl-sort (acet-ss-to-list (ssget (list (cons 0 "insert") (cons 2 bln))))
                			'(lambda (x y) (> (vlax-curve-getparamatpoint pln (vlax-curve-getclosestpointto pln (cdr (assoc 10 (entget x)))))
                                                                  		(vlax-curve-getparamatpoint pln (vlax-curve-getclosestpointto pln (cdr (assoc 10 (entget y)))))
                                        			)
                			)
             	)
)
(foreach en ssbl
  	(setq i (vl-position en ssbl)
    			p1 (tamblk en)
    			p2 (if (setq en1 (nth (1+ i) ssbl)) (tamblk en1))
  	)
  	(if p2
  	(command "dimaligned" p1 p2  (polar p1 (+ (angle p1 p2) (/ pi 2)) h))
  	)
)
(acet-sysvar-restore)
(command "undo" "e")
(princ)
)

Đúng như ý mình,thanks các bác đã nhiệt tình giúp đỡ,chúc tất cả anh em thành công trong công việc.


<<

Filename: 186740_dimblk.lsp
Tác giả: DanKhaosat
Bài viết gốc: 257335
Tên lệnh: rft
lisp Phun tọa độ các điểm từ file txt vào CAD

 

Có bác nào giúp em chỉnh sửa lisp của bác Gia_Bach >>

 

Có bác nào giúp em chỉnh sửa lisp của bác Gia_Bach http://www.cadviet.c.../80142_rft2.lsp

;; free lisp from cadviet.com
(defun c:RFT(/ data f h line pt pXY spc str ten val);Read File Txt
  ;|  By : Gia Bach, gia_bach @  www.CadViet.com 			|;  
  (vl-load-com)
  (defun Split (Str Char / Lst pos)
	(while (setq pos (vl-string-search Char Str))
  	(if (null Lst)
(setq Lst (list (substr Str 1 pos)))
(setq Lst (append Lst (list (read (substr Str 1 pos))))))
  	(setq Str (substr Str (+ pos 2)) ))
	(setq Lst (append Lst (list (read Str)))))
 
  (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" "") )
  	(setq spc (vla-get-ModelSpace (vla-get-ActiveDocument(vlax-get-Acad-Object))))
  	(setq h 2);(* (getvar "dimtxt")(getvar "dimscale")))
  	(setq f (open (findfile ten) "r"))
  	(while (setq Line (read-line f))
(if (vl-string-search "\t" Line)
   (progn
	(setq data (split Line "\t" )
	val (car data)
	pt  (cdr data))
	(if (not(vl-catch-all-error-p (vl-catch-all-apply 'vlax-3d-point pt)))
   	(progn
  (setq pXY (list (car pt)(cadr pt)))
  (vla-put-Layer (vla-addpoint spc (vlax-3d-point pXY)) "Point")
  (vla-put-Layer (setq str (vla-addtext spc val (vlax-3d-point pXY) h)) "Sothutu")
  (vla-put-Alignment str 8)
  (vla-put-TextAlignmentPoint str (vlax-3d-point pXY))
  (vla-put-Layer (vla-addtext spc (caddr pt) (vlax-3d-point pXY) h) "Caodo") )))))  ))
  (princ))
với yêu cầu:

- File text dạng : SST,Y,X,Z,Code

- Độ cao Z có dấu chấm ở hàng thập phân nằm đúng vào vị trí tọa độ (X,Y) của điểm đó .

Em xin cảm ơn trước.

Bạn ơi bạn có thể sửa để chạy ra

1. Layer: point

2. Layer: docao

3. Layer: madiem

4. Layer Tendiem

với số liệu thứ tự:

1.Tendiem          2. Tọa dộ X        3. Tọa dộ Y        4. Độ cao  H     5. Mã điểm

I-1_A=              2482493.792       417021.870         167.751            II-1

I-1_A=    2482493.792    417021.875    167.748    II-1

I-1_2    2482454.002    416964.167    175.394    ?

I-1_3    2482449.684    416963.618    173.798    ?

I-1_4    2482447.597    416959.881    175.082    ?

I-1_5    2482380.325    416886.284    167.977    S

I-1_6    2482360.346    416888.805    168.130    S

I-1_7    2482367.507    416866.060    169.516    Shttp://www.cadviet.com/upfiles/3/123341_a_1.rar


<<

Filename: 257335_rft.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 360659
Tên lệnh: dopl
Lisp đo khoảng cách các điểm trên polyline

 

Quick code:

(defun c:dopl()
  (setq i 0)
  
  (if (setq e (car(entsel "\n Chon Pline : ")))
     (progn
   ...
>>

 

Quick code:

(defun c:dopl()
  (setq i 0)
  
  (if (setq e (car(entsel "\n Chon Pline : ")))
     (progn
       (setq obj (vlax-ename->vla-object e))
       (if (= 0 (vla-GetBulge obj i)) 
  (command "._dimlinear" "_non" (vlax-curve-getstartpoint e) "_non" (vlax-curve-getpointatparam e (1+ i))
   "_non" pause)
  (command "._dimarc" (vlax-curve-getpointatparam e (+ i 0.5)) "_non" pause)
       )
       (setq i (1+ i) ddat (cdr(assoc 10 (entget (entlast)))) dis (distance ddat (vlax-curve-getclosestpointto e ddat)))
       (Repeat (1- (fix (vlax-curve-getEndParam e)))
 (if (= 0 (vla-GetBulge obj i))
    (command "._dimlinear" "_non" (vlax-curve-getpointatparam e i) "_non" (vlax-curve-getpointatparam e (1+ i))
     "_non" (polar (vlax-curve-getpointatparam e (+ i 0.5)) (- (angle '(0 0 0) (vlax-curve-getFirstDeriv e (+ i 0.5))) (/ pi 2.0)) dis))
    (command "._dimarc" (vlax-curve-getpointatparam e (+ i 0.5))
     "_non" (polar (vlax-curve-getpointatparam e (+ i 0.5)) (- (angle '(0 0 0) (vlax-curve-getFirstDeriv e (+ i 0.5))) (/ pi 2.0)) dis))
          )
 (setq i (1+ i) ddat (cdr(assoc 10 (entget (entlast)))) )
       )
   )
   )
 )

Các ơn Bác đã quan tâm đã text nhưng còn 1 vướng mắc có cái đo được có cái đo không được. Qua những lần text phát hiện điểm đặt của dim ở gần polyline thì được (điểm đặt này còn phụ thuộc vào chiều dài đoạn đo)


<<

Filename: 360659_dopl.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 428729
Tên lệnh: cdthep
Các pro giúp e! LISP Tính tổng dim và paste giá trị vào block attribute
40 phút trước, quocmanh04tt đã nói:

Dùng...

>>
40 phút trước, quocmanh04tt đã nói:

Dùng nentsel.

Làm thử cái xem sao

(Defun c:cdthep(/ oldos s dtltc thongtin giatricu giatrimoi)
(setq oldos (getvar "OSMODE")) 
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(setq dtltc (car (entsel "\nChon doi tuong pline.")))
(Command "area" "o" dtltc)
(setq s (getvar "PERIMETER"))
(setq thongtin (entget (car (nentsel "\nChon text trong block can thay the."))))
(setq giatricu (assoc 1 thongtin))
(setq giatrimoi (cons 1 (rtos s 2 2)))
(setq thongtin (subst giatrimoi giatricu thongtin))
(entmod thongtin)
(setvar "osmode" oldos)
(princ)
)

 


<<

Filename: 428729_cdthep.lsp
Tác giả: thanhduan2407
Bài viết gốc: 123282
Tên lệnh: ft
Căn lề text + Mtext, Căn lề đối tượng
Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật...
>>
Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật Bổn, mót được cái này,e liền làm thử bài đánh giá, thấy tốc độ khá tốt, các bác thử chém gió xem sao, và vì code dài nên e cũng chẳng hiểu tại sao ^^

 

Mạn phép bác Thái,E xin post lại lisp ft của bác, thêm dòng check time :

 

(defun c:ft()
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq ollay (getvar "Clayer"))
(setq olstyle (getvar "textstyle"))
(setq TB  (textbox mau) LC  (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq h (cdr(assoc 40 mau)))
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5) (* -0.03 h)) (cadr x1)))
(setq x3 (list (+ (car x1) di (* -0.06 h)) (cadr x1)))
(setq canle (cond (canle) ("Left")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le <" canle ">"))) (canle)))
(setq oldang (getvar "Angbase"))
(command "angbase" 0 "ucs" "w")

(setq time (getvar "MILLISECS"))

(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" 0 txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(command "ucs" "p")
(setvar "textstyle" olstyle)
(setvar "angbase" oldang)
(setvar "Clayer" ollay)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")

(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))

(prompt"\nText da duoc sap xep lai\n")
(command "undo" "end")
);defun

 

Bên dưới là code khác,dài hơn,cũng với chức năng tương tự (và đổi Insert point của text) :


(defun c:trai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Left and align to Left")					
(setq Value72_73_71  '(0 0 7))
(setq AssocL '(10 10))
(Procedure)
(princ)
)

(defun c:giua ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Center and align to Center")							
(setq Value72_73_71 '(1 0 8))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

(defun c:phai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)
(princ "\n Change Insetion point to Right and align to Right")							

(setq Value72_73_71 '(2 0 9))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

;***************************************************
(defun Procedure ()
(while (= ObjSet nil)
	(setq ObjSet (ssget '((-4 . ""))))
)
(setq ObjName0 (car (entsel "\n")))	
(setq i 0)
(setq time (getvar "MILLISECS"))
(repeat (sslength ObjSet)
	(setq ObjName (ssname ObjSet i))
	(setq Data (entget	ObjName))
	(cond 	((= (cdr(assoc 0 Data)) "TEXT")
				(TextInsP_Text ObjName Value72_73_71)	
				(setq Co (car AssocL))
			)
			(	(= (cdr(assoc 0 Data)) "MTEXT")		
				(TextInsP_MText ObjName Value72_73_71)	
				(setq Co (cadr AssocL))
			)
	)
	(setq i (1+ i))
)


(setq Data0 (entget ObjName0))
(setq Ang1 (angle '(0 0) (getvar "UCSXDIR")))
(cond 	((= (cdr(assoc 0 Data0)) "TEXT")
		(setq AngT (cdr(assoc 50 Data0)))				
		(setq Ang2 (- AngT Ang1))					
		(setq Co (car AssocL))
		)
		((= (cdr(assoc 0 Data0)) "MTEXT")
		(setq Ang2 (cdr(assoc 50 Data0)))			
		(setq AngT (+ Ang1 Ang2))					
		(setq Co (cadr AssocL))
		)
)
(setq Pt0 (cdr (assoc Co Data0)))		
(setq Pt0_U (trans Pt0 0 1))			
(setq Pt0_O (SD1862 Pt0_U Ang2))	

(setq i 0)
(repeat (sslength ObjSet)
	(setq Data (entget (setq ObjName (ssname ObjSet i))))
	(cond 	((= (cdr(assoc 0 Data)) "TEXT")(setq Co (car AssocL)))
			((= (cdr(assoc 0 Data)) "MTEXT")(setq Co (cadr AssocL)))
	)
	(setq Pt1 (cdr (assoc Co Data)))				
	(setq Pt1_U (trans Pt1 0 1))				
	(setq Pt1_O (SD1862 Pt1_U Ang2))		
	(setq Delta_O (- (car Pt0_O) (car Pt1_O)))		
	(setq Delta_U (SD8446 (list Delta_O 0) '(0 0) AngT))	
	(setq Data (subst (cons Co (mapcar '+ Pt1 Delta_U))(assoc Co Data) Data))		
	(entmod Data)
	(setq i (1+ i))
)
(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))	
(princ)
)
(defun TextInsP_Text ( ObjName Value72_73_71 / Data OrgPosition NewPosition Org_11 New_11 )

	(setq Data (entget	ObjName))				
	(setq OrgPosition (cdr (assoc 10 Data)))		
	(setq Org_11 (cdr (assoc 11 Data)))			
	(setq Data (subst (cons 72 (car Value72_73_71)) (assoc 72 Data) Data))
	(setq Data (subst (cons 73 (cadr Value72_73_71)) (assoc 73 Data) Data))
	(entmod Data)
	‚ª–³‚¢j
	(setq NewPosition (cdr (assoc 10 (entget  ObjName))))	
	(setq Delta (mapcar '- OrgPosition NewPosition))				
	(setq New_11 (mapcar '+ Org_11 Delta))		
	(setq Data (entget	ObjName))					
	(setq Data (subst (cons 11 New_11) (assoc 11 Data)	Data))	
	(entmod Data)
)
(defun TextInsP_MText ( ObjName Value72_73_71 / Data X_Old X_New Y_Old Y_New Scale Base0 W_42 Ang_50 Delta )
	(setq Data (entget	ObjName))
	(setq InsP (cdr (assoc 10 Data)))
	(setq W_42	(cdr (assoc 42 (entget ObjName))))
	(setq H_43	 	(cdr (assoc 43 (entget ObjName))))
	(setq Ang (cdr (assoc 50 Data)))		
	(setq AngU (angle '(0 0) (getvar "UCSXDIR")))	
	(setq OldIP (cdr (assoc 71 Data)))			
	(setq NewIP (caddr Value72_73_71))		

	(setq Data (subst (cons 71 NewIP) (assoc 71 Data) Data))
	(entmod Data)


	(setq X_Old (- (+ OldIP 2) (* (fix ( / (+ OldIP 2) 3)) 3)))
	(setq X_New (- (+ NewIP 2) (* (fix ( / (+ NewIP 2) 3)) 3)))


	(setq Y_Old (fix ( / (- OldIP 1) 3)))
	(setq Y_New (fix ( / (- NewIP 1) 3)))

	(setq IncUnit (list (- X_New X_Old)(- Y_Old Y_New )))
	(setq Delta (mapcar '* IncUnit (list (* 0.5 W_42)(* 0.5 H_43))))

	(setq Delta (SD8446 Delta '(0 0) Ang))

·
	(setq Delta (SD1862 Delta (* -1.0 AngU)))

	(setq Data (subst (cons 10 (mapcar '+ InsP Delta))(assoc 10 Data) Data))
	(entmod Data)

)

 

Tiếp theo, thực hiện test so sánh :

Lần 1: với 100 text và sắp xếp bên trái :

 

-> gần như là ngay tức thì

 

Lần 2, e chơi sang làm hẳn 1000 text + Mtext đi .Lần này thì :

 

- > :undecided:

 

Vậy là tương quan,2 lisp chênh nhau về thời gian xử lý khoảng 50 lần.Tất nhiên, ngoài thực tế ít khi ta gặp 1 đoạn văn bản CAD dài như vậy, nhưng nhiều khi, 1 vấn đề đã cũ,mà vẫn có nhiều lựa chọn giải quyết.

 

PS :Còn đoạn code FIT + code sắp xếp Đối tượng cũng khù khoằm như vậy,tí rỗi e post típ ^^

bạn ketxu rất hăng hái trong diễn đàn. Cảm ơn bài viết của bạn. Mình ủng hộ bạn


<<

Filename: 123282_ft.lsp
Tác giả: 790312
Bài viết gốc: 153928
Tên lệnh: wo
Lisp chỉnh style TEXT trong block thuộc tính

Tranh thủ thời gian mần luôn cái Lisp này cho bạn 790312 luôn

(defun c:wo( / ssdt sodt index tt entdt w sty h)  
 (setq ssdt...
>>

Tranh thủ thời gian mần luôn cái Lisp này cho bạn 790312 luôn

(defun c:wo( / ssdt sodt index tt entdt w sty h)  
 (setq ssdt (ssget '((0 . "INSERT") (66 . 1)))
sodt (sslength ssdt)
index 0
  )
 (or *w* (setq *w* 1.0))
 (setq w (getreal (strcat "\n Nhap be rong < " 
			(rtos *w* 2 2) " > :")))
 (if w (setq *w* w) (setq w *w*))
 (or *h* (setq *h* 5.0))
 (setq h (getreal (strcat "\n Nhap chieu cao < " 
			(rtos *h* 2 2) " > :")))
 (if h (setq *h* h) (setq h *h*))

 (or *sty* (setq *sty* (getvar "textstyle")))
 (setq sty (getstring t (strcat "\n Nhap ten style < " 
			*sty* " > :")))
 (if sty (setq *sty* sty) (setq sty *sty*))

 (repeat sodt
   (setq entdt (ssname ssdt index)
  index (1+ index))
   (while (/= (cdr(assoc 0 (entget entdt))) "SEQEND")
   	(setq
    entdt (entnext entdt)
  tt (entget entdt)
   	)
(if w (setq tt (subst (cons 41 w) (assoc 41 tt) tt)))
(if h (setq tt (subst (cons 40 h) (assoc 40 tt) tt)))
(if (tblsearch "style" sty) (setq tt (subst (cons 7 sty) (assoc 7 tt) tt)))

  	 (entmod tt)
   	(entupd entdt)
   )
 )

 (princ)
)

Chỗ kêu nhập chiều cao chữ nếu không nhập thì nó vẫn giữ nguyên chiều cao cũ chứ bác lisp này nếu không nhập nó cho chiều cao chữ bằng 0,giống như text style không nhập thì nó vẫn giữ nguyên đó bác,Mong bác sửa lại phần nhập chiều cao chữ giúp e.Thanks.


<<

Filename: 153928_wo.lsp

Trang 274/330

274