Bạn có thể dựa theo cấu trúc sau để tạo các layer cần thiết cho mình

(DEFUN C:tla() 
(setvar "cmdecho" 0)
 (COMMAND...
>>

Bạn có thể dựa theo cấu trúc sau để tạo các layer cần thiết cho mình

(DEFUN C:tla() 
(setvar "cmdecho" 0)
 (COMMAND "LAYER" "M" "TIM" "C" "8" "" "L" "DASHDOT" "" "");tao layer Tim mau 8 net ve la dashdot
 (COMMAND "LAYER" "M" "KHUAT" "C" "9" "" "L" "HIDDEN" "" "")
 (COMMAND "LAYER" "M" "Text" "C" "11" "" "")
 (COMMAND "LAYER" "M" "Ghichu" "C" "2" "" "")
 (COMMAND "LAYER" "M" "1" "C" "2" "" "")
 (COMMAND "LAYER" "M" "dim" "C" "2" "" "")
 (COMMAND "LAYER" "M" "thep" "C" "6" "" "")
 (COMMAND "LAYER" "M" "dai" "C" "1" "" "")
 (COMMAND "LAYER" "M" "0" "C" "7" "" "")
 (COMMAND "LAYER" "M" "hatch" "C" "251" "" "")
 (COMMAND "LAYER" "M" "Bao chinh" "C" "4" "" "")
 (setvar "cmdecho" 1)
)

 

Qủa là tuyệt vời thanks bạn rất nhiều.

<<

Của bạn đây.Khi tìm kiếm có phân biệt chữ hoa - chữ thường

 

;free líp from cadviet.com @ ketxu
(defun c:fz( /...
>>

Của bạn đây.Khi tìm kiếm có phân biệt chữ hoa - chữ thường

 

;free líp from cadviet.com @ ketxu
(defun c:fz( / t2f sss lst ent minpoint maxpoint oEcho)
(vl-load-com)
(setq oEcho (getvar "cmdecho"))
(setvar "cmdecho" 0)
 (setq
   t2f (getstring t "\nChuoi can tim (ket thuc bang enter):")
   sss (ssget "X" (list (cons 0 "TOLERANCE") (cons 1 (strcat "*" t2f "*"))))        
   lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex sss)))
 )
(alert (strcat "\nTim thay " (itoa (length lst)) " doi tuong!"))  
(foreach ent lst
(vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
(setq minpoint (vlax-safearray->list minpoint) 
   maxpoint (vlax-safearray->list maxpoint))
   (command ".zoom" minpoint maxpoint)
   (command ".zoom" "0.5xp")    
   (getstring "\nNhan enter hoac spacebar de tiep tuc!")
 )
(setvar "cmdecho" oEcho)
 (princ)
)

Cảm ơn bạn rất nhiều mình đang test và thấy rất OK! Có gì mình phản hồi sau nhé!

P/S: Cho mình hỏi diễn đàn mới nâng cấp giao diện mình ko thấy nút thanks đâu hết, với lại chức năng download lisp ko dùng được hay sao đó, down xuống mở lên chỉ có 1 hàng à!

<<

Bạn thử đoạn code này xem :

(defun c:COA()
(prompt "\n Chon doi tuong : ")
(setq ss (ssget))
(setq p1 (getpoint "\n Specify first source point : "))
(setq p2 (getpoint p1"\n...
>>

Bạn thử đoạn code này xem :

(defun c:COA()
(prompt "\n Chon doi tuong : ")
(setq ss (ssget))
(setq p1 (getpoint "\n Specify first source point : "))
(setq p2 (getpoint p1"\n Specify first destination point: "))
(setq p3 (getpoint "\n Specify Second source point : "))
(setq p4 (getpoint p3 "\n Specify Second destination point: "))
(command "copy" ss "" p1 "@")
(command "align" ss "" p1 p2 p3 p4 "" "")
(princ)
)

Specify first source point :

Specify first destination point:

Specify Second source point :

Specify Second destination point: giống như lệnh Align

 

Mong bạn làm được :s_big:

Cảm ơn các bác đã tận tình viết lisp giúp em.

Bác Tue_NV bác sửa lại cho em sao cho lisp đó khi Align có thể Scale được (Giống như lệnh Align binh thường )

Cái dòng đó em nhớ hình như: "Scale Objects based on alignment point/ Yes/ No

Cảm ơn bác .

<<

Xin giới thiệu với các bác đoạn lisp mà em mày mò mãi (với VBA thì vấn đề có vẻ đơn giản (các bác cao thủ nói vậy chứ em chưa...

>>

Xin giới thiệu với các bác đoạn lisp mà em mày mò mãi (với VBA thì vấn đề có vẻ đơn giản (các bác cao thủ nói vậy chứ em chưa thực hành VBA nhiều lắm) nhưng để làm "thuần lisp" thì phải ...tốn công fu hơn

Lệnh e2x: chọn các text sắp xếp theo dạng bảng (ko cần căn thẳng hàng cột)

Kết quả: file xuất ra dưới dạng "giả excel" (Lisp chỉ làm được đến thế này thôi, bạn fải thêm một công ...open & save as --> Thành excel xịn ngay)

 

(defun myerror (s)
(cond
((= s "quit / exit abort") (princ))
((/= s "Function cancelled") (princ (strcat "\nError: " s)))
)
(setvar "cmdecho" CMD) ; Restore saved modes
(setvar "osmode" OSM)
(setq *error* OLDERR) ; Restore old *error* handler
(princ)
)

;;;=========================================================================
(defun bocchu (ss1 c)
(setq ob (entget (ssname ss1 c)))
(setq ts (assoc 1 ob))
(setq a (cdr ts))
)

(defun boc1chu (ob)
(if (/= ob nil)
(progn
(setq ts (assoc 1 ob))
(setq a (cdr ts))
)
)
)


(defun Txtnum (num)
(if (> num 0)
(strcat "+" (rtos num 2 0))
(rtos num 2 0)
)
)
;;;=================================
(defun Txtint (num)
(rtos num 2 0)

)

(defun Txtreal (num) (rtos num 2 2))
(defun Txtreal1 (num) (rtos num 2 0))

(defun thaychu (Ob newstr / obtmp)
(setq txtstr (assoc 1 Ob))
(setq newstr (cons 1 newstr)
obtmp (entmod (subst newstr txtstr Ob))
)
(entupd (cdr (assoc -1 obtmp)))
)
(defun chonchu (dongnhac)
(prompt dongnhac)
(ssget
'((-4 . "<OR") (0 . "text") (0 . "mtext") (0 . "ATTRIB") (-4 . "OR>"))
)
)

(defun chon1chu (dongnhac / obj objtype)
(if (setq obj (nentsel dongnhac))
(setq obj (entget (car obj))
objtype (cdr (assoc 0 obj))
)
)
(if (member objtype '("ATTRIB" "MTEXT" "TEXT"))
(setq obj obj)
)
)


(defun chon (str) (ssget '((cons (0 str)))))
(defun bamchon (st) (entget (car (entsel st))))
(defun bocdt (ss1 c) (entget (ssname ss1 c)))


;;;====================================================================
;;; Ham kiem tra xem mot so co nam trong day so ko voi sai so cho san
(defun memberp (num listn tsaiso / cter ni ntest test)
(setq cter 0
test nil
)
(while (< cter (length listn))
(setq ntest (nth cter listn)
sstest (abs (- num ntest))
)
(if (<= sstest tsaiso)
(setq cter (length listn)
test T
)
(setq cter (1+ cter))
)
)
(if test
(setq ntest ntest)
(setq ntest nil)
)
(setq ntest ntest)
)

;;;=======================================================================
;;;;=============================================================
;;; Chep du lieu bang ra file xls (du lieu lon xon khong thang hang cot)
(defun C:e2x (/ Txtline txtfile nrow ncol Filedir count count1 Cpright)
(setvar "cmdecho" 0)
(setq OldLay (getvar "Clayer"))

(Setq Cpright
"Copyright by NguyÔn Gia §¹t <Datnggia@gmail.com - 0915169886>"
)
(setq sstab (chonchu "\nChon bang du lieu ...")
sstmp sstab
cter 0
nn (sslength sstmp)
tabdata '()
htext 0
)

;;; loc ra bang du lieu
(while (< cter nn)
(setq objtxt (entget (ssname sstmp cter))
content (cdr (assoc 1 objtxt))
htext (+ htext (cdr (assoc 40 objtxt)))
objtype (cdr (assoc 0 objtxt))
)
(if (= objtype "TEXT")
(progn
(setq just (cdr (assoc 72 objtxt))
)
(if (= just 0)
(setq idtxt (cdr (assoc 10 objtxt)))
(setq idtxt (cdr (assoc 11 objtxt)))
)
)
(setq idtxt (cdr (assoc 10 objtxt)))
)
(setq
objdata (list content idtxt)
tabdata (append tabdata (list objdata))
cter (1+ cter)
)
)

;;; Tim so hang , so cot cua bang du lieu

(setq cter 0
saiso (* 5 (/ htext nn))
xlist '()
ylist '()
)
(repeat nn
(setq objdata (nth cter tabdata)
Pobj (car (cdr objdata))
xobj (car Pobj)
yobj (cadr Pobj)

cter (1+ cter)

)
(if (not (memberp yobj ylist (* saiso 0.1)))
(setq ylist (append ylist (list yobj)))
)
(if (not (memberp xobj xlist saiso))
(setq xlist (append xlist (list xobj)))
)
)
(setq
ncol (length xlist)
nrow (length ylist)
)
;;; Sap xep toa do x, y theo thu tu
(setq xlist (vl-sort xlist '<)
ylist (vl-sort ylist '>)
)

;;; Sap xep du lieu bang thanh hang, cot
(setq tabdata
(vl-sort tabdata
(function (lambda (objdata1 objdata2)
(< (cadr (car (cdr objdata1)))
(cadr (car (cdr objdata2)))
)
)
)
)
)
;;; Chia bang du lieu thanh hang, cot
(setq txtfile '()
ctrow 0


)
(repeat nrow
(setq txtline '()
yrow (nth ctrow ylist)
ctrow (1+ ctrow)

)

(setq txtrow '()
xlistrow '()
cter 0
)
(repeat nn
(setq txtobj (nth cter tabdata)
xobj (car (cadr txtobj))
yobj (cadr (cadr txtobj))
cter (1+ cter)
)
(if (<= (abs (- yrow yobj)) (* 0.1 saiso))
(setq txtrow (append txtrow (list txtobj))
xlistrow (append xlistrow (list xobj))
)
)
)
(setq txtrow
(vl-sort txtrow
(function (lambda (objdata1 objdata2)
(< (car (car (cdr objdata1)))
(car (car (cdr objdata2)))
)
)
)
)
)
(setq ctcol 0
cter1 0)
(repeat ncol
(setq
xcol (nth ctcol xlist)
txtobj (nth cter1 txtrow)
ctcol (1+ ctcol)
cter1 (1+ cter1)
)
(if (memberp xcol xlistrow saiso)
(setq content (strcat (car txtobj) "\t")
)
(setq content (strcat " " "\t")
cter1 (1- cter1))
)

(setq txtline (append txtline (list content))
)

)
(setq txtfile (append txtfile (list txtline)))
)

;;; Chon file luu so lieu

(Setq FileDir (getfiled "File luu so lieu:" "" "xls" 1)
)


(setq cter 0
count (length txtfile)
FileID (open FileDir "w")
)
(write-line "B¶ng d÷ liÖu trÝch xuÊt tõ AutoCAD" FileID)
;(write-line "Stt\tTªn nót\tTo¹ ®é X\tTo¹ ®é Y" FileID)
(while (< cter count)
(setq Txtline (nth cter txtfile)
cter (1+ cter)
cter1 0
content ""
)
(repeat ncol
(setq Content (strcat content (nth cter1 txtline))
cter1 (1+ cter1)
)
)
(setq txtline content)
(write-line Txtline FileID)
)
(write-line Cpright FileID)

(close FileID)
(princ)
)

 

bác cho em hỏi với ạ : em chọn object rồi nhưng nó báo thế này là bị làm sao vậy bác " bad argument type: stringp nil "

<<

Download lisp

Filename: 365851_e2x.lsp

Bạn dùng thử Lisp thống kê Text trên bản vẽ

kết quả gồm 2 cột :

- cột 1 : số luợng Text

- cột 2 : giá trị Text

(defun c:tkt...
>>

Bạn dùng thử Lisp thống kê Text trên bản vẽ

kết quả gồm 2 cột :

- cột 1 : số luợng Text

- cột 2 : giá trị Text

(defun c:tkt (/ lst msp pt ss str txtsiz)
 (vl-load-com)
 (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) lst (list))
 (prompt (strcat "\nChon Text de Liet ke hay ENTER de chon tat ca :"))
 (if (null (setq ss (ssget(list (cons 0 "TEXT"))))) (setq ss (ssget "_X" (list(cons 410 (getvar "Ctab")) (cons 0 "TEXT")))))
 (if ss
   (progn
     (foreach e (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq str (vla-get-TextString 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)))
)
     (setq lst (vl-sort lst '(lambda (x y) (< (cdr x) (cdr y))))
    pt (getpoint "\nDiem dat Bang :" )
    txtsiz (* (getvar "dimtxt")(getvar "dimscale")))
     (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))

 

bạn giabach xem lại lisp dùm mình với, nghe giới thiệu thấy có vẻ rất hay và đáp ứng được yêu cầu, nhưng mình tải về, ko chạy được, có lẽ là lỗi ở 2 dòng lệnh điều kiện

 

(if (null (setq ss (ssget(list (cons 0 "TEXT"))))) (setq ss (ssget "_X" (list(cons 410 (getvar "Ctab")) (cons 0 "TEXT")))))

(if ss

 

mình mới ngâm cứu cái món này nên chưa biết chỉnh lại thế nào cả :undecided:

<<

Tks bác vì ý tưởng toggle current Viewport ^^

Vậy ta sửa như thế này, tránh động chạm đến thằng ACET :

(defun...
>>

Tks bác vì ý tưởng toggle current Viewport ^^

Vậy ta sửa như thế này, tránh động chạm đến thằng ACET :

(defun C:vtl ( / SelSet ST:VP-Toggle-DisplayLocked) ;VP toggle Locked
;======== Local Function =========
(defun ST:VP-Toggle-DisplayLocked (vpObj / rt)
;vp : vlaObject
;RT : T if Lock VP / nil if Open
(cond ((eq (vla-get-DisplayLocked vpObj) :vlax-false)(vla-put-DisplayLocked vpObj :vlax-true)(setq rt T)(vla-put-color vpObj acBlue))
	(T (vla-put-DisplayLocked vpObj :vlax-False)(vla-put-color vpObj acByLayer)))
)
;========== Start Here ==============
(grtext -1 "Free Lisp from Cadviet @Ketxu")
(cond
 ((< (atof (getvar "ACADVER")) 15.0)
  (alert " Lisp requires AutoCAD 2000 or higher. "))
 ((= (getvar "TILEMODE") 1)  
  (alert " Lisp can only be done in paper space. "))
 ((> (getvar "CVPORT") 1)
  (ST:VP-Toggle-DisplayLocked (vlax-ename->vla-object (ssname	(ssget "x" (list '(0 . "VIEWPORT") (cons 69 (getvar 'CVport)) (cons 410 (getvar 'CTab)))) 0))))
 ((and
   (not (prompt "\nSelect Viewport for (un)lock... "))
   (not (setq SelSet (ssget '((0 . "VIEWPORT"))))))
  (princ "Nothing or no Viewport selected."))
 (T
  (vl-load-com)
  (vlax-for vpObj (setq SelSet (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
    (ST:VP-Toggle-DisplayLocked vpObj)     
   )))
(princ)
)

@chủ topic : ngoài ra có thể pick vào biểu tượng hình cái khóa trên Status Bar

Nhìn trình card của các bạn mà thèm. Câu hỏi có vẻ hơi thừa nhưng cho mình hỏi là mình đã load cái lisp của các bạn vào rồi. Đã báo thành công sau đó dùng lệnh gì để khóa hoặc mở khóa hả bạn.

<<

Chuyển về Bylayer các đối tượng chọn theo ý tưởng của bạn thì :

;; free lisp from cadviet.com...
>>

Chuyển về Bylayer các đối tượng chọn theo ý tưởng của bạn thì :

;; free lisp from cadviet.com @ssg

;;;-------------------------------------------------------------------------------
(defun remc(s / sn i OK sc ch) ;;;Remove color code
(setq sn "" i 1 OK T)
(repeat (strlen s)
  (setq
       sc (substr s i 2)
       ch (substr s i 1)
  )
  (if (= sc "\\C") (setq OK nil))
  (if OK
      (setq sn (strcat sn ch))
      (if (= ch ";") (setq OK T)) 
   )
   (setq i (1+ i))
)
sn
)
;;;-------------------------------------------------------------------------------
(defun C:CBL(/ ss e d old new) ;;;Reset all objects ByLayer
(setq ss (ssget "X" '((0 . "MTEXT"))))
(while (setq e (ssname ss 0))
   (setq
       d (entget e)
       old (assoc 1 d)
       new (cons 1 (remc (cdr old)))
       d (subst new old d)
  )
  (entmod d)
  (ssdel e ss)
)
(command "change" (ssget "X") "" "p" "C" "bylayer" "LT" "bylayer" "LW" "bylayer" "")
(princ)
)
;;;-------------------------------------------------------------------------------

<<

 

Mình thấy trên diễn đàn có lisp tính tổng chiều dài như thế này

(defun add_mline ()
(foreach...
>>

 

Mình thấy trên diễn đàn có lisp tính tổng chiều dài như thế này

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



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun C:tg (/ tot_len ss e_name e_record e_type)
(princ "\nCADViet.com © 2007")
(setq tot_len 0.0)
(setq ss (ssget))
(if (null ss)
(exit)
)
(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))
)
)
(prompt (strcat "\nTotal length is: " (rtos tot_len 2 2)))
(princ)
)
(princ "\ntg - free lisp from www.cadviet.com")
(princ)

Bây giờ muốn mọi người sửa giúp kết quả cuối cùng là chọn text để ghi thay cho kết quả hiện ra trên màn hình, thanks.

Mình đang sử dụng lisp này ở cad 2012 trở xuống OK

Nhưng khong hiểu sao khi dùng trên Cad 2015 bản quyền thì lại bị lỗi,rõ ràng đã thông báo load thành công?

Bác nào có thể giải thích giúp em không,liệu có phải sửa gì không ah.

Nó báo:error funtion cancelled

Các bác giup em với.thanks

<<

Bạn đã bao giờ mệt vì phải tính toán để đánh cốt cao độ của mặt cắt và mặt đứng hay chưa?

vừa phải tính xem từ điểm cần tính đến cốt 0.00 có khoảng...

>>

Bạn đã bao giờ mệt vì phải tính toán để đánh cốt cao độ của mặt cắt và mặt đứng hay chưa?

vừa phải tính xem từ điểm cần tính đến cốt 0.00 có khoảng cách h bao nhiêu, rồi lại nhập vào bản vẽ.

 

Bây giờ, bạn có thể làm điều này một cách nhanh chóng và tự động nhờ vào lisp dc của cadviet.

với lisp này, bạn chỉ cần gõ lệnh dc, chương trình sẽ hỏi bạn điểm bạn cần đánh cốt, sau đó chương trình sẽ chèn ký hiệu cốt vào đúng vị trí và giá trị mà bạn cần. Bạn dùng lệnh cot00 để định nghĩa điểm có cao độ là cot00.

 

Để sử dụng lệnh, trước tiên phải copy file cot.dwg vào thư mục support - Đây là file chứa nội dung của ký hiệu cốt. Sau đó appload file danhcot.lsp để sử dụng lệnh.

 

(defun c:cot00 ()
 (setq Cot00 (cadr (getpoint "\nDiem co cot 0.000: ")))
 (princ)
)
(defun c:dc (/ diem caodo dau giatri dodaichuoi)
 (if (not cot00)
(progn
  (alert "chua co cot 0.000")
  (c:cot00)
)
 )
 (grdraw (list	(+ (car (getvar "VIEWCTR")) (* -1.0 (getvar "VIEWSIZE")))
	cot00
  )
  (list	(+ (car (getvar "VIEWCTR")) (* 1.0 (getvar "VIEWSIZE")))
	cot00
  )
  1
  1
 )
 (setq
diem   (getpoint "\nVao diem can danh cot: ")
caodo  (- (cadr diem) cot00)
dau	   (cond
	 ((equal caodo 0.0 0.01) "%%p")
	 ((> caodo 0.0) "+")
	 (t "-")
   )
giatri (rtos caodo 2 0)
 )
 (if (= "-" (substr giatri 1 1))
(setq giatri (substr giatri 2))
 )
 (while (< (strlen giatri) 4)
(setq giatri (strcat "0" giatri))
 )
 (setq	dodaichuoi (strlen giatri)
giatri	   (strcat (substr giatri 1 (- dodaichuoi 3))
		   "."
		   (substr giatri (- dodaichuoi 2))
	   )
 )
 (command ".insert" "danhcot" diem 100.0 100.0 0.0 dau giatri)
 (redraw)
)

file danhcot.lsp: http://www.cadviet.com/upfiles/danhcot.lsp

file danhcot.dwg: http://www.cadviet.com/upfiles/DANHCOT.zip

 

Lưu ý: Với mỗi file DWG mà bạn vẽ, bạn phải đặt lại biến ATTDIA về 0 trước khi dùng lệnh DC (chỉ cần đặt 1 lần cho mỗi file).

 

Rất mong có được sự phản hồi.

Cảm ơn.

<<

 

Viết cho anh em xài. Lisp chấp nhận cả Cos cao...

>>

 

Viết cho anh em xài. Lisp chấp nhận cả Cos cao độ dạng Text hoặc ATT, và tất nhiên lấy text đầu - ATT đầu của Block đầu xử lý

(defun c:dc (/ lstSS txtstr p1 p2 listname txt txt1 ss)
(vl-load-com)
(defun dowith(lstSS / lstSS en str)
(cond  ((setq en  (car (vl-remove-if-not '(lambda(x)(wcmatch (cdadr (entget x))"*TEXT")) lstSS)))(setq str (acet-dxf 1 (entget en)) en (vlax-ename->vla-object en)))
 ((setq en (car (vl-remove-if-not '(lambda(x)(and (wcmatch (cdadr (entget x))"INSERT")(= (acet-dxf 66 (entget x)) 1))) lstSS)))
  (setq str (vla-get-textstring (setq en(car (vlax-invoke (vlax-ename->vla-object en) 'GetAttributes)))))
 )
)
(cons en str)
)
(grtext -1 "Free lisp from Cadviet @Ketxu")
(setq  lstSS (acet-ss-to-list (setq ss (ssget)))
 obj (car (setq en (dowith lstSS)))
 str (cdr en)
 p1 (getpoint "\nBasepoint :")
 eL (entlast)
)
(while (setq p2 (getpoint p1 "\nTo point :"))
(command "copy" ss "" p1 p2)
(while (setq EL (entnext EL)) (setq Listname (cons EL Listname)))
(setq  Txt1 (car (dowith listName))
 eL (entlast)
)
(vla-put-textstring txt1
(strcat (cond ((> (setq num (+ (atof str) (/ (- (cadr p2)(cadr p1)) 1000))) 0) "+")
((= num 0) "%%p")
(T "")
  )
(rtos num  2 3))
)
)
)

 

 

 

Vô cùng cảm ơn bạn ketxu. Cuối cùng tờ cũng thấy được thành Rome rồi. Lisp này thì bất kể ai dùng cũng được và tự tạo ký hiệu cos theo ý thích. một lần nữa cảm ơn ketxu. Chúc bạn vui vẻ

<<

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

 

 

Hi hi đ­ược rồi ạ ! cảm ơn Mr Thái ! Chúc Bác mạnh khoẻ !

<<

lít copy tăng dần cop đến hàng nghìn cũng OK, không bit lit này cổ chưa nhưng vẫn pos

nếu ai chưa có thank một tiếng động viên...

>>

lít copy tăng dần cop đến hàng nghìn cũng OK, không bit lit này cổ chưa nhưng vẫn pos

nếu ai chưa có thank một tiếng động viên cái!

 (defun C:CT (/ name_op num_op_chon point_base_st point_new_st num_ op_tang 
                 op_tang_new last_ch cong_val)
(setq old_ts_err *error*)
(setvar "Cmdecho" 0)
(if(= cong_vao NIL)(setq cong_vao 1))
(Prompt "\n Neu tham so < 0  --> ket qua giam ! ")
(setq cong_val(getint(strcat "\n Tham so tang /<" (itoa cong_vao)">: ") ))
     (if(= cong_val NIL)(setq cong_val cong_vao)(setq cong_vao cong_val))
(Prompt "\n Chon doi tuong tang: ") 
(if(and cong_vao (setq op_tang(ssget)))
  (progn
   (setq num_op_chon(sslength op_tang)
         num_ 0 
         op_tang_new NIL)
   (if(setq point_base_st(getpoint "\n > Diem goc: "))
      (while 
      (setq point_new_st(getpoint "\n >> Diem dat tiep theo: " point_base_st)) 
         (if op_tang_new (setq op_tang op_tang_new op_tang_new NIL))
         (setq num_op_chon(sslength op_tang) op_tang_new(ssadd))
         (if(and point_base_st point_new_st)
            (progn
             (repeat num_op_chon
               (progn
                  (setq name_op(ssname op_tang num_))
                  (command "_.Copy" name_op "" point_base_st point_new_st)
	   (setq last_ch(entlast)
                        op_tang_new(ssadd last_ch op_tang_new))
                  (process)
                  (setq num_ (+ 1 num_))
                    (if(= num_ num_op_chon)(setq num_ 0))
               )
             ) 
            )
         );if
         (setq point_base_st point_new_st)
      ));if while
  );progn
);if  
(setq *error* old_ts_err)
(princ)
);End Tang.
(defun process (/ name_check text_value dat_up dat_style num_value new_value)
(progn
             (setq name_check(assoc 0 (setq dat_up (entget last_ch))) )
             (if(or(= (cdr name_check) "TEXT")
                   (= (cdr name_check) "MTEXT"))
                (progn
                  (setq text_value(assoc 1 dat_up))
                  (if(= (distof (cdr text_value) 2) NIL)
                     (setq dat_style "Text")
                     (setq dat_style "Num" num_value (atof (cdr text_value)) )
                  )
                  (cond
                     ((= dat_style "Num")
                      (setq new_value (itoa (fix(+ num_value cong_vao))) ))
                     ((= dat_style "Text")
                      (setq new_value(chr (+ (ascii (cdr text_value)) cong_vao))) )
                  )
                  (setq dat_up(subst (cons '1 new_value) text_value dat_up) )
                  (entmod dat_up)
                );progn 
             );if
             (setq name_op NIL)
);progn
);Process.

lisp này có lâu rùi mà. dù sao vẫn thanks bạn rùi đó^^

<<

 

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

Mới chỉ có khả...

>>

 

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

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

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

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

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

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

Đây là líp

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

"Cách tắt Check chính tả và bật mấy cái vụ làm chữ đậm, in nghiêng, bôi đen tô mầu"

Cái này ngày trc mh cũng bị mắc, nhưng sau một t.g mày mò mh đã có cách khắc phục rất tiện dụng, nhanh, chính xác. Mình ở HN khi nào rảnh qua mh hd, nói chung là nhanh thui.

<<

Bạn thử xài đoạn lisp nay xem. Các text gần nhau sẽ chuyển sang màu xanh và bạn chọn lệnh ssx để lọc và xóa đối tượng

 

(defun c:xoatext...
>>

Bạn thử xài đoạn lisp nay xem. Các text gần nhau sẽ chuyển sang màu xanh và bạn chọn lệnh ssx để lọc và xóa đối tượng

 

(defun c:xoatext (/)
 (command "_.undo" "be")
 (setvar "cmdecho" 0)
 (setq ss (ssget (list (cons 0 "TEXT"))))
 (if (= kc nil)
   (setq kc1 5)
   (setq kc1 kc)
 )
 (setq kc (getreal (strcat "\nKhoang cach min: <" (rtos kc1) ">")))
 (if (= kc nil)
   (setq kc kc1)
 )
 (setq nhom (ssadd))
 (setq i 0)
 (repeat (sslength ss)
   (setq tam (ssname ss 0))
   (setq j 1)
   (repeat (- (sslength ss) 1)
     (if (/= (ssname ss j) nil)
(progn
  (if (< (distance (cdr (assoc 10 (entget tam)))
		   (cdr (assoc 10 (entget (ssname ss j))))
	 )
	 kc
      )
    (progn
      (setq nhom (ssadd (ssname ss j) nhom))
      (setq ss (ssdel (ssname ss j) ss))
    )
  )
)
     )

     (setq j (+ j 1))
   )
   (if	(/= tam nil)
     (setq ss (ssdel tam ss))
   )
   (setq i (+ i 1))
 )
 (command "change" nhom "" "p" "c" "5" "")
 (command "_.undo" "e")
  (princ)
)

Chưa đạt yêu cầu vì một số điểm gần nhau mà vẫn chưa bị xoá.

<<

 

Rảnh nên làm bậy, bác Bình đừng quở nhé ! :D

;; free lisp from cadviet.com
;;; this lisp was downloaded...
>>

 

Rảnh nên làm bậy, bác Bình đừng quở nhé ! :D

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/3778-lisp-tinh-tong-chieu-dai-cac-line-hay-pline/
;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Sua theo yeu cau cua Khang (Cadviet) de thong ke thep co cong them doan noi = 30\40*d khi Lthanh >1170mm, luu y ham add_mline ko sua vi thep thuong ko ve bang mline

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



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Doi ten lenh thanh TKT = thong ke thep de khoi lan lon !


(defun C:TKT (/ tot_len ss e_name e_record e_type dk hs len_i)
(princ "\nCADViet.com © 2007")
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq tot_len 0.0)
(setq ss (ssget))
(initget 1)
(setq dk (getreal "\nNhap duong kinh thanh thep (mm): "))
(initget 1 "30d 40d")
(setq hs (atof (getkword "\nNhap chieu dai doan noi <30d/40d>: ")))
(if (null ss)
(exit)
)
(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 len_i (getvar "PERIMETER"))
(setq len_i (+ (* hs dk (fix (/ len_i 1170))) len_i))
(setq tot_len (+ tot_len len_i))
(ssdel e_name ss)
)
((wcmatch e_type "MLINE") (add_mline))
(e_type (ssdel e_name ss))
)
)
(prompt (strcat "\nTong chieu dai thep (da tinh phan moi noi): " (rtos tot_len 2 2)))
(princ)
)
(setvar "cmdecho" cmd)
(princ)

 

Em thử lisp của anh Hiệp trên AutoCAD2013 , không vấn đề gì:

Command:

TKT

CADViet.com © 20073 found

Nhap duong kinh thanh thep (mm): 20

Nhap chieu dai doan noi <30d/40d>: 30d

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

 

Bác Phamthanhbinh nói rất đúng: "...Nghèo nó đi với hèn là rứa.......".

Câu nói của bác, khiến em liên tưởng đến mấy câu thơ của nhà thơ Nguyễn Bùi Vợi:

 "... Xin đừng tô vẽ, đôn những vùng quê lên mười tấn

Hạt lúa lép ngoài đồng mà trên trang giấy thơm tho

Ai ngợi gió ca mây hoài mà bữa cơm vẫn độn

Tháng giáp hạt dài, tóc mẹ bạc vì lo

Xin đừng lấy cái nghèo làm điều cao thượng

Trên thế gian này không ai nói nghèo sang..."

:) :) :)

<<

Download lisp

Filename: 346407_tkt.lsp

Hề hề hề,

Bạn dùng thử cái này coi sao nhé.

Mình viết và chỉ lấy ra các giá trị cần dùng để tinh toán mà...

>>

Hề hề hề,

Bạn dùng thử cái này coi sao nhé.

Mình viết và chỉ lấy ra các giá trị cần dùng để tinh toán mà thôi,nghĩa là chỉ lấy từ cột đường kính trở đi. Các số liệu khác mình thấy không cần thiết nên không mất công lấy làm chi. Còn nếu bạn thấy cần thì hãy tự bổ sung thêm dựa trên cái mình đã làm nhé.

(defun c:tab2exl (/ lst1 lst2 lst3 lst4 lst5 lst6)
(setq ssbl (acet-ss-to-list (ssget (list (cons 0 "insert") (cons 66 1))))
         fn (getfiled "Chon file de save" "" "csv" 1)
         fw (open fn "w"))
(foreach bl ssbl
     (setq en (entnext bl))
     (while (/= (cdr (assoc 0 (entget en))) "SEQEND")
    		(if (= (cdr (assoc 0 (entget en))) "ATTRIB")
        		(cond
              		((or (= (cdr (assoc 2 (entget bl))) "TK_2") (= (cdr (assoc 2 (entget bl))) "TK_4")
                             (= (cdr (assoc 2 (entget bl))) "TK_5") (= (cdr (assoc 2 (entget bl))) "TK_6"))
                           (if (= (cdr (assoc 2 (entget en))) "TL") (setq lst6 (append lst6 (list (cdr (assoc 1 (entget en)))))))
                           (if (= (cdr (assoc 2 (entget en))) "DT") (setq lst5 (append lst5 (list (cdr (assoc 1 (entget en)))))))
                           (if (= (cdr (assoc 2 (entget en))) "SLA") (setq lst4 (append lst4 (list (cdr (assoc 1 (entget en)))))))
                           (if (= (cdr (assoc 2 (entget en))) "SL1") (setq lst3 (append lst3 (list (cdr (assoc 1 (entget en)))))))
                           (if (= (cdr (assoc 2 (entget en))) "DAI") (setq lst2 (append lst2 (list (cdr (assoc 1 (entget en)))))))
                           (if (= (cdr (assoc 2 (entget en))) "DK") (setq lst1 (append lst1 (list (cdr (assoc 1 (entget en)))))))
              		)
              		( T nil)
               )
           )
           (setq en (entnext en))
     )
)
(setq ldata (mapcar 'list lst1 lst2 lst3 lst4 lst5 lst6))
(princ  "DK, DAI, SL1, SLA, DT, TL\n" fw)
(foreach data ldata
   (setq txt (strcat  (nth 0 data)  ","  (nth 1 data) "," (nth 2 data)  "," (nth 3 data)  "," (nth 4 data)  "," (nth 5 data) ","))
(princ (strcat txt "\n") fw)
)
(close fw)
(princ)
)

Chúc bạn vui.

Mình down được nhưng không biết cách sử dụng list này. Mong bạn chỉ cho cách sử dụng với

<<

Lệnh TKD (thống kê dài) dưới đây sẽ giúp bạn.

Chương trình sẽ yêu cầu bạn chọn các đối tượng, yêu cầu bạn nhập khoảng cách max, yêu cầu bạn nhập...

>>

Lệnh TKD (thống kê dài) dưới đây sẽ giúp bạn.

Chương trình sẽ yêu cầu bạn chọn các đối tượng, yêu cầu bạn nhập khoảng cách max, yêu cầu bạn nhập khoảng cách min. Sau đó nó sẽ hiển thị một hộp thoại thông báo cho bạn biết có bao nhiêu đối tượng thỏa mãn.

(defun c:tkd ( / ss dmax dmin i ent dai tong)
 (setq	ss  (ssget '((0 . "*LINE")))
dmax (getdist "\nVao khoang cach max: ")
dmin (getdist "\nVao khoang cach min: ")
i 0
tong 0)
 (repeat (sslength ss)
   (setq ent (ssname ss i)
  i (1+ i))
   (command ".lengthen" ent "")
   (setq dai (getvar "perimeter"))
   (if (and (<= dai dmax)(<= dmin dai))
     (setq tong (1+ tong))
   )
 )
 (alert (strcat "Co " (itoa tong) " doi tuong co khoang cach\nTu " (rtos dmin) " - " (rtos dmax)))
 (princ)
)

cám ơn bác hoành nhiều nhá ...............tối về nhà sẽ chạy thử lisp của bác , a em làm đuờng cám ơn bác nh lắm đấy ....he he

<<

Nếu bạn không đóng block dim thì có thể dùng cái này :)

(defun c:dc()(setvar "dimclrt" 2)(setvar "dimclrd" 30)(command...
>>

Nếu bạn không đóng block dim thì có thể dùng cái này :)

(defun c:dc()(setvar "dimclrt" 2)(setvar "dimclrd" 30)(command "-dimstyle" "a" "all" ""))

Lisp đổi được màu DIM nhưng mà có 1 vấn đề phát sinh là nó tự động cắt cụt hết các chân DIM đi bác KETXU ạ ? Bác xem lại giúp em với ?

<<

Sao mi

Thôi thì thế này nhé :

(defun vatgoc_tinhtoan (a b c d / osm p1 p2 p3 p4 pt1 pt2 intp d1 d2 a1...
>>

Sao mi

 

Thôi thì thế này nhé :

(defun vatgoc_tinhtoan (a b c d / osm p1 p2 p3 p4 pt1 pt2 intp d1 d2 a1 a2 di1 di2 ai1 ai2 kqua)
(setq pt1 nil pt2 nil p1 a p2 b p3 c p4 d)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(if (setq intp (inters p1 p2 p3 p4 nil))
(progn
(setq d1 (distance p1 p2) d2 (distance p3 p4) a1 (angle p1 p2) a2 (angle p3 p4))
(setq di1 (distance p1 intp) di2 (distance p3 intp) ai1 (angle p1 intp) ai2 (angle p3 intp))
(cond
((and (and (equal ai1 a1 0.00001) (> di1 d1)) (and (equal ai2 a2 0.00001)(> di2 d2))) (setq pt1 p2 pt2 p4))
(T (setq pt1 nil pt2 nil))
);cond
);prgn
);if
(setvar "osmode" osm)
(if (and pt1 pt2) (setq kqua (list pt1 pt2 intp))))
;-------------------------
(defun c:vatgoc_dimaligned (/ i Egss k cl lstpt vg lst_vg t1 p1 diem n )
(setq i 0)
(setq Egss (entget (car (entsel "\nChon pline :" ))))
(setq k (cdr (assoc 90 Egss)) cl (cdr (assoc 70 Egss)))
(setq lstpt '() vg '() lst_vg '())
(setq i 1)
(while (<= i k)
(progn
(setq t1 (member (assoc 10 Egss) Egss))
(setq p1 (car t1))
(setq Egss (cdr t1))
(setq diem (cdr p1))
(setq lstpt (append lstpt (list diem)))
(setq i (+ 1 i))));while
(setq k (length lstpt))
(if (< k 4) (exit))
(if (= cl 1) (setq lstpt (append lstpt (list (nth 0 lstpt)(nth 1 lstpt) (nth 2 lstpt)))))
(if (and (= cl 0) (equal (nth 0 lstpt) (nth (- k 1) lstpt)))
(setq lstpt (append lstpt (list (nth 1 lstpt) (nth 2 lstpt)))))
(setq k (length lstpt))
(setq n 0)
(while (< n (- k 3))
(repeat 4 (setq vg (append vg (list (nth n lstpt)))) (setq n (1+ n)))
(setq lst_vg (append lst_vg (list vg)) vg '())
(setq n (- n 3))
)
(setq k (length lst_vg) n 0)
(repeat k
(if (setq vgtt (vatgoc_tinhtoan (nth 0 (nth n lst_vg)) (nth 1 (nth n lst_vg)) (nth 3 (nth n lst_vg)) (nth 2 (nth n lst_vg))))
(progn (command "dimaligned" (nth 0 vgtt) (nth 2 vgtt)(nth 2 vgtt))
(command "dimaligned" (nth 1 vgtt) (nth 2 vgtt)(nth 2 vgtt)))
)
(setq n (1+ n))
)
)

PS: Dimstyle bạn tự khai báo phù hợp là đc

Sao khi sử dụng với pline kín thì không được bác ah. bác có thể khắc phục được không?

<<

 

Chào bạn Thaistreetz,

Bạn dùng thử cái này nha:

(defun Length1(e)...
>>

 

Chào bạn Thaistreetz,

Bạn dùng thử cái này nha:

(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:TL( / ss L e)
(setq
ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
L 0.0
k (getvar "dimlfac")
)

(vl-load-com)
(while (setq e (ssname ss 0))
(setq L (* k (length1 e)))
(setq ans (getstring "\n Ban hay chon phuong an nhap ket qua "))
(if (= ans "1")
(progn
(setq te (entget(car(entsel "\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
)
(progn
(setq p (getpoint "\n Chon diem nhap ket qua" ))
(setq h (getreal "\n Nhap chieu cao text ket qua "))
(command "text" p h "0" (rtos L 2 2))
)
)
(ssdel e ss)
)
(princ)
)
;;;--------------------------------------------------------------------

Đoạn lisp này mình chỉnh sửa lại từ cái lisp của bác SSG và bác Tue_nv do mình nghĩ có thể bác Tue_NV hiểu nhầm ý bạn. Bạn muốn lấy các độ dài của từng đoạn chứ không phải lấy tổng độ dài, vả lại bạn cũng muốn kết quả ghi theo tỷ lệ của dimstyle hiện tại chứ không phải là kết quả đo được nữa. Ở lisp này mình cũng để bạn chọn phương án nhap kết quả , nhưng bạn lưu ý là khi lisp hỏi bạn chỉ cần gõ 1 hoặc enter là đủ bạn nhé. Bạn xài thử xem nhé. Nếu có gì trục trặc xin báo lại vì mình cũng chưa kiểm nghiệm nó do chưa có thời gian bạn ạ. Thực ra mình cũng chưa ưng ý với lisp này do nếu như bạn chọn khá nhiều đối tượng thì việc nhớ được trật tự khi lựa chọn đối tượng không hề dễ. Theo ý mình thì nên mỗi lần chỉ chọn một đối tượng và sau khi chạy xong thi lisp sẽ hỏi bạn có muốn tiếp tục hay không, nếu có thì chọn đối tượng tiếp, còn nếu không thì kết thúc sẽ thuận lợi cho việc chỉnh sửa trên bản vẽ của bạn hơn.

Không biết bạn nghĩ sao, nếu bạn đồng ý mình sẽ cải tạo lại đoạn lisp trên bạn nhé.

Chúc bạn vui.

 

@ Bác Tue_NV: Mạn phép bác sửa lại chút xíu cái lisp của bác cho gần với yêu cầu của bạn Thaistreetz hơn. Mong bác không giận.

Bác viết thêm là thể hiện thứ tự các đoạn cần điền chiều dài (theo thứ tự mà lisp nhận được) chứ không biết đâu mà ghi chiều dài được bác ạ. Mong bác giúp đỡ

<<