Jump to content
InfoFile
Tác giả: quocmanh04tt
Bài viết gốc: 378364
Tên lệnh: td
Hiệu Chỉnh File Lisp

Không được là do: mình có text có nội dung bất kì thì nó không chạy được
1/ ví dụ mình có dãy số:
08200
08300
08222
123
... chẳng hạn 
Bây giờ mình muốn nó về
08200
08201
08202
08203
Hoặc muốn nó...

>>

Không được là do: mình có text có nội dung bất kì thì nó không chạy được
1/ ví dụ mình có dãy số:
08200
08300
08222
123
... chẳng hạn 
Bây giờ mình muốn nó về
08200
08201
08202
08203
Hoặc muốn nó về
08E00
08E00
08E00
08E00

 
Bạn xem lại yêu cầu của bạn ở bài đầu !
Đây là lý do tại sao phần dưới của bạn đỏ lừ, bạn yêu cầu không rõ ràng.
Nếu là text bất kỳ thì Lisp phải viết khác.
Lisp này cắt bỏ ký tự cuối cùng (của chuỗi nhập vào) và thêm 1, 2, 3 ....
(defun c:td (/ tdt csht sdt index tt entdt txt)
(defun thay (tt key moi / cu) (setq cu (assoc key tt)) (subst (cons key moi) cu tt))
(princ "\nCADViet.com (c) 2007")
(if (setq tdt (ssget '((0 . "*TEXT"))))
(progn (setq txt (getstring "\nNhap chuoi: ")
sdt (sslength tdt)
csht 1
index 0)
(repeat sdt
(setq entdt (ssname tdt index)
index (1+ index)
tt (entget entdt))
(setq tt (thay tt 1 (strcat (substr txt 1 (- (strlen txt) 1)) (itoa csht)))
csht (1+ csht))
(entmod tt)
(entupd entdt))))
(princ))
<<

Filename: 378364_td.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 378380
Tên lệnh: test
Lisp chọn đối tượng theo trục X hoặc trục Y
Ví dụ: Xóa các đối tượng (gồm text hoặc line) theo phương trục X hoặc trục Y

Filename: 378380_test.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 378502
Tên lệnh: tkt%C2%A0
Lisp đếm text rồi thống kê thành bảng
Thử cái này xem:
(defun c:tkt  (/ lst msp pt ss str txtsiz-0 txtsiz doc)
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "TEXT"))))
    (progn (foreach e  (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
             (setq str      (vla-get-TextString...
>>
Thử cái này xem:
(defun c:tkt  (/ lst msp pt ss str txtsiz-0 txtsiz doc)
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "TEXT"))))
    (progn (foreach e  (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
             (setq str      (vla-get-TextString e)
                   txtsiz-0 (vla-get-height e))
             (if (not (assoc str lst))
               (setq lst (cons (cons str 1) lst))
               (setq lst (subst (cons str (1+ (cdr (assoc str lst)))) (assoc str lst) lst))))
           (or (setq txtsiz (getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos txtsiz-0 2 2) ">: ")))
               (setq txtsiz txtsiz-0))
           (setq lst (vl-sort lst '(lambda (x y) (< (cdr x) (cdr y))))
                 pt  (getpoint "\nDiem dat Bang :")
                 doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
                 msp (if (zerop (vla-get-activespace doc))
                       (if (= (vla-get-mspace doc) :vlax-true)
                         (vla-get-modelspace doc)
                         (vla-get-paperspace doc))
                       (vla-get-modelspace doc)))
           (foreach e  lst
             (vla-addtext msp (cdr e) (vlax-3d-point pt) txtsiz)
             (vla-addtext msp (car e) (vlax-3d-point (polar pt 0 (* 5 txtsiz))) txtsiz)
             (setq pt (polar pt (/ pi -2) (* 1.5 txtsiz)))))
    (alert "Khong chon duoc Text."))
  (princ))​

<<

Filename: 378502_tkt%C2%A0.lsp
Tác giả: mitalead_kirk
Bài viết gốc: 379010
Tên lệnh: tinhtong
Lisp đo chiều dài và ghi text
Lisp tính tổng chiều dài bằng cách pick liên tục nhiều điểm và ghi thành text mới theo stype có sẵn. Chiều dài được để ở giữa "L = .... m”.

Filename: 379010_tinhtong.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 110816
Tên lệnh: tdd
Viết lisp theo yêu cầu [phần 2]

Chào bạn hdt4151,
Do file bạn gửi không load về được nên mình tự hiểu và điều chỉnh cái lisp cũ theo các yêu cầu mới của bạn. Bạn dùng thử và cho ý kiến nhé
Trong lisp này mình đã bổ sung phần loại bỏ sai lệch do người dùng chuyển hệ tọa độ.


PS: có thể về chiều cao text chưa phù hợp với yêu cầu của bạn, bạn hãy tự điều chỉnh chiều cao này trong dòng...
>>

Chào bạn hdt4151,
Do file bạn gửi không load về được nên mình tự hiểu và điều chỉnh cái lisp cũ theo các yêu cầu mới của bạn. Bạn dùng thử và cho ý kiến nhé
Trong lisp này mình đã bổ sung phần loại bỏ sai lệch do người dùng chuyển hệ tọa độ.


PS: có thể về chiều cao text chưa phù hợp với yêu cầu của bạn, bạn hãy tự điều chỉnh chiều cao này trong dòng code ghi text nhé. Lưu ý khi chỉnh sửa chiều cao này cần chú ý tới việc điều chỉnh vị trí của điểm đặt của text bạn nhé. Vị trí này chính là điểm pt trong lisp. Mong bạn cố gắng tự sửa những điểm nhỏ nhặt nói trên để sử dụng lisp được hiệu quả.
<<

Filename: 110816_tdd.lsp
Tác giả: tien2005
Bài viết gốc: 379548
Tên lệnh: chw
Lisp Thay ??i Height Và Width Factor C?a Text Attribute Trong Block

bạn thử xem

(defun c:CHW (/ ss h sc)
  (if (and
	(SETQ ss (ssget '((0 . "insert") (66 . 1))))
	(setq h (getreal "\nChieu cao chu: "))
	(setq sc (getreal "\nDo rong chu: "))
      )
    (progn
      (setq
	ss (mapcar 'vlax-ename->vla-object
		   (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
	   )
      )
      (mapcar '(lambda (Obj)
		 (mapcar '(lambda (x)
			    (vla-put-height x h)
			    (vla-put-scalefactor x sc)
			  )
			 (vlax-invoke Obj...
>>

bạn thử xem

(defun c:CHW (/ ss h sc)
  (if (and
	(SETQ ss (ssget '((0 . "insert") (66 . 1))))
	(setq h (getreal "\nChieu cao chu: "))
	(setq sc (getreal "\nDo rong chu: "))
      )
    (progn
      (setq
	ss (mapcar 'vlax-ename->vla-object
		   (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
	   )
      )
      (mapcar '(lambda (Obj)
		 (mapcar '(lambda (x)
			    (vla-put-height x h)
			    (vla-put-scalefactor x sc)
			  )
			 (vlax-invoke Obj 'GetAttributes)
		 )
	       )
	      ss
      )
    )
  )
  (princ)
)

<<

Filename: 379548_chw.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 379567
Tên lệnh: eb
Lisp Thay Đổi Height Và Width Factor Của Text Attribute Trong Block

Hy vọng là được (Khuyến mại thêm Textstyle): :D​

(defun c:eb (/ get-gc put-gc getvalue *error* att curcmd dcledittext dcl_id editext file_dcl hei oldhei oldval oldwid str wid dialog taolist
lststy possty sty)
(setq *error* (defun my-err (msg)
(cond ((= msg "function cancelled") (princ "\t\tuser abort"))
(t (progn (princ msg) (princ))))
(setq *error* nil)
(princ)))
(defun get-gc (group entity) (cdr (assoc group (entget entity))))
(defun...

>>

Hy vọng là được (Khuyến mại thêm Textstyle): :D​

(defun c:eb (/ get-gc put-gc getvalue *error* att curcmd dcledittext dcl_id editext file_dcl hei oldhei oldval oldwid str wid dialog taolist
lststy possty sty)
(setq *error* (defun my-err (msg)
(cond ((= msg "function cancelled") (princ "\t\tuser abort"))
(t (progn (princ msg) (princ))))
(setq *error* nil)
(princ)))
(defun get-gc (group entity) (cdr (assoc group (entget entity))))
(defun put-gc (value group entity / properties)
(setq properties (entget entity))
(setq properties (subst (cons group value) (assoc group properties) properties))
(entmod properties))
(defun getvalue ()
(setq str (get_tile "text")
hei (atof (get_tile "hei"))
wid (atof (get_tile "wid"))
sty (atoi (get_tile "sty"))))
(defun taolist (kieu / kieu nl lkq)
(setq lkq '())
(setq nl (tblnext kieu t))
(while nl (setq lkq (append lkq (list (cdr (assoc 2 nl))))) (setq nl (tblnext kieu)))
lkq)
(vl-load-com)
(setq dcledittext (list
"edit: dialog {label = \"CHANGE TEXT PROPERTIES\";initial_focus = \"text\";"
":edit_box {label = \"String:\"; allow_accept = true; edit_width = 45; key = \"text\";}" ": row {"
":edit_box {label = \"Height:\"; allow_accept = true; edit_width = 8; key = \"hei\";}"
":edit_box {label = \"Width:\"; allow_accept = true; edit_width = 8; key = \"wid\";}"
":popup_list {allow_accept = true; edit_width = 12; key = \"sty\";}" "}" "spacer_1;" "ok_cancel;}"))
(setq curcmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(while (/= (setq att (car (nentselp "\nselect attribute for edit: "))) nil)
(if (or (= (get-gc 0 att) "ATTRIB") (= (get-gc 0 att) "TEXT"))
(progn (setq oldval (get-gc 1 att)
oldhei (rtos (get-gc 40 att) 2 (getvar 'LUPREC))
oldwid (rtos (get-gc 41 att) 2 2)
oldsty (get-gc 7 att)
lststy (taolist "STYLE")
possty (vl-position oldsty lststy))
(setq editext.dcl (vl-filename-mktemp "edittext.dcl")
file_dcl (open editext.dcl "w"))
(foreach ll dcledittext (write-line ll file_dcl))
(close file_dcl)
(if (> 0 (setq dcl_id (load_dialog editext.dcl)))
(progn (alert "not found file edittext.dcl") (exit)))
(if (not (new_dialog "edit" dcl_id))
(progn (alert "not found edit dialog") (exit)))
(set_tile "text" oldval)
(set_tile "hei" oldhei)
(set_tile "wid" oldwid)
(set_tile "sty" (rtos possty))
(start_list "sty" 3)
(mapcar 'add_list lststy)
(end_list)
(action_tile "accept" "(getvalue)(setq dialog 1)(done_dialog)")
(action_tile "cancel" "(setq dialog nil)")
(start_dialog)
(unload_dialog dcl_id)
(if (eq dialog 1)
(progn (put-gc str 1 att) (put-gc hei 40 att) (put-gc wid 41 att) (put-gc (nth sty lststy) 7 att))))
(princ "select attrib/text")))
(if editext.dcl
(vl-file-delete editext.dcl))
(setvar "cmdecho" curcmd)
(setq *error* nil)
(princ))


<<

Filename: 379567_eb.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 380040
Tên lệnh: tpl
Tính Kho?ng Cách ?o?n Th?ng Gi?i H?n B?i 2 ?i?m B?t K? Trên ???ng Th?ng
Ch? c?n pick 2 ?i?m trên cùng 1 Pline:
(defun c:tpl (/ ent ep2 len pt1 pt2 txt vars vals)
(vl-load-com)
(setq vars '("DYNMODE" "DYNPROMPT" "OSMODE")
vals (mapcar 'getvar vars))
(mapcar 'setvar vars '(1 1 623))
(if (and (setq pt1 (getpoint "\nDiem thu nhat nam tren Polyline: "))
(setq ent (car (nentselp pt1)))
(wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
(setq pt2 (getpoint "\nDiem thu nhat nam tren Polyline: "))
(setq ep2 (car (nentselp pt2)))
(eq (cdr...
>>
Ch? c?n pick 2 ?i?m trên cùng 1 Pline:
(defun c:tpl (/ ent ep2 len pt1 pt2 txt vars vals)
(vl-load-com)
(setq vars '("DYNMODE" "DYNPROMPT" "OSMODE")
vals (mapcar 'getvar vars))
(mapcar 'setvar vars '(1 1 623))
(if (and (setq pt1 (getpoint "\nDiem thu nhat nam tren Polyline: "))
(setq ent (car (nentselp pt1)))
(wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
(setq pt2 (getpoint "\nDiem thu nhat nam tren Polyline: "))
(setq ep2 (car (nentselp pt2)))
(eq (cdr (assoc 5 (entget ent)))
(cdr (assoc 5 (entget (car (nentselp pt2)))))))
(progn (setq pt1 (vlax-curve-getclosestpointto ent pt1)
pt2 (vlax-curve-getclosestpointto ent pt2)
len (abs
(- (vlax-curve-getdistatpoint ent pt2) (vlax-curve-getdistatpoint ent pt1)))
len (rtos len 2 (getvar 'LUPREC)))
(princ (strcat "\nLength: " len "."))
(if (and (setq txt (car (entsel "\nChon Text, Mtext de gan gia tri: ")))
(wcmatch (cdr (assoc 0 (entget txt))) "*TEXT"))
(vla-put-textstring (vlax-ename->vla-object txt) len)))
(cond ((or (null pt1) (null ent)) (princ))
((not (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE"))
(princ "\nDiem da pick khong nam tren Pline! "))
((or (null pt2)
(null ep2)
(not (eq (cdr (assoc 5 (entget ent))) (cdr (assoc 5 (entget ep2))))))
(alert "\nXem lai diem thu 2...! "))
(t)))
(mapcar 'setvar vars vals)
(princ))
<<

Filename: 380040_tpl.lsp
Tác giả: duy782006
Bài viết gốc: 380143
Tên lệnh: cpm
Sửa Lisp Copy Rải

-Tên lệnh: pcm
-Thao tác: 
+Nhập lệnh. 
+Chọn đối tượng cần copy.

>>

-Tên lệnh: pcm
-Thao tác: 
+Nhập lệnh. 
+Chọn đối tượng cần copy.
+Chọn điểm xuất phát.
+Chọn điểm đến. 
*Lisp thực hiện copy nhóm đối tượng từ điểm xuất phát đến điểm đến và đưa ra 3 lựa chọn. *N/:N/<: trong đó N là số tuỳ ý (nhập trực tiếp luôn nhé ví dụ *5 lisp sẽ tự lọc lấy số để thực hiện).
+Lựa chọn *N thì đối tượng sẽ được copy thêm N lần với khoảng cách từ từ đối tượng này đến đối tượng kia bằng điểm xuất phát đến điểm đến.
+Lựa chọn :N Thì khoảng cách từ điểm xuất phát đến điểm đến sẽ được chia làm N lần và đối tượng sẽ được copy đến các điểm nút này.
+Lựa chọn < thì sau khi enter lisp hỏi khoảng cách giới hạn và tính toán rãi trong khoảng cách này phần dư thì bỏ. (kiểu như MEASURE của cad ấy)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun thuchiencopy ()
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(repeat solanthuchien
(setq index (1+ index))
(command ".copy" doituong "" p1 (polar p1 goc (* kc index)))
)
(setvar "osmode" luubatdiem)
(Princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kieunhan ()
(setq index 1)
(setq solanthuchien (- (atoi kytuconlai) 1)) 
(thuchiencopy)
(Princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kieuchia ()
(setq index 0)
(setq kc (/ kc (atoi kytuconlai)))
(setq solanthuchien (- (atoi kytuconlai) 1)) 
(thuchiencopy)
(Princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kieutrong ()
(setq p3 (getpoint p1 "\nRai trong khoang: "))
(setq kc1 (distance p1 p3))
(setq index 1)
(setq solanthuchien (- (fix (/ kc1 kc)) 1)) 
(thuchiencopy)
(Princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun tinhtoankieu ()
(setq ddkc (strlen kieuchep))
(setq skytuconlai (- ddkc 1))
(setq kytuconlai (substr kieuchep 2 skytuconlai))
(setq kytudautien (substr kieuchep 1 1))

(if (= kytudautien "*")
(progn
(kieunhan)
))
(if (= kytudautien ":")
(progn
(kieuchia)
))
(if (= kytudautien "<")
(progn
(kieutrong)
))
(Princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:cpm ()
(command "undo" "be")
(setvar "MODEMACRO" "RAI DOI TUONG THEO QUY LUAT CHO TRUOC")
(princ "\nPHAM QUOC DUY Binh Son - Quang ngai")
(Prompt "\nChon doi tuong muon chep...")
(setq doituong (ssget)
p1 (getpoint "\nDiem bat dau: ")
p2 (getpoint p1 "\nDiem ket thuc: ")
goc (angle p1 p2)
kc (distance p1 p2)
index 0
)
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(command ".copy" doituong "" p1 p2)
(setvar "osmode" luubatdiem)
(setq kieuchep (getstring "\n*N/:N/<: "))
(tinhtoankieu)
(command "undo" "end")
(setvar "MODEMACRO" "**CHUC BAN LAM VIEC HIEU QUA** PHAM QUOC DUY - BINH SON - QUANG NGAI")
(Princ))


<<

Filename: 380143_cpm.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 380108
Tên lệnh: chuyendoifont
Lisp Chuyển Đổi Mã Font Chữ Trong Autocad

Dưới đây là lisp convert các mã font thông dụng (unicode, tcvn, vni, xược) trong AutoCAD. Chương trình tự nhận dạng mã font hiện hành của đối tượng text.

Sau khi Appload xong:
Dùng lệnh cfu để chuyển font sang unicode
Dùng lệnh cft để chuyển font sang tcvn
Dùng lệnh cfv để chuyển font sang vni
Dùng lệnh cfx để chuyển font sang xược (/)
Dùng lệnh cfk để chuyển font sang không dấu
Dùng...
>>
Dưới đây là lisp convert các mã font thông dụng (unicode, tcvn, vni, xược) trong AutoCAD. Chương trình tự nhận dạng mã font hiện hành của đối tượng text.

Sau khi Appload xong:
Dùng lệnh cfu để chuyển font sang unicode
Dùng lệnh cft để chuyển font sang tcvn
Dùng lệnh cfv để chuyển font sang vni
Dùng lệnh cfx để chuyển font sang xược (/)
Dùng lệnh cfk để chuyển font sang không dấu
Dùng lệnh cf+ để chuyển font sang chữ hoa
Dùng lệnh cf- để chuyển font sang chữ thường

File lisp: Download Lisp chuyển font (để tham khảo)
File vlx: convertfont.vlx (download và sử dụng file này)

Câu hỏi thường gặp
Hỏi: Sau khi chuyển font, tôi vẫn chưa đọc được
Đáp: Sau khi chuyển font, bạn phải chỉnh cả style phù hợp thì mới đọc được (nếu style chưa phù hợp với mã font)

Hỏi: Text của tôi là TCVN (vì sử dụng font .vnArial hiển thị bình thường), nhưng không thể convert được sang bất cứ mã nào. Khi convert dường như Text không hề thay đổi.
Đáp: Có thể mã chữ của bạn được viết theo mã %%. Cách kiểm tra xem có phải mã này không bằng cách dùng lệnh LIST rồi chọn một text có tiếng việt. Nếu bạn thấy tại các vị trí ký tự nguyên âm là dấu %%, thì bạn phải "sửa" text trước khi dùng mã lệnh này. Cách sửa bạn xem ở đây: http://www.cadviet.com/forum/topic/150896-lisp-chuya-n-a-i-ma-font-cha-trong-autocad/?p=386883

Hỏi: Tại sao khi tôi chuyển từ TCVN sang các mã khác, các chữ có dấu bị hoa-thường không đúng.
Đáp: Vì font TCVN có nhược điểm là dùng chung mã chữ (char code) cho cả chữ hoa hoa và chữ thường thường. Vì vậy khi convert sang mã khác, sẽ không đúng ý.
Muốn được đúng, bạn cần convert sang mã khác, sau đó dùng lệnh cf+ hoặc cf-.

Lịch sử phát triển
2015-10-04: Phiên bản đầu tiên
2015-10-05:
- Hiệu chỉnh lỗi tên file
- Tính năng tự tìm mã font
- Tính năng loại bỏ dấu
2015-10-06:
- Sửa lỗi
- Tính năng chữ hoa / chữ thường
- Sửa / rút ngắn số lệnh
2015-11-23:
- Cải tiến tính năng tự tìm mã font
- Cải tiến tốc độ chạy chương trình
- Bổ sung tính năng xác định thời gian
2015-11-27:
- Upload file lisp thay vì download file.
____________________________________________
<<

Filename: 380108_chuyendoifont.lsp
Tác giả: pphung183
Bài viết gốc: 380774
Tên lệnh: tkte
Lisp Thống Kế Thép Bằng Block.

Thấy Bạn duy782006 tặng diễn đàn 1 lisp hết sức công phu, mình cũng viết 1 lisp hỗ trợ sửa Bảng thống kê từ Lisp duy782006 :)

tặng các bạn yêu thích Lisp :) :

(defun...
>>

Thấy Bạn duy782006 tặng diễn đàn 1 lisp hết sức công phu, mình cũng viết 1 lisp hỗ trợ sửa Bảng thống kê từ Lisp duy782006 :)

tặng các bạn yêu thích Lisp :) :

(defun c:TKTE (/ cmd GetTLDV GetDai GetTag PutTag ent at obj tn Dai km n k)
(setq cmd (getvar "cmdecho")) (setvar "cmdecho" 0)
(defun GetTLDV(D)
(cond ((= D 6) 0.222) ((= D 8) 0.395) ((= D 10) 0.617) ((= D 12) 0.888) ((= D 14) 1.209)
((= D 16) 1.579) ((= D 18) 1.998) ((= D 20) 2.467) ((= D 22) 2.985) ((= D 24) 3.552)
((= D 25) 3.854) ((= D 26) 4.169) ((= D 28) 4.835) ((= D 30) 5.55) ((= D 32) 6.315)
((= D 34) 7.129) ((= D 36) 7.992) ((= D 40) 9.867) )) ;;;;;
(defun GetDai (obj / Tag Val l lst)
(foreach att (vlax-invoke obj 'GetAttributes) 
(setq Tag (vla-get-TagString att)) (setq Val (vla-get-TextString att))
(if (or (eq Tag "KT1") (eq Tag "KT2") (eq Tag "KT3") (eq Tag "KTA1")
(eq Tag "KTA2") (eq Tag "KTB1") (eq Tag "KTB2") (eq Tag "KTC1") 
(eq Tag "KTC2") ) (setq l (atof Val) lst (cons l lst)) )) lst) ;;;;;
(defun GetTag (obj tag)
(vl-some '(lambda (att) (if (= tag (vla-get-tagstring att)) (vla-get-textstring att)))
(vlax-invoke obj 'getattributes)) ) ;;;;;
(defun PutTag (obj tag tn)
(vl-some '(lambda (att) (if (= tag (vla-get-tagstring att)) (vla-put-textstring att tn)))
(vlax-invoke obj 'getattributes)) ) ;;;;;
(setq cmd (getvar "cmdecho")) (setvar "cmdecho" 0) 
(while (and (/= (setq ent (entsel "\nSelect Block Attribute for edit: ")) nil) 
(setq at (car (nentselp (cadr ent))) obj (vlax-ename->vla-object (car ent))) )
(setq tn (lisped (vla-get-TextString (setq at (vlax-ename->vla-object at)))))
(vla-put-TextString at tn) (setq Dai (apply '+ (GetDai obj)))
(PutTag obj "CD" (rtos Dai 2 0))
(setq km (GetTLDV (atoi (GetTag obj "PI")))) (setq n (atof (GetTag obj "SL")))
(setq k (atof (GetTag obj "SCK"))) (setq tn1 (/ (* Dai n k) 1000))
(setq tn2 (* tn1 km)) (PutTag obj "TCDCK" (rtos tn1 2 2)) 
(PutTag obj "TLCK" (rtos tn2 2 2)) (vla-Update obj) ) 
(setvar "cmdecho" cmd) (princ))


<<

Filename: 380774_tkte.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 380727
Tên lệnh: rgt
H?i V? ???ng Th?ng Khi Có T?a ?? Trên S? ??
B?n th? cái này xem:
(defun C:RGT (/ MKTEXT tmp Plist mspace obj ent epar j len pal le1 le2 Pm lst ang)
;;--- NHAP TOA DO CAC DIEM O DAY :
(setq Plist (list '(1204372.51 610950.64) '(1204367.73 610979.33) '(1204360.41 610976.53) '(1204358.58 610981.01) '(1204357.31 610984.12)
'(1204341.11 610977.91) '(1204342.47 610974.65) '(1204343.94 610971.56) '(1204354.13 610946.60) '(1204372.51...
>>
B?n th? cái này xem:
(defun C:RGT (/ MKTEXT tmp Plist mspace obj ent epar j len pal le1 le2 Pm lst ang)
;;--- NHAP TOA DO CAC DIEM O DAY :
(setq Plist (list '(1204372.51 610950.64) '(1204367.73 610979.33) '(1204360.41 610976.53) '(1204358.58 610981.01) '(1204357.31 610984.12)
'(1204341.11 610977.91) '(1204342.47 610974.65) '(1204343.94 610971.56) '(1204354.13 610946.60) '(1204372.51 610950.64)))
;;-----------------------------------------------------------------------------------------------------------------------------------------
(defun MKTEXT (pt hgt str ang col)
(if (and pt str)
(entmakex (list (cons 0 "TEXT")
(cons 10 pt)
(cons 40 hgt)
(cons 50 ang)
(cons 62 col)
(cons 1 str)
(cons 72 1)
(cons 11 pt)
(cons 73 2)))))
(vl-load-com)
(setq mspace (vla-get-modelSpace (vla-get-activeDocument (vlax-get-acad-object))))
(setq Plist (apply 'append Plist))
(setq tmp (vlax-make-safearray vlax-vbDouble (cons 0 (- (vl-list-length Plist) 1))))
(vlax-safearray-fill tmp Plist)
(setq obj (vla-addLightweightPolyline mspace tmp)
ent (vlax-vla-object->ename obj))
(vla-put-color obj 3)
(setq epar (vlax-curve-getendparam obj)
j -1
pal (vlax-curve-getdistatparam obj epar))
(repeat (fix epar)
(setq j (1+ j)
le1 (vlax-curve-getdistatparam obj j)
le2 (vlax-curve-getdistatparam obj (1+ j))
len (- le2 le1)
Pm (trans (vlax-curve-getPointAtParam ent (+ j 0.5)) 0 ent)
ang (angle (trans (vlax-curve-getpointatparam ent j) 0 ent)
(trans (vlax-curve-getpointatparam ent (1+ j)) 0 ent))
lst (cons (list (1+ j) Pm len) lst))
(MKTEXT (trans (vlax-curve-getpointatparam ent j) 0 ent) 0.75 (itoa (1+ j)) 0 1)
(cond ((and (> ang (/ pi 2)) (<= ang pi)) (setq ang (- ang pi)))
((and (> ang pi) (<= ang (/ (* 3 pi) 2))) (setq ang (+ ang pi))))
(MKTEXT Pm 0.5 (rtos len 2 2) ang 2))
(princ))
<<

Filename: 380727_rgt.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 335962
Tên lệnh: sth
[Nhờ sửa lisp]Thống kê cốt thép

Mình có 1 lisp thống kê cốt thép, lisp sử dụng để chỉnh sữa block thuộc tính trong file cad đính kèm.

Lisp sửa thép:

 

Mình muốn thêm công thức như sau: Tổng chiều dài các đoạn thép thành phần = chiều dài.

Ví dụ như ảnh trên thì: 50+350+14400+350+50=15200 (2 ô màu vàng)

Tức là khi...

>>

Mình có 1 lisp thống kê cốt thép, lisp sử dụng để chỉnh sữa block thuộc tính trong file cad đính kèm.

Lisp sửa thép:

 

Mình muốn thêm công thức như sau: Tổng chiều dài các đoạn thép thành phần = chiều dài.

Ví dụ như ảnh trên thì: 50+350+14400+350+50=15200 (2 ô màu vàng)

Tức là khi mình chỉnh sữa các số 50, 350, 14400, 350, 50 thì số 15200 cũng nhảy theo.

Hy vọng được mọi người giúp đỡ. Cám ơn!!!

 

File lisp: http://www.cadviet.com/upfiles/4/96055_suathep.lsp

File cad: http://www.cadviet.com/upfiles/4/96055_bangtkt.dwg

File tl (giải nén file rar): http://www.cadviet.com/upfiles/4/96055_tl_1.rar

Hề hề hề,

Không biết có phải ý chủ thớt là như vầy không???

Chủ thớt hãy download lisp đã sửa dưới đây và test thử coi sao nhé.

 

http://www.cadviet.com/upfiles/4/5194_sth_1.lsp

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/120498-nho-sua-lisp-thong-ke-cot-thep/
;----------------------------------------
 
; TT - Sua thep trong Bang thong ke thep
 
; Su dung file : tl.dcl
 
;----------------------------------------
 
 
(defun GetTLDV(Phi)
 
(cond ((= Phi 6) 0.222)
 
((= Phi 8) 0.395)
 
((= Phi 10) 0.617)
 
((= Phi 12) 0.888)
 
((= Phi 14) 1.21)
 
((= Phi 16) 1.58)
 
((= Phi 18) 2.0)
 
((= Phi 20) 2.47)
 
((= Phi 22) 2.98)
 
((= Phi 24) 3.551)
 
((= Phi 25) 3.85)
 
((= Phi 26) 4.17)
 
((= Phi 28) 4.83)
 
((= Phi 30) 5.55)
 
((= Phi 32) 6.31)
 
((= Phi 34) 7.13)
 
((= Phi 36) 7.99)
 
((= Phi 40) 9.89)
 
)
 
)
 
 
;------------------------------------------------------------------------
 
; ATTUPD - Update the attribute values of a selected block in steel table
 
;------------------------------------------------------------------------
 
(defun AttUpd (ENTITY_NAME / ENTITY_LIST ENTITY_TYPE CONTINUE VALUE TAG TLDV Dai TongSL TongDai)
 
 
(setq ENTITY_LIST (entget ENTITY_NAME))
 
(setq ENTITY_TYPE (cdr (assoc 0 ENTITY_LIST)))
 
 
(setq CONTINUE "YES")
 
 
(if (equal ENTITY_TYPE "INSERT")
 
    (progn
 
     (setq Dai 0)
 
    (while (and (setq ENTITY_NAME (entnext ENTITY_NAME)) (equal CONTINUE "YES"))
 
               (setq ENTITY_LIST (entget ENTITY_NAME))
 
               (setq ENTITY_TYPE (cdr (assoc 0 ENTITY_LIST)))
 
 
              (cond 
 
                       ((equal ENTITY_TYPE "ATTRIB")
 
                              (setq VALUE (cdr (assoc 1 ENTITY_LIST)))
 
                              (setq TAG (cdr (assoc 2 ENTITY_LIST)))
 
                             (cond 
                                     
                                     ((or (equal TAG "O_SO0")
                                            (equal TAG "O_SO1")
                                            (equal TAG "O_SO2")
                                            (equal TAG "O_SO3")
                                            (equal TAG "O_SO4")
                                            (equal TAG "O_SO5")
                                            (equal TAG "O_SO6")
                                            (equal TAG "O_SO7")
                                            (equal TAG "O_SO8")
                                            (equal TAG "O_SO9")
                                            (equal TAG "O_SO10")
                                            (equal TAG "O_SO11")
                                            (equal TAG "O_SO12")
                                            (equal TAG "O_SO13")    )
                                                                                          (setq  Dai (+ Dai (atof VALUE)))            )
 
                                     ((equal TAG "D_K") (setq TLDV (GetTLDV (atof VALUE))))
 
                                     ((equal TAG "D_T") (setq ENTITY_LIST (subst (cons 1 (rtos Dai 2 0)) (assoc 1 ENTITY_LIST) ENTITY_LIST))
 
                                                                        (entmod ENTITY_LIST)
 
                                                                       (entupd ENTITY_NAME)             )
 
                                     ((equal TAG "T_S") (setq TongSL (atof VALUE)))
 
                                     ((equal TAG "T_D") (setq TongDai (/ (* Dai TongSL) 1000))
 
                                                                       (setq ENTITY_LIST (subst (cons 1 (rtos TongDai 2 2)) (assoc 1 ENTITY_LIST) ENTITY_LIST))
 
                                                                       (entmod ENTITY_LIST)
 
                                                                       (entupd ENTITY_NAME)
 
                                     )
 
                                     ((equal TAG "T_L") (setq TongLuong (* TLDV TongDai))
 
                                                                       (setq ENTITY_LIST (subst (cons 1 (rtos TongLuong 2 2)) (assoc 1 ENTITY_LIST) ENTITY_LIST))
 
                                                                       (entmod ENTITY_LIST)
 
                                                                       (entupd ENTITY_NAME)
 
                                     )
 
                            )
 
                     )
 
                    ((equal ENTITY_TYPE "SEQEND") (setq CONTINUE "NO")  )
 
           )
 
      )
 
)
 
)
 
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:STH(/ Pick TextEntity Point Entity First_Entity Entity_Type
 
EList CText)
 
(defun _DCL ()
 
(setq _CText (get_tile "text_kt"))
 
(done_dialog)
 
); End of _DCL
 
 
(setq oldblp (getvar "BLIPMODE")
 
oldech (getvar "CMDECHO")
 
)
 
(setvar "BLIPMODE" 0)
 
(setvar "CMDECHO" 0)
 
 
(while (setq Pick (nentsel "\nChon Text trong Bang ke thep : "))
 
(setq TextEntity (car Pick)) ;Get the entity name
 
(setq Point (car (cdr Pick))) ;Get the selected point
 
(setq Entity (ssget Point)) ;Get the entity at selected point
 
(setq First_Entity (ssname Entity 0)) ;Get the first entity
 
 
(setq ELIST (entget TextEntity)) ;Get the database information
 
(setq ENTITY_TYPE (cdr (assoc 0 ELIST)))
 
 
(if (equal ENTITY_TYPE "ATTRIB")
 
(setq CText (cdr (assoc 1 EList)))
 
(setq CText "")
 
); End of if
 
 
(if (/= CText "")
 
(progn
 
(setq dcl_id (load_dialog "tl.DCL"))
 
(if (not (new_dialog "sua_text" dcl_id)) (exit))
 
(setq accept nil)
 
(set_tile "text_kt" CText)
 
(action_tile "accept" "(_DCL)")
 
(start_dialog)
 
(setq ELIST (subst (cons 1 _CText) (assoc 1 ELIST) ELIST))
 
(entmod ELIST)
 
(if (equal ENTITY_TYPE "ATTRIB")
 
(progn
 
(entupd TextEntity)
 
(AttUpd First_Entity)
 
)
 
)
 
(unload_dialog dcl_id)
 
)
 
)
 
); End of while
 
 
(setvar "BLIPMODE" oldblp)
 
(setvar "CMDECHO" oldech)
 
 
(redraw)
 
(prompt "\nProgram complete.")
 
(princ)
 
 
) ;End of C:STH
 

<<

Filename: 335962_sth.lsp
Tác giả: pphung183
Bài viết gốc: 381035
Tên lệnh: eb
Lisp Thay Đổi Height Và Width Factor Của Text Attribute Trong Block

Thêm màu mè là đây :D :

(defun c:eb (/ colimg get-gc put-gc getvalue *error* att curcmd dcledittext dcl_id editext file_dcl hei oldhei oldval oldwid str wid dialog taolist

lststy possty sty #color)

(setq *error* (defun my-err (msg)

(cond ((= msg "function cancelled") (princ "\t\tuser abort"))

(t (progn (princ msg) (princ))))

(setq *error* nil)

(princ)))

(defun colimg (k c)
(start_image k) (fill_image 0 0 (dimx_tile k) (dimy_tile k) c) (end_image)...
>>

Thêm màu mè là đây :D :

(defun c:eb (/ colimg get-gc put-gc getvalue *error* att curcmd dcledittext dcl_id editext file_dcl hei oldhei oldval oldwid str wid dialog taolist

lststy possty sty #color)

(setq *error* (defun my-err (msg)

(cond ((= msg "function cancelled") (princ "\t\tuser abort"))

(t (progn (princ msg) (princ))))

(setq *error* nil)

(princ)))

(defun colimg (k c)
(start_image k) (fill_image 0 0 (dimx_tile k) (dimy_tile k) c) (end_image) )

(defun get-gc (group entity) (cdr (assoc group (entget entity))))

(defun put-gc (value group entity / properties)

(setq properties (entget entity))

(setq properties (subst (cons group value) (assoc group properties) properties))

(entmod properties))

(defun getvalue ()

(setq str (get_tile "text")

hei (atof (get_tile "hei"))

wid (atof (get_tile "wid"))

sty (atoi (get_tile "sty"))))

(defun taolist (kieu / kieu nl lkq)

(setq lkq '())

(setq nl (tblnext kieu t))

(while nl (setq lkq (append lkq (list (cdr (assoc 2 nl))))) (setq nl (tblnext kieu)))

lkq)

(vl-load-com)

(setq dcledittext (list

"edit: dialog {label = \"CHANGE TEXT PROPERTIES\";initial_focus = \"text\";"

":edit_box {label = \"String:\"; allow_accept = true; edit_width = 45; key = \"text\";}" ": row {"

":edit_box {label = \"Height:\"; allow_accept = true; edit_width = 8; key = \"hei\";}"

":edit_box {label = \"Width:\"; allow_accept = true; edit_width = 8; key = \"wid\";}"

":popup_list {allow_accept = true; edit_width = 12; key = \"sty\";}" "}" "spacer_1;"

" :row {" " : text {" " label = \"Ch\U+1ECDn Color cho Text :\"; alignment =left;" "}"
" : image_button {"
" key = \"color\"; alignment = centered; height = 1.7; width = 15.0; fixed_width = false;   fixed_height = true;" "}}"
 
"ok_cancel;}"))

(setq curcmd (getvar "cmdecho"))

(setvar "cmdecho" 0)

(while (/= (setq att (car (nentselp "\nselect attribute for edit: "))) nil)

(if (or (= (get-gc 0 att) "ATTRIB") (= (get-gc 0 att) "TEXT"))

(progn (setq oldval (get-gc 1 att)

oldhei (rtos (get-gc 40 att) 2 (getvar 'LUPREC))

oldwid (rtos (get-gc 41 att) 2 2)

oldsty (get-gc 7 att)

lststy (taolist "STYLE")

possty (vl-position oldsty lststy))

(setq editext.dcl (vl-filename-mktemp "edittext.dcl")

file_dcl (open editext.dcl "w"))

(foreach ll dcledittext (write-line ll file_dcl))

(close file_dcl)

(if (> 0 (setq dcl_id (load_dialog editext.dcl)))

(progn (alert "not found file edittext.dcl") (exit)))

(if (not (new_dialog "edit" dcl_id))

(progn (alert "not found edit dialog") (exit)))

(set_tile "text" oldval)

(set_tile "hei" oldhei)

(set_tile "wid" oldwid)

(set_tile "sty" (itoa possty))

(start_list "sty" 3)

(mapcar 'add_list lststy)

(end_list)

(setq #color (vla-get-color (vlax-ename->vla-object att))) (colimg "color" #color)

(action_tile "color" "(if (setq #color (acad_colordlg #color)) (colimg \"color\" #color))")

(action_tile "accept" "(getvalue) (vla-put-color (vlax-ename->vla-object att) #color)(setq dialog 1)(done_dialog)")

(action_tile "cancel" "(setq dialog nil)")

(start_dialog)

(unload_dialog dcl_id)

(if (eq dialog 1)

(progn (put-gc str 1 att) (put-gc hei 40 att) (put-gc wid 41 att) (put-gc (nth sty lststy) 7 att))))

(princ "select attrib/text")))

(if editext.dcl

(vl-file-delete editext.dcl))

(setvar "cmdecho" curcmd)

(setq *error* nil)

(princ))


<<

Filename: 381035_eb.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 381135
Tên lệnh: dttn caidatlai
[Nhờ Chỉnh Sửa] Lisp Tính Diện Tích Trên Nhiều Trắc Ngang

Đây là lisp mình viết đang còn hạn chế về tính tự động(chỉ tính từng hạng mục một).Bây giờ muốn phát triển thêm tính nhiều hạng mục

chỉ 1 lần chạy:

ý tưởng thì có nhưng viết lại không được mới khổ chứ:

1. Sẽ định nghĩa đối tượng tương ứng với hạng mục

Hạng mục 1

 1.1 chọn đối tượng

 1.2 chọn text hạng mục có sẳn (nếu ghi...

>>

Đây là lisp mình viết đang còn hạn chế về tính tự động(chỉ tính từng hạng mục một).Bây giờ muốn phát triển thêm tính nhiều hạng mục

chỉ 1 lần chạy:

ý tưởng thì có nhưng viết lại không được mới khổ chứ:

1. Sẽ định nghĩa đối tượng tương ứng với hạng mục

Hạng mục 1

 1.1 chọn đối tượng

 1.2 chọn text hạng mục có sẳn (nếu ghi thì tôt hơn)

 1.3 chọn đơn vị m or m2

Hạng mục 2

 1.1 chọn đối tượng

 1.2 chọn text hạng mục có sẳn (nếu ghi thì tôt hơn)

 1.3 chọn đơn vị m or m2

..........

Sau khi định nghĩa xong các hạng mục Enter thì lisp điền diện tích luôn.

Và đây là lisp:

(defun c:DTTN (/ NDTS dem1 lstkm point kcach point1 pointtim diemtam xuongdong kt diemtren1)
(setvar "CMDECHO" 0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq lop1 "entdauco")
  (prompt "\nChon Pline hoac Hatch mau tinh dien tich.")
  (setq fltr (ssx_fe))
  (prompt "\nChon Text ghi dien tich.")
  (setq DTS (car (entsel)))
  (setq DTS (entget DTS))
  (setq NDTS (cdr (assoc 1 DTS)))
  (command "-layer" "new" "Tinh dien tich TN" "color" "2" "Tinh dien tich TN" "")
  (command "-layer" "set" "Tinh dien tich TN" "")
(if (null cdtxt)
 (caidat)
)
 (setq th (getvar "textsize"))
 (setq dentay (- dentay (* 1.5 th)))
  ;(prompt "\nChon trac ngang.")
  (setq danhsachkm (acet-ss-to-list (ssget "X" (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 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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
    (vla-ZoomCenter (vlax-get-acad-object) (vlax-3D-point diemtam) (+ kcach 50))
    (setq dd (acet-ss-to-list (ssget "C" (polar pointtim 0 0.1 ) (polar pointtim 0 0.15 ) '((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))
	(setq diemtren1 (list (car diemcuoi) (cadr diemtren) 0))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq SSS (ssget "C" diemdau diemtren1 fltr)) 
(if (/= sss nil)
(progn
(setq i 0)
(setq s 0)
(setq N (sslength sss))
 (setq data (ssget "C" diemdau diemtren1 '((0 . "INSERT") (8 . "entdauco"))))
  (while (< i N)
  ;(luuos)
  (setvar "osmode" 0)
  (setq DT (ssname sss i))	
  (setq j 0)
  (setq ent1 (ssname data 0))
  (setq diemchuan (cdr (assoc 10 (entget ent1))))
  (Command "area" "o" DT)
  (if (= (getvar "area") 0)
  (progn
  (setq s (+ s (getvar "PERIMETER")))
  (setq i (1+ i))
  (setq donvi "m")
  )
  (progn
  (setq s (+ s (getvar "AREA")))
  (setq i (1+ i))
  (setq donvi "m2")
  )
  ))
  (setq diemghi (polar diemchuan 0 dentax))
  (setq diemghi (polar diemghi (/ pi 2) dentay))
  (setq txt NDTS)
  (command "TEXT" diemghi th 0 txt)
  (setq pointt11 (polar diemghi 0 cdtxt))
  (command "TEXT" pointt11 th 0 ":")
  (setq pointt1 (polar pointt11 0 cdsokl))
  (command "TEXT" "J" "R" pointt1 th 0 (rtos s 2 2))
  (setq point2 (polar pointt1 0 0.2))
  (command "TEXT" point2 th 0 donvi)
  ;(traos)
  )
  (progn
  (setq data (ssget "C" diemdau diemtren1 '((0 . "INSERT") (8 . "entdauco"))))
  (setq ent1 (ssname data 0))
  ;(luuos)
  (setvar "osmode" 0)
  (setq diemchuan (cdr (assoc 10 (entget ent1))))
  (setq diemghi (polar diemchuan 0 dentax))
  (setq diemghi (polar diemghi (/ pi 2) dentay))
  (setq txt NDTS)
  (command "TEXT" diemghi th 0 txt)
  (setq pointt11 (polar diemghi 0 cdtxt))
  (command "TEXT" pointt11 th 0 ":")
  (setq pointt1 (polar pointt11 0 cdsokl))
  (command "TEXT" "J" "R" pointt1 th 0 "0.00")
  (setq point2 (polar pointt1 0 0.2))
  (command "TEXT" point2 th 0 donvi)
  ;(traos)
  )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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")  
)
(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 ssx_fe (/ data fltr ent)
  (setq ent (car (entsel "\nSelect object <None>: ")))
  (if ent
    (progn
      (setq data (entget ent))
      (foreach x '(0 2 6 7 8 39 62 66 210) ; do not include 38
        (if (assoc x data)
          (setq fltr
            (cons (assoc x data) fltr)
          )
        )
      )
      (reverse fltr)
    )
  )
)
(defun Caidat (/ htxt httxt ltxt lsokl)
 (if (null dentax)
 (progn
 (setq dentax 10)
 (setq dentay 10)
 ))
 (setq x (getstring (strcat "\nKhoang cach dien phuong x <"(rtos dentax)"> :")))
 (setq y (getstring (strcat "\nKhoang cach dien phuong y <"(rtos dentay)"> :")))
 (if (/= x "") (setq dentax (atof x)))
 (if (/= y "") (setq dentay (atof y)))
(setq htxt 0.2)
(setq httxt (getstring (strcat "\nNhap chieu cao chu <"(rtos htxt)"> :")))
(if (/= httxt "") (setq htxt (atof httxt)))
(setvar "textsize" htxt)
(setq cdtxt 4.5)
(setq ltxt (getstring (strcat "\nNhap chieu dai chuoi <"(rtos cdtxt)"> :")))
(if (/= ltxt "") (setq cdtxt (atof ltxt)))
(setq cdsokl 0.75)
(setq lsokl (getstring (strcat "\nNhap chieu dai chu so khoi luong <"(rtos cdsokl)"> :")))
(if (/= lsokl "") (setq cdsokl (atof lsokl)))
)
(defun C:Caidatlai (/ htxt httxt ltxt lsokl)
(if (null dentax)
 (progn
 (setq dentax 10)
 (setq dentay 10)
 ))
 (setq x (getstring (strcat "\nKhoang cach dien phuong x <"(rtos dentax)"> :")))
 (setq y (getstring (strcat "\nKhoang cach dien phuong y <"(rtos dentay)"> :")))
 (if (/= x "") (setq dentax (atof x)))
 (if (/= y "") (setq dentay (atof y)))
(setq htxt 0.2)
(setq httxt (getstring (strcat "\nNhap chieu cao chu <"(rtos htxt)"> :")))
(if (/= httxt "") (setq htxt (atof httxt)))
(setvar "textsize" htxt)
(setq cdtxt 4.5)
(setq ltxt (getstring (strcat "\nNhap chieu dai chuoi <"(rtos cdtxt)"> :")))
(if (/= ltxt "") (setq cdtxt (atof ltxt)))
(setq cdsokl 0.75)
(setq lsokl (getstring (strcat "\nNhap chieu dai chu so khoi luong <"(rtos cdsokl)"> :")))
(if (/= lsokl "") (setq cdsokl (atof lsokl)))
) 

Đây là file test:

http://www.cadviet.com/upfiles/5/66960_vi_du.dwg

 


<<

Filename: 381135_dttn_caidatlai.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 381165
Tên lệnh: tbv
Tách Các Bản Vẽ Bên Layout Thành Từng Bản Vẽ Riêng Biệt

Share code cho "Nhạc sỹ" và bạn nào nếu cần.

+ Hạn chế của lisp:
* Như đã nói ở bài #13
- Khung ten Block
- Layout
(vấn đề này có thể gải quyết bằng cách dùng hộp thoại để chọn Layout, và Block)
- Nếu trong layout có nhiều viewport lồng vào nhau thì lisp chưa xử lý được.

+ Code chưa tối ưu, đang còn lộn xộn ... :D

(defun xuat-file (/ e i ss ssg ssv)
(command "_ucs"...

>>

Share code cho "Nhạc sỹ" và bạn nào nếu cần.

+ Hạn chế của lisp:
* Như đã nói ở bài #13
- Khung ten Block
- Layout
(vấn đề này có thể gải quyết bằng cách dùng hộp thoại để chọn Layout, và Block)
- Nếu trong layout có nhiều viewport lồng vào nhau thì lisp chưa xử lý được.

+ Code chưa tối ưu, đang còn lộn xộn ... :D

(defun xuat-file (/ e i ss ssg ssv)
(command "_ucs" "_w")
(vlax-for x (vla-get-layouts acaddoc)
(if (wcmatch (vla-get-name x) "QUOCMANH-*")
(progn (vla-put-ActiveLayout acaddoc x)
(vla-ZoomExtents acadapp)
(vla-put-ActiveLayout acaddoc acadlyt))))
(foreach l (cdr (layoutlist))
(setvar 'ctab l)
(if (> (sslength (ssget "_x" (list (cons 410 (getvar 'ctab))))) 1)
(progn (vla-endundomark acaddoc)
(vla-startundomark acaddoc)
(vlax-for x (vla-get-layouts acaddoc)
(and (/= (vla-get-name x) (getvar 'ctab))
(vl-catch-all-apply 'vla-delete (list x))))
(if (setq ss (ssget "_X" (list (cons 410 "Model"))))
(progn (if (setq ssv (ssget "_X" (list (cons 0 "VIEWPORT"))))
(mapcar '(lambda (e) (Vla-Display (vlax-ename->vla-object e) :vlax-true))
(mapcar 'cadr (ssnamex ssv))))
(vla-put-mspace (vla-get-ActiveDocument (vlax-get-acad-object)) :vlax-true)
(setq ssg (ssget "_W" (getvar 'EXTMIN) (getvar 'EXTMAX)))
(setq i 0)
(while (setq e (ssname ssg i)) (setq ss (ssdel e ss)) (setq i (1+ i)))
(mapcar '(lambda (e) (vla-delete (vlax-ename->vla-object e)))
(mapcar 'cadr (ssnamex ss)))))
(vla-put-mspace (vla-get-ActiveDocument (vlax-get-acad-object))
:vlax-false)
(command "_-wblock"
(strcat (getvar 'dwgprefix) (vl-filename-base (getvar 'dwgname)) "-" l)
"*")
(vla-endundomark acaddoc)
(command "_u"))))
(princ))
;;------------------------------------------------------------------
(defun c:tbv (/ maxp minp acadapp acaddoc acadlyt lst-nn vars vals sbv ssb)
(vl-load-com)
(if (and (member "Layout" (layoutlist))
(ssget "_X"
(list (cons 0 "INSERT") (cons 2 "KHUNG TEN") (cons 410 "Layout"))))
(progn (setq vars '("FILEDIA" "EXPERT" "TILEMODE" "CTAB" "REGENMODE" "CMDECHO" "LAYOUTREGENCTL" "OSMODE")
vals (mapcar 'getvar vars))
(mapcar 'setvar vars '(0 5 1 "Layout" 0 0 0 0))
(setq acadapp (vlax-get-acad-object)
acaddoc (vla-get-ActiveDocument acadapp)
acadlyt (vla-get-ActiveLayout acaddoc))
(createlayobj)
(vlax-for x (vla-get-layouts acaddoc)
(if (wcmatch (vla-get-name x) "QUOCMANH-*")
(progn (vla-put-ActiveLayout acaddoc x)
(vla-ZoomExtents acadapp)
(vla-put-ActiveLayout acaddoc acadlyt))))
(xuat-file)
(vlax-for x (vla-get-layouts acaddoc)
(if (wcmatch (vla-get-name x) "QUOCMANH-*")
(vla-delete x)))
(mapcar 'setvar vars vals)
(if sbv
(alert
(strcat "Co "
(itoa sbv)
" file ban ve duoc tach ra! \nLisp write by QuocManh04tt-Cadviet.com."))))
(alert "Khong ton tai layout co ten: Layout! \nHoac Block KHUNG TEN..."))
(princ "\nLisp write by QuocManh04tt-Cadviet.com.")
(princ))
;;--------------------------------------------------
(defun createlayobj (/ create-layout nl i ss k lst ssold copy2layout lay-out lso lst-new-layout)
(defun create-layout (name)
(vl-catch-all-apply '(lambda () (vla-add (vla-get-layouts acaddoc) name)))
(vla-item (vla-get-layouts acaddoc) name))
(defun copy2layout (k / lobj i llst layout tab lay)
(if (setq ss (ssget "_C" minp maxp (list (cons 410 "Layout"))))
(progn (repeat (setq i (sslength ss))
(setq lobj (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lobj)))
(if (= 1 (getvar 'cvport))
(setq tab (strcase (getvar 'ctab)))
(setq tab "MODEL"))
(vlax-invoke (vla-get-activedocument (vlax-get-acad-object))
'CopyObjects
lobj
(vla-get-block (nth k lst)))
(vla-ZoomExtents (vlax-get-acad-object)))))
;; --- MAIN ----
(if (setq ssb (ssget "_X"
(list (cons 0 "INSERT") (cons 2 "KHUNG TEN") (cons 410 "Layout"))))
(progn (if (not (member "QUOCMANH-1" (layoutlist)))
(progn
(repeat (setq i (sslength ssb))
(create-layout (strcat "QUOCMANH-" (itoa i)))
(setq lst-new-layout (cons (strcat "QUOCMANH-" (itoa i)) lst-new-layout))
(setq i (1- i)))))
;; listlayout
(vlax-for lay (vla-get-layouts (vla-get-activedocument (vlax-get-acad-object)))
(if (/= tab (strcase (vla-get-name lay)))
(setq lst (cons lay lst))))
;;del old obj
(vlax-for x (vla-get-layouts acaddoc)
(if (wcmatch (vla-get-name x) "QUOCMANH-*")
(progn (setq lst-nn (cons (vla-get-name x) lst-nn)
lay-xl (cons x lay-xl))
(vla-put-ActiveLayout acaddoc x)
(vla-ZoomExtents acadapp)
(vla-put-ActiveLayout acaddoc acadlyt)
(if (setq ssold (ssget "_X" (list (cons 410 (vla-get-name x)))))
(mapcar '(lambda (e) (vla-delete (vlax-ename->vla-object e)))
(mapcar 'cadr (ssnamex ssold)))))))
;; copy obj
(if (setq ssb (ssget "_X"
(list (cons 0 "INSERT") (cons 2 "KHUNG TEN") (cons 410 "Layout"))))
(progn (setq k 0
sbv (sslength ssb))
(repeat (length (setq lso (mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ssb))))))
(vla-getBoundingBox (nth k lso) 'Minp 'Maxp)
(setq minp (vlax-safearray->list Minp)
maxp (vlax-safearray->list Maxp))
(copy2layout k)
(setq k (1+ k))))))))

* File bản vẽ thứ 2 của chủ thớt có nhiều viewport lồng vào nhau​


<<

Filename: 381165_tbv.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 110216
Tên lệnh: tktxt
Viết lisp theo yêu cầu [phần 2]

Chào bạn Truongthanh,
Mình bổ sung đoạn code check style vào trong lisp này. Khi chạy nó sẽ tự kiểm tra xem trong bản vẽ của bạn đã có style "1" hay chưa. Nếu chưa có nó sẽ tạo style "1" giống như cái style "1" mà bạn đang sử dụng trong bản vẽ testnew.dwg. Và như vậy kết quả sẽ luôn hiện tiếng Việt như bạn mong muốn.
Bạn phải cảnh giác nếu như trên file bản vẽ của bạn đã có...
>>

Chào bạn Truongthanh,
Mình bổ sung đoạn code check style vào trong lisp này. Khi chạy nó sẽ tự kiểm tra xem trong bản vẽ của bạn đã có style "1" hay chưa. Nếu chưa có nó sẽ tạo style "1" giống như cái style "1" mà bạn đang sử dụng trong bản vẽ testnew.dwg. Và như vậy kết quả sẽ luôn hiện tiếng Việt như bạn mong muốn.
Bạn phải cảnh giác nếu như trên file bản vẽ của bạn đã có style "1" nhưng nó lại không phải là font Arial.tif thì text sẽ hiển thị không đúng đâu nhé. Vì thế nên kiểm tra kỹ font text trước khi chạy lisp bạn nhé.
Lisp đây:


Hy vọng bạn sẽ hài lòng.
<<

Filename: 110216_tktxt.lsp
Tác giả: hiepttr
Bài viết gốc: 381599
Tên lệnh: dong
[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

Rảnh nên mò mẫn lại tí, quên cả rồi :D

(defun c:DONG ()
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
	  tlt...
>>

Rảnh nên mò mẫn lại tí, quên cả rồi :D

(defun c:DONG ()
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
	  tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
	  tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
(foreach c coc
	(setq trai (vlax-invoke (vlax-ename->vla-object c) 'intersectwith tlt acExtendThisEntity)
		  phai (vlax-invoke (vlax-ename->vla-object c) 'intersectwith tlp acExtendThisEntity))
	(command "_.insert" "cocmoc" trai 25.4 "" "")
	(command "_.insert" "cocmoc" phai 25.4 "" "")
)
(mapcar 'setvar lst_va old)
(princ)
)

- Để block được chèn đúng vị trí, bạn cần:

    Chỉnh sửa điểm chèn cái block của bạn đúng tâm đường tròn (đã có bài hướng dẫn cụ thể trên diễn đàn)

   ..... :D :D :D


<<

Filename: 381599_dong.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 381613
Tên lệnh: ccmb
[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

Các pro giúp em với

Hề hề hề,

Bạn tham khảo lisp sau đây. Lưu ý hai vấn đề sau:

1/ Bạn phải tạo block "cocmoc1" có các thành phần giống như block cocmoc của bạn nhưng có điểm chèn là tâm của hình tròn bao. (mình đã tạo block này trong file bản vẽ gửi kèm ở bài này)

2/-...

>>

Các pro giúp em với

Hề hề hề,

Bạn tham khảo lisp sau đây. Lưu ý hai vấn đề sau:

1/ Bạn phải tạo block "cocmoc1" có các thành phần giống như block cocmoc của bạn nhưng có điểm chèn là tâm của hình tròn bao. (mình đã tạo block này trong file bản vẽ gửi kèm ở bài này)

2/- hãy xóa các pline mép taluy trùng nhau (khá nhiều đấy) để tránh chèn trùng lắp quá nhiều block. (Trong file bản vẽ kèm theo ở đây mình đã xáo hết chỉ để lại mỗii bên một đường thôi.)

Hãy test thử và cho ý kiến nếu cần chỉnh sửa nhé.

 

http://www.cadviet.com/upfiles/5/5194_camcocgpmb_1.lsp

 

http://www.cadviet.com/upfiles/5/5194_64560_gpmbbd_1.dwg

(defun c:ccmb (/ oldos ls1 ls2 plst )
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(alert "Chon cac coc tim duong")
(setq ls1 (acet-ss-to-list (ssget (list (cons 0 "line") (cons 8 "entcoc")))) )
(alert "Chon cac duong mep taluy ")
(setq ls2 (acet-ss-to-list (ssget (list (cons 0 "*line") (cons 8 "dientichtn")))) 
          plst (list) )
(foreach e1 ls1
         (foreach e2 ls2
                (setq plst (append plst (acet-geom-intersectwith e1 e2 1)))
         )
)
(command "undo" "be")
(foreach p plst
         (command "insert" "cocmoc1" p 1 1 0)
)
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)

<<

Filename: 381613_ccmb.lsp
Tác giả: ketxu
Bài viết gốc: 227341
Tên lệnh: tor
lisp xoay text theo pline

Quick code cho bạn :

(defun c:tor(/ ob)(vl-load-com)
    ;Xoay text theo 1 duong dan
    ;Ketxu quick code 25/2
    (cond 
        ((and
            (setq ob (entsel "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng d\U+1EABn : "))
            (ssget (list (cons 0 "TEXT,MTEXT")))
        )
        (setq ob (car ob))
        (vlax-for obT (vla-get-ActiveSelectionSet...
>>

Quick code cho bạn :

(defun c:tor(/ ob)(vl-load-com)
    ;Xoay text theo 1 duong dan
    ;Ketxu quick code 25/2
    (cond 
        ((and
            (setq ob (entsel "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng d\U+1EABn : "))
            (ssget (list (cons 0 "TEXT,MTEXT")))
        )
        (setq ob (car ob))
        (vlax-for obT (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))
            (vla-put-Rotation 
                obT
                ((lambda(a)(if (and (> a (/ pi 2.)) (<= a (* pi 1.5)))(+ a pi) a))
                (+ (* 0.5 pi)
                (angle     (setq a (vlax-get obT 'InsertionPoint))
                        (vlax-curve-getclosestpointto ob a T)
                )))
            )
        ))
        (T (alert "L\U+1ED7i thao t\U+00E1c!"))
    )
    (princ)
)

<<

Filename: 227341_tor.lsp

Trang 196/330

196