Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Đăng nhập để thực hiện theo  
khopanh

LISP cộng têxt toàn bộ bản vẽ thêm 1 hằng sô

Các bài được khuyến nghị

khopanh    0

Kính gửi các Pro

Tôi đã tìm kiếm trên diễn đàn rùi nhưng không có. Xin đừng ném đá tui nhé.

Tôi có 1 bản đồ với các điểm caođộ ở dạng TEXT, giờ muốn cộng toàn bộ chúng hoặc các đối tượng được chọn) thêm 1 hằng số K nào đó và ghi đè lên giá trị cũ ởđúng vị trí cũ thì làm thế nào? Kính mong các cao thủ giúp đỡ. Chân thành cảm ơn

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Tue_NV    3.841
Kính gửi các Pro

Tôi đã tìm kiếm trên diễn đàn rùi nhưng không có. Xin đừng ném đá tui nhé.

Tôi có 1 bản đồ với các điểm caođộ ở dạng TEXT, giờ muốn cộng toàn bộ chúng hoặc các đối tượng được chọn) thêm 1 hằng số K nào đó và ghi đè lên giá trị cũ ởđúng vị trí cũ thì làm thế nào? Kính mong các cao thủ giúp đỡ. Chân thành cảm ơn

Đây bạn :

(defun c:cso()
(setq olddim (getvar "dimzin"))
(setvar "DimZin" 0)

(setq en (ssget '((0 . "TEXT"))))
(setq tp (getint "\n So chu so thap phan :"))

(setq n (sslength en) i 0)

(if (null newo) (setq newo 1))

(setq new1 (getreal (strcat "\nNhap so can cong : ")))

(if (null new1) (setq new1 newo) (setq newo new1))

(while (
(setq ename (entget (ssname en i)))

(setq li (cdr (assoc 1 ename)))
(setq lis (+ (atof li) new1))

(setq ename (subst (cons 1 (rtos lis 2 tp)) (assoc 1 ename) ename))

(entmod ename)
(setq i (+ i 1))
)
(setvar "dimzin" olddim)
(princ)
)
;;;;

  • Vote tăng 9

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
tigertiger    0
Đây bạn :

(defun c:cso()
(setq olddim (getvar "dimzin"))
(setvar "DimZin" 0)

(setq en (ssget '((0 . "TEXT"))))
(setq tp (getint "\n So chu so thap phan :"))

(setq n (sslength en) i 0)

(if (null newo) (setq newo 1))

(setq new1 (getreal (strcat "\nNhap so can cong <" (rtos newo) ">: ")))

(if (null new1) (setq new1 newo) (setq newo new1))

(while (< i n)

(setq ename (entget (ssname en i)))

(setq li (cdr (assoc 1 ename)))
(setq lis (+ (atof li) new1))

(setq ename (subst (cons 1 (rtos lis 2 tp)) (assoc 1 ename) ename))

(entmod ename)
(setq i (+ i 1))
)
(setvar "dimzin" olddim)
(princ)
)
;;;;

 

rất hay

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Đây bạn :

(defun c:cso()
(setq olddim (getvar "dimzin"))
(setvar "DimZin" 0)

(setq en (ssget '((0 . "TEXT"))))
(setq tp (getint "\n So chu so thap phan :"))

(setq n (sslength en) i 0)

(if (null newo) (setq newo 1))

(setq new1 (getreal (strcat "\nNhap so can cong <" (rtos newo) ">: ")))

(if (null new1) (setq new1 newo) (setq newo new1))

(while (< i n)

(setq ename (entget (ssname en i)))

(setq li (cdr (assoc 1 ename)))
(setq lis (+ (atof li) new1))

(setq ename (subst (cons 1 (rtos lis 2 tp)) (assoc 1 ename) ename))

(entmod ename)
(setq i (+ i 1))
)
(setvar "dimzin" olddim)
(princ)
)
;;;;

Tui là gà mới vào nghề nên chẳng hiểu gì cả, bác Pro nào có thể giải thích rõ hơn để anh em gà còn có cơ hội thành gà già. Thank u! :s_big:

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Thaistreetz    515
Kính gửi các Pro

Tôi đã tìm kiếm trên diễn đàn rùi nhưng không có. Xin đừng ném đá tui nhé.

Tôi có 1 bản đồ với các điểm caođộ ở dạng TEXT, giờ muốn cộng toàn bộ chúng hoặc các đối tượng được chọn) thêm 1 hằng số K nào đó và ghi đè lên giá trị cũ ởđúng vị trí cũ thì làm thế nào? Kính mong các cao thủ giúp đỡ. Chân thành cảm ơn

 

Cái này cũng tương tự

 

(defun c:as()

(setq i 0 s1 0)
(setq n (getreal "\nnhap so bi tru hoac so de cong: "))
 (prompt "\nchon cac so can sua ...")
(setq txt (ssget '((0 . "TEXT"))))
	(repeat (sslength txt)
	(setq txt_name (ssname txt i))
	  (setq txt_ent (entget txt_name))
	(setq cont (cdr(assoc 1 txt_ent)))
	(setq cont (atof cont))
	(setq s (+ cont n))	  
  (setq txt_ent  (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))
	(entmod txt_ent)
	(setq i (+ i 1))
);repeat
);defun	
;------------------------------------------------------

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Tue_NV    3.841
sao ko có LISP nào mình dùng được hết vậy bạn?

Bạn nhấn nút Reply bài viết -> chép hết code (không sót nhé) về chạy là được

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
hukhong    0
Kính gửi các Pro

Tôi đã tìm kiếm trên diễn đàn rùi nhưng không có. Xin đừng ném đá tui nhé.

Tôi có 1 bản đồ với các điểm caođộ ở dạng TEXT, giờ muốn cộng toàn bộ chúng hoặc các đối tượng được chọn) thêm 1 hằng số K nào đó và ghi đè lên giá trị cũ ởđúng vị trí cũ thì làm thế nào? Kính mong các cao thủ giúp đỡ. Chân thành cảm ơn

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Đây bạn :

(defun c:cso()
(setq olddim (getvar "dimzin"))
(setvar "DimZin" 0)

(setq en (ssget '((0 . "TEXT"))))
(setq tp (getint "\n So chu so thap phan :"))

(setq n (sslength en) i 0)

(if (null newo) (setq newo 1))

(setq new1 (getreal (strcat "\nNhap so can cong <" (rtos newo) ">: ")))

(if (null new1) (setq new1 newo) (setq newo new1))

(while (< i n)

(setq ename (entget (ssname en i)))

(setq li (cdr (assoc 1 ename)))
(setq lis (+ (atof li) new1))

(setq ename (subst (cons 1 (rtos lis 2 tp)) (assoc 1 ename) ename))

(entmod ename)
(setq i (+ i 1))
)
(setvar "dimzin" olddim)
(princ)
)
;;;;

 

 

Các bác cho em hỏi, có thể sửa lisp này cho đối tượng chọn là mtext được không? vì đối tượng text nằm ở gữa khung, khi dùng lisp này thì đối tượng text không còn mằm ở giữa khung nữa. mong các bác chỉ giúp.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
phamthanhbinh    3.123

Các bác cho em hỏi, có thể sửa lisp này cho đối tượng chọn là mtext được không? vì đối tượng text nằm ở gữa khung, khi dùng lisp này thì đối tượng text không còn mằm ở giữa khung nữa. mong các bác chỉ giúp.

Hề hề hề,

Bạn nói chi thế nhỉ??? Lisp này chỉ đổi nội dung text chứ có đả động chi tới các thông số khác của text đâu mà bảo nó chạy mới nhày được????

Hãy gửi cái bản vẽ gốc của bạn và cái kết quả có sau khi xài cái lisp này lên để mọi người kiểm tra giùm. Hay là bạn lại đẻ thêm cái chức năng chi chi đó cho lisp này vậy???

Hề hề hề.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Cái này cũng tương tự

 

(defun c:as()

(setq i 0 s1 0)
(setq n (getreal "\nnhap so bi tru hoac so de cong: "))
 (prompt "\nchon cac so can sua ...")
(setq txt (ssget '((0 . "TEXT"))))
(repeat (sslength txt)
	(setq txt_name (ssname txt i))
  	(setq txt_ent (entget txt_name))
	(setq cont (cdr(assoc 1 txt_ent)))
	(setq cont (atof cont))
	(setq s (+ cont n))     
 	(setq txt_ent  (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))
	(entmod txt_ent)
	(setq i (+ i 1))
);repeat
);defun   
;------------------------------------------------------

Lisp rất hay bạn có thể bổ sung thêm phép trừ

cám ơn nhiều lắm

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
ketxu    2.653

Bạn hãy search trên diễn đàn với từ khóa defun c:tinh lisp , ngoài ra bản thân phép trừ cũng chính là phép cộng số âm, có phải bạn đang quá bị động k ?

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Bạn hãy search trên diễn đàn với từ khóa defun c:tinh lisp , ngoài ra bản thân phép trừ cũng chính là phép cộng số âm, có phải bạn đang quá bị động k ?

mình đã load lisp tính rồi nhưng lisp đó chỉ tính những số mình chọn ví dụ như cộng các số lại với nhau hay lấy số này trừ số kia chứ không lấy những số mình chọn rồi thực hiện cộng trừ nhân chia với 1 giá trị cụ thể. Ừ nhỉ sao mình không nghĩ ra nhiều khi đơn giãn lại muốn làm cho phức tạp lên để lại đau đầu suy nghĩ.

­

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
bach1212    2

Thêm 1 chú nữa:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=37567
;;----------------------------------------------;;
;; Text calculation tool -  Skywings ;;
;;----------------------------------------------;;
;;***SUB-FUNCTION***
(defun GET-TEXT ()
 (princ "\nSelect NUMBERs : ")
 (while (null (setq Numbers (ssget '((0 . "*TEXT")))))
(princ "\n**NOTHING selected!**")
 )
)
(defun GET-DATA (/ ss-mt ss-t n)
 (setq ss-mt (ssadd)
ss-t  (ssadd)
n 	0
sw	0
 )
 (repeat (sslength Numbers)
(setq ent (ssname Numbers n))
(if (= (cdr (assoc 0 (entget ent))) "MTEXT")
 	(setq ss-mt (ssadd ent ss-mt))
 	(setq ss-t (ssadd ent ss-t))
)
(setq n (1+ n))
 ) 
 (if (/= (sslength ss-mt) 0)
(setq Numbers (acet-explode ss-mt)
  sw   1
)
 )
 (setq n 0)
 (repeat (sslength ss-t)
(setq ent   (ssname ss-t n)
  Numbers (ssadd ent Numbers)
  n   (1+ n)
)
 )
)
(defun GET-VALUE (name / sw)
 (princ (strcat "\nSelect " name " : "))
 (cond
((= (cdr (assoc 0 (entget ename))) "MTEXT")
	(command ".explode" ename "")
	(setq value (read (cdr (assoc 1 (entget (entlast)))))
sw  1
	)
)
((setq value (read (cdr (assoc 1 (entget ent))))))
 )
 (if (= sw 1)
(command ".undo" 1)
 )
 value
)
(defun OPT ()
 (if (null option)
(setq option "Replace"
  save2  option
)
 )
 (initget "Replace Create Do-nothing")
 (setq
option
	(getkword
  	(strcat "\nOptions: [Replace/Create/Do-nothing] <"
   	option
   	"> "
  	)
	)
 )
 (if (null option)
(setq option save2)
(setq save2 option)
 )
 (setq switch 1)
)
(defun ACTION (option result / txt pnt)
 (cond
((= option "Replace")
	(while (null (setq txt (entsel "\nChoose TEXT to replace: ")))
  	(princ "\n**NOTHING selected!**")
	)
	(setq txt (entget (car txt))
txt (subst (cons 1 result) (assoc 1 txt) txt)
	)
	(entmod txt)
)
((= option "Create")
	(setq pnt (getpoint "\nSpecify start point of text:"))
	(entmake (list (assoc 0 ent)
 	(assoc 8 ent)
 	(cons 1 result)
 	(cons 10 (trans pnt 1 0))
 	(assoc 40 ent)
 	(assoc 7 ent)
 	(assoc 50 ent)
  	)
	)
)
 )
)
(defun GET-ORDER ()
 (princ (strcat "\nCurrent setting: Precision = "
  (rtos precision 2 0)
  " <"
  (rtos 0 2 precision)
  ">"
 )
 )
 (initget
"Plus Subtract Multiply Divide Average maX-min ADd-by mUltiply-by preCision"
 )
 (setq operation
 (getkword
(strcat
 	"\nOperations: [Plus/Subtract/Multiply/Divide/Average/maX-min/ADd-by/mUltiply-by/preCision]: <"
 	operation
 	"> "
)
 )
 )
 (if (null operation)
(setq operation save1)
(setq save1 operation)
 )
)
;;***MAIN FUNCTION***:
(defun c:TCAL (/ Numbers   DIVIDEND  DIVISOR   ENT  ID
  INDEX	MINUEND   NUM-MAX   NUM-MIN  NUM-SET
  RESULT	SUBTRAHEND    	SWITCH  VALUE
  sw
 )
 (princ
"** Text calculation tool - Skywings **"
 )
 (setvar "CMDECHO" 0)
 (setvar "QAFLAGS" 1)
 (if (null precision)
(setq precision 2
  save3 precision
)
 )
 (if (null operation)
(setq operation "Plus"
  save1 operation
)
 )
 (GET-ORDER)
 (while (= operation "preCision")
(initget 4)
(setq
 	precision (getint (strcat "\nSpecify new precision: <"
(rtos precision 2 0)
"> "
  )
 )
)
(if (null precision)
 	(setq precision save3)
 	(setq save3 precision)
)
(GET-ORDER)
 )
 (cond
;; PLUS:
((= operation "Plus")
	(GET-TEXT)
	(setq switch 0)
	(while (/= Numbers nil)
  	(GET-DATA)
  	(setq index 0
 	result 0
  	)
  	(princ "\n>>Expression: ")
  	(repeat (sslength Numbers)
 (setq ent   (entget (ssname Numbers index))
   	value (read (cdr (assoc 1 ent)))
   	index (1+ index)
 )
 (if (numberp value)
(progn
 	(setq result (+ result value))
 	(if (/= index 1)
   	(princ " + ")
 	)
 	(princ (rtos value 2 precision))
)
 )
  	)
  	(if (= sw 1) (command ".undo" 1))
  	(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
  	(if (= switch 0)
 (OPT)
  	)
  	(ACTION option (rtos result 2 precision))
  	(setq Numbers nil
 	Numbers (ssget '((0 . "*TEXT")))
  	)
	)
)
;; MULTIPLY:
((= operation "Multiply")
 	(GET-TEXT)
 	(setq switch 0)
 	(while (/= Numbers nil)
(GET-DATA)
(setq index 0
  	result 1
)
(princ "\n>>Expression: ")
(repeat (sslength Numbers)
  (setq ent   (entget (ssname Numbers index))
 value (read (cdr (assoc 1 ent)))
 index (1+ index)
  )
  (if (numberp value)
	(progn
  	(setq result (* result value))
  	(if (/= index 1)
 (princ " * ")
  	)
  	(princ (rtos value 2 precision))
	)
  )
)
(if (= sw 1)
  (command ".undo" 1)
)
(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
(if (= switch 0)
  (OPT)
)
(ACTION option (rtos result 2 precision))
(setq Numbers nil
  	Numbers (ssget '((0 . "*TEXT")))
)
 	)
)
;; SUBTRACT:
((= operation "Subtract")
 	(setq switch 0
	sw 0
 	)
 	(while (null (setq ename (car (entsel (strcat "\nSelect MINUEND : "))))))
 	(setq minuend (GET-VALUE "MINUEND"))
 	(while (null (numberp minuend))
(while (null (setq ename (car (entsel (strcat "\nSelect MINUEND : "))))))
(setq minuend (GET-VALUE "MINUEND"))
 	)
 	(princ minuend)
 	(redraw ename 3)
 	(princ "\nSelect SUBTRAHENDs : ")
 	(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
(princ "\nSelect SUBTRAHENDs : ")
 	)
 	(redraw ename 4)
 	(while (/= ename nil)
(GET-DATA)
(setq index   0
  	result  0
  	minuend (float minuend)
)
(princ (strcat "\n>>Expression: "
    	(rtos minuend 2 precision)
    	" - ("
   	)
)
(repeat (sslength Numbers)
  (setq ent	(entget (ssname Numbers index))
 subtrahend (read (cdr (assoc 1 ent)))
 index	(1+ index)
  )
  (if (numberp subtrahend)
	(progn
  	(setq result (+ result subtrahend))
  	(if (/= index 1)
 (princ " + ")
  	)
  	(princ (rtos subtrahend 2 precision))
	)
  )
)
(princ ")")
(if (= sw 1)
  (command ".undo" 1)
)
(setq result (- minuend result))
(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
(if (= switch 0)
  (OPT)
)
(ACTION option (rtos result 2 precision))
(setq ename nil
  	ename (car (entsel (strcat "\nSelect MINUEND : ")))
)
(if
  (or
	(null ename)
	(null (numberp (setq minuend (GET-VALUE "MINUEND"))))
  )
  (progn
	(setvar "QAFLAGS" 0)
	(vl-exit-with-error "")
  )
)
(princ minuend)
(princ "\nSelect SUBTRAHENDs <TEXT>: ")
(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
  (princ "\nSelect SUBTRAHENDs : ")
)
 	)
)
;; DIVIDE:
((= operation "Divide")
 	(setq switch 0
	sw 0
 	)
 	(while (null (setq ename (car (entsel (strcat "\nSelect DIVIDEND : "))))))
 	(setq dividend (GET-VALUE "DIVIDEND"))
 	(while (null (numberp dividend))
(while (null (setq ename (car (entsel (strcat "\nSelect DIVIDEND : "))))))
(setq dividend (GET-VALUE "DIVIDEND"))
 	)
 	(princ dividend)
 	(redraw ename 3)
 	(princ "\nSelect DIVISORs : ")
 	(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
(princ "\nSelect DIVISORs : ")
 	)
 	(redraw ename 4)
 	(while (/= ename nil)
(GET-DATA)
(setq index   0
  	result  1
  	dividend (float dividend)
)
(princ (strcat "\n>>Expression: "
    	(rtos dividend 2 precision)
    	" / ("
   	)
)
(repeat (sslength Numbers)
  (setq ent (entget (ssname Numbers index))
 divisor (read (cdr (assoc 1 ent)))
 index (1+ index)
  )
  (if (numberp divisor)
	(progn
  	(setq result (* result divisor))
  	(if (/= index 1)
 (princ " * ")
  	)
  	(princ (rtos divisor 2 precision))
	)
  )
)
(princ ")")
(if (= sw 1)
  (command ".undo" 1)
)
(setq result (/ dividend result))
(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
(if (= switch 0)
  (OPT)
)
(ACTION option (rtos result 2 precision))
(setq ename nil
  	ename (car (entsel (strcat "\nSelect DIVIDEND : ")))
)
(if
  (or
	(null ename)
	(null (numberp (setq dividend (GET-VALUE "DIVIDEND"))))
  )
  (progn
	(setvar "QAFLAGS" 0)
	(vl-exit-with-error "")
  )
)
(princ dividend)
(princ "\nSelect DIVISORs : ")
(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
  (princ "\nSelect DIVISORs : ")
)
 	)
)
;; AVERAGE:
((= operation "Average")
	(GET-TEXT)
	(setq switch 0)
	(while (/= Numbers nil)
  	(GET-DATA)
  	(setq index 0
 	id 0
 	result 0
  	)
  	(princ "\n>>Expression: (")
  	(repeat (sslength Numbers)
 (setq ent   (entget (ssname Numbers index))
   	value (read (cdr (assoc 1 ent)))
   	index (1+ index)
 )
 (if (numberp value)
(progn
 	(setq result (+ result value)
	id   (1+ id)
 	)
 	(if (/= index 1)
   	(princ " + ")
 	)
 	(princ (rtos value 2 precision))
)
 )
  	)
  	(if (= sw 1) (command ".undo" 1))
  	(setq result (rtos (/ (float result) id) 2 precision))
  	(princ (strcat ") / " (rtos id 2 0)))
  	(princ (strcat "\n>>RESULT = " result))
  	(if (= switch 0)
 (OPT)
  	)
  	(ACTION option result)
  	(setq Numbers nil
 	Numbers (ssget '((0 . "*TEXT")))
  	)
	)
)
;; MAX-MIN:
((= operation "maX-min")
	(GET-TEXT)
	(setq switch 0)
	(while (/= Numbers nil)
  	(GET-DATA)
  	(setq index 0
 	Num-set nil
  	)
  	(repeat (sslength Numbers)
 (setq ent   (entget (ssname Numbers index))
   	value (read (cdr (assoc 1 ent)))
   	index (1+ index)
 )
 (if (numberp value)
(setq Num-set (cons value Num-set))
 )
  	)
  	(setq Num-set (vl-sort Num-set '>)
 	num-max (car Num-set)
 	num-min (last Num-set)
 	result  (strcat "MAX = "
   	(rtos num-max 2 precision)
   	"  MIN = "
   	(rtos num-min 2 precision)
  	)
  	)
  	(if (= sw 1) (command ".undo" 1))
  	(princ "\n>>Numbers set: ")
  	(princ Num-set)
  	(print)
  	(princ result)
  	(if (= switch 0)
 (OPT)
  	)
  	(ACTION option result)
  	(setq Numbers nil
 	Numbers (ssget '((0 . "*TEXT")))
  	)
	)
)
;; ADD-BY...:
((= operation "ADd-by")
	(if (null number0)
  	(setq number0 0.00
 	save4 number0
  	)
	)
	(setq number0 (getreal (strcat "Add by: <" (rtos number0 2 2) "> "))
index   0
	)
	(if (null number0)
  	(setq number0 save4)
  	(setq save4 number0)
	)
	(GET-TEXT)
	(GET-DATA)
	(repeat (sslength Numbers)      
  	(setq ent   (entget (ssname Numbers index))
 	value (read (cdr (assoc 1 ent)))
 	index (1+ index)
  	)      
  	(if (numberp value)
 (setq value (+ (float value) number0)
   	ent   (subst (cons 1 (rtos value 2 precision))
  	(assoc 1 ent)
  	ent
  	)
 )
  	)
  	(entmod ent)      
	)
)
;;MULTIPLY-BY...:
((= operation "mUltiply-by")
	(if (null number0)
  	(setq number0 0.00
 	save4 number0
  	)
	)
	(setq number0 (getreal (strcat "Multiply by: <" (rtos number0 2 2) "> "))
index   0
	)
	(if (null number0)
  	(setq number0 save4)
  	(setq save4 number0)
	)
	(GET-TEXT)
	(GET-DATA)
	(repeat (sslength Numbers)
  	(setq ent   (entget (ssname Numbers index))
 	value (read (cdr (assoc 1 ent)))
 	index (1+ index)
  	)
  	(if (numberp value)
 (setq value (* (float value) number0)
   	ent   (subst (cons 1 (rtos value 2 precision))
  	(assoc 1 ent)
  	ent
  	)
 )
  	)
  	(entmod ent)
	)
)
 )
 (princ "<Exit>")
 (setvar "QAFLAGS" 0)
 (princ)
)

Tcal dùng lựa chọn AD (add-by) nhập hằng số K là -K nếu muốn trừ, K nếu muốn cộng

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
victor85    10

Với vấn đề này các bác có thể tham khảo lệnh tcount trong acad và sử dụng linh hoạt sẽ không nhất thiết cần dùng đến autolisp. Chúc các bạn sử dụng hiệu quả trong acad.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Thêm 1 chú nữa:

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=37567
;;----------------------------------------------;;
;; Text calculation tool -  Skywings ;;
;;----------------------------------------------;;
;;***SUB-FUNCTION***
(defun GET-TEXT ()
 (princ "\nSelect NUMBERs : ")
 (while (null (setq Numbers (ssget '((0 . "*TEXT")))))
(princ "\n**NOTHING selected!**")
 )
)
(defun GET-DATA (/ ss-mt ss-t n)
 (setq ss-mt (ssadd)
ss-t  (ssadd)
n 	0
sw	0
 )
 (repeat (sslength Numbers)
(setq ent (ssname Numbers n))
(if (= (cdr (assoc 0 (entget ent))) "MTEXT")
 	(setq ss-mt (ssadd ent ss-mt))
 	(setq ss-t (ssadd ent ss-t))
)
(setq n (1+ n))
 )
 (if (/= (sslength ss-mt) 0)
(setq Numbers (acet-explode ss-mt)
  sw   1
)
 )
 (setq n 0)
 (repeat (sslength ss-t)
(setq ent   (ssname ss-t n)
  Numbers (ssadd ent Numbers)
  n   (1+ n)
)
 )
)
(defun GET-VALUE (name / sw)
 (princ (strcat "\nSelect " name " : "))
 (cond
((= (cdr (assoc 0 (entget ename))) "MTEXT")
(command ".explode" ename "")
(setq value (read (cdr (assoc 1 (entget (entlast)))))
sw  1
)
)
((setq value (read (cdr (assoc 1 (entget ent))))))
 )
 (if (= sw 1)
(command ".undo" 1)
 )
 value
)
(defun OPT ()
 (if (null option)
(setq option "Replace"
  save2  option
)
 )
 (initget "Replace Create Do-nothing")
 (setq
option
(getkword
  	(strcat "\nOptions: [Replace/Create/Do-nothing] <"
   	option
   	"> "
  	)
)
 )
 (if (null option)
(setq option save2)
(setq save2 option)
 )
 (setq switch 1)
)
(defun ACTION (option result / txt pnt)
 (cond
((= option "Replace")
(while (null (setq txt (entsel "\nChoose TEXT to replace: ")))
  	(princ "\n**NOTHING selected!**")
)
(setq txt (entget (car txt))
txt (subst (cons 1 result) (assoc 1 txt) txt)
)
(entmod txt)
)
((= option "Create")
(setq pnt (getpoint "\nSpecify start point of text:"))
(entmake (list (assoc 0 ent)
 	(assoc 8 ent)
 	(cons 1 result)
 	(cons 10 (trans pnt 1 0))
 	(assoc 40 ent)
 	(assoc 7 ent)
 	(assoc 50 ent)
  	)
)
)
 )
)
(defun GET-ORDER ()
 (princ (strcat "\nCurrent setting: Precision = "
  (rtos precision 2 0)
  " <"
  (rtos 0 2 precision)
  ">"
 )
 )
 (initget
"Plus Subtract Multiply Divide Average maX-min ADd-by mUltiply-by preCision"
 )
 (setq operation
 (getkword
(strcat
 	"\nOperations: [Plus/Subtract/Multiply/Divide/Average/maX-min/ADd-by/mUltiply-by/preCision]: <"
 	operation
 	"> "
)
 )
 )
 (if (null operation)
(setq operation save1)
(setq save1 operation)
 )
)
;;***MAIN FUNCTION***:
(defun c:TCAL (/ Numbers   DIVIDEND  DIVISOR   ENT  ID
  INDEX	MINUEND   NUM-MAX   NUM-MIN  NUM-SET
  RESULT	SUBTRAHEND    	SWITCH  VALUE
  sw
 )
 (princ
"** Text calculation tool - Skywings **"
 )
 (setvar "CMDECHO" 0)
 (setvar "QAFLAGS" 1)
 (if (null precision)
(setq precision 2
  save3 precision
)
 )
 (if (null operation)
(setq operation "Plus"
  save1 operation
)
 )
 (GET-ORDER)
 (while (= operation "preCision")
(initget 4)
(setq
 	precision (getint (strcat "\nSpecify new precision: <"
(rtos precision 2 0)
"> "
  )
 )
)
(if (null precision)
 	(setq precision save3)
 	(setq save3 precision)
)
(GET-ORDER)
 )
 (cond
;; PLUS:
((= operation "Plus")
(GET-TEXT)
(setq switch 0)
(while (/= Numbers nil)
  	(GET-DATA)
  	(setq index 0
 	result 0
  	)
  	(princ "\n>>Expression: ")
  	(repeat (sslength Numbers)
 (setq ent   (entget (ssname Numbers index))
   	value (read (cdr (assoc 1 ent)))
   	index (1+ index)
 )
 (if (numberp value)
(progn
 	(setq result (+ result value))
 	(if (/= index 1)
   	(princ " + ")
 	)
 	(princ (rtos value 2 precision))
)
 )
  	)
  	(if (= sw 1) (command ".undo" 1))
  	(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
  	(if (= switch 0)
 (OPT)
  	)
  	(ACTION option (rtos result 2 precision))
  	(setq Numbers nil
 	Numbers (ssget '((0 . "*TEXT")))
  	)
)
)
;; MULTIPLY:
((= operation "Multiply")
 	(GET-TEXT)
 	(setq switch 0)
 	(while (/= Numbers nil)
(GET-DATA)
(setq index 0
  	result 1
)
(princ "\n>>Expression: ")
(repeat (sslength Numbers)
  (setq ent   (entget (ssname Numbers index))
 value (read (cdr (assoc 1 ent)))
 index (1+ index)
  )
  (if (numberp value)
(progn
  	(setq result (* result value))
  	(if (/= index 1)
 (princ " * ")
  	)
  	(princ (rtos value 2 precision))
)
  )
)
(if (= sw 1)
  (command ".undo" 1)
)
(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
(if (= switch 0)
  (OPT)
)
(ACTION option (rtos result 2 precision))
(setq Numbers nil
  	Numbers (ssget '((0 . "*TEXT")))
)
 	)
)
;; SUBTRACT:
((= operation "Subtract")
 	(setq switch 0
sw 0
 	)
 	(while (null (setq ename (car (entsel (strcat "\nSelect MINUEND : "))))))
 	(setq minuend (GET-VALUE "MINUEND"))
 	(while (null (numberp minuend))
(while (null (setq ename (car (entsel (strcat "\nSelect MINUEND : "))))))
(setq minuend (GET-VALUE "MINUEND"))
 	)
 	(princ minuend)
 	(redraw ename 3)
 	(princ "\nSelect SUBTRAHENDs : ")
 	(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
(princ "\nSelect SUBTRAHENDs : ")
 	)
 	(redraw ename 4)
 	(while (/= ename nil)
(GET-DATA)
(setq index   0
  	result  0
  	minuend (float minuend)
)
(princ (strcat "\n>>Expression: "
	(rtos minuend 2 precision)
	" - ("
   	)
)
(repeat (sslength Numbers)
  (setq ent	(entget (ssname Numbers index))
 subtrahend (read (cdr (assoc 1 ent)))
 index	(1+ index)
  )
  (if (numberp subtrahend)
(progn
  	(setq result (+ result subtrahend))
  	(if (/= index 1)
 (princ " + ")
  	)
  	(princ (rtos subtrahend 2 precision))
)
  )
)
(princ ")")
(if (= sw 1)
  (command ".undo" 1)
)
(setq result (- minuend result))
(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
(if (= switch 0)
  (OPT)
)
(ACTION option (rtos result 2 precision))
(setq ename nil
  	ename (car (entsel (strcat "\nSelect MINUEND : ")))
)
(if
  (or
(null ename)
(null (numberp (setq minuend (GET-VALUE "MINUEND"))))
  )
  (progn
(setvar "QAFLAGS" 0)
(vl-exit-with-error "")
  )
)
(princ minuend)
(princ "\nSelect SUBTRAHENDs <TEXT>: ")
(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
  (princ "\nSelect SUBTRAHENDs : ")
)
 	)
)
;; DIVIDE:
((= operation "Divide")
 	(setq switch 0
sw 0
 	)
 	(while (null (setq ename (car (entsel (strcat "\nSelect DIVIDEND : "))))))
 	(setq dividend (GET-VALUE "DIVIDEND"))
 	(while (null (numberp dividend))
(while (null (setq ename (car (entsel (strcat "\nSelect DIVIDEND : "))))))
(setq dividend (GET-VALUE "DIVIDEND"))
 	)
 	(princ dividend)
 	(redraw ename 3)
 	(princ "\nSelect DIVISORs : ")
 	(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
(princ "\nSelect DIVISORs : ")
 	)
 	(redraw ename 4)
 	(while (/= ename nil)
(GET-DATA)
(setq index   0
  	result  1
  	dividend (float dividend)
)
(princ (strcat "\n>>Expression: "
	(rtos dividend 2 precision)
	" / ("
   	)
)
(repeat (sslength Numbers)
  (setq ent (entget (ssname Numbers index))
 divisor (read (cdr (assoc 1 ent)))
 index (1+ index)
  )
  (if (numberp divisor)
(progn
  	(setq result (* result divisor))
  	(if (/= index 1)
 (princ " * ")
  	)
  	(princ (rtos divisor 2 precision))
)
  )
)
(princ ")")
(if (= sw 1)
  (command ".undo" 1)
)
(setq result (/ dividend result))
(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
(if (= switch 0)
  (OPT)
)
(ACTION option (rtos result 2 precision))
(setq ename nil
  	ename (car (entsel (strcat "\nSelect DIVIDEND : ")))
)
(if
  (or
(null ename)
(null (numberp (setq dividend (GET-VALUE "DIVIDEND"))))
  )
  (progn
(setvar "QAFLAGS" 0)
(vl-exit-with-error "")
  )
)
(princ dividend)
(princ "\nSelect DIVISORs : ")
(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
  (princ "\nSelect DIVISORs : ")
)
 	)
)
;; AVERAGE:
((= operation "Average")
(GET-TEXT)
(setq switch 0)
(while (/= Numbers nil)
  	(GET-DATA)
  	(setq index 0
 	id 0
 	result 0
  	)
  	(princ "\n>>Expression: (")
  	(repeat (sslength Numbers)
 (setq ent   (entget (ssname Numbers index))
   	value (read (cdr (assoc 1 ent)))
   	index (1+ index)
 )
 (if (numberp value)
(progn
 	(setq result (+ result value)
id   (1+ id)
 	)
 	(if (/= index 1)
   	(princ " + ")
 	)
 	(princ (rtos value 2 precision))
)
 )
  	)
  	(if (= sw 1) (command ".undo" 1))
  	(setq result (rtos (/ (float result) id) 2 precision))
  	(princ (strcat ") / " (rtos id 2 0)))
  	(princ (strcat "\n>>RESULT = " result))
  	(if (= switch 0)
 (OPT)
  	)
  	(ACTION option result)
  	(setq Numbers nil
 	Numbers (ssget '((0 . "*TEXT")))
  	)
)
)
;; MAX-MIN:
((= operation "maX-min")
(GET-TEXT)
(setq switch 0)
(while (/= Numbers nil)
  	(GET-DATA)
  	(setq index 0
 	Num-set nil
  	)
  	(repeat (sslength Numbers)
 (setq ent   (entget (ssname Numbers index))
   	value (read (cdr (assoc 1 ent)))
   	index (1+ index)
 )
 (if (numberp value)
(setq Num-set (cons value Num-set))
 )
  	)
  	(setq Num-set (vl-sort Num-set '>)
 	num-max (car Num-set)
 	num-min (last Num-set)
 	result  (strcat "MAX = "
   	(rtos num-max 2 precision)
   	"  MIN = "
   	(rtos num-min 2 precision)
  	)
  	)
  	(if (= sw 1) (command ".undo" 1))
  	(princ "\n>>Numbers set: ")
  	(princ Num-set)
  	(print)
  	(princ result)
  	(if (= switch 0)
 (OPT)
  	)
  	(ACTION option result)
  	(setq Numbers nil
 	Numbers (ssget '((0 . "*TEXT")))
  	)
)
)
;; ADD-BY...:
((= operation "ADd-by")
(if (null number0)
  	(setq number0 0.00
 	save4 number0
  	)
)
(setq number0 (getreal (strcat "Add by: <" (rtos number0 2 2) "> "))
index   0
)
(if (null number0)
  	(setq number0 save4)
  	(setq save4 number0)
)
(GET-TEXT)
(GET-DATA)
(repeat (sslength Numbers)      
  	(setq ent   (entget (ssname Numbers index))
 	value (read (cdr (assoc 1 ent)))
 	index (1+ index)
  	)      
  	(if (numberp value)
 (setq value (+ (float value) number0)
   	ent   (subst (cons 1 (rtos value 2 precision))
  	(assoc 1 ent)
  	ent
  	)
 )
  	)
  	(entmod ent)      
)
)
;;MULTIPLY-BY...:
((= operation "mUltiply-by")
(if (null number0)
  	(setq number0 0.00
 	save4 number0
  	)
)
(setq number0 (getreal (strcat "Multiply by: <" (rtos number0 2 2) "> "))
index   0
)
(if (null number0)
  	(setq number0 save4)
  	(setq save4 number0)
)
(GET-TEXT)
(GET-DATA)
(repeat (sslength Numbers)
  	(setq ent   (entget (ssname Numbers index))
 	value (read (cdr (assoc 1 ent)))
 	index (1+ index)
  	)
  	(if (numberp value)
 (setq value (* (float value) number0)
   	ent   (subst (cons 1 (rtos value 2 precision))
  	(assoc 1 ent)
  	ent
  	)
 )
  	)
  	(entmod ent)
)
)
 )
 (princ "<Exit>")
 (setvar "QAFLAGS" 0)
 (princ)
)

 

Tcal dùng lựa chọn AD (add-by) nhập hằng số K là -K nếu muốn trừ, K nếu muốn cộng

Bạn ơi bạn có thể thêm tiền tố vào trước kết quả xuất ra không? ví dụ (+1) + (+1) = (+2) tương tự với các ký tự khác ví dụ (layer1: 1,2) + (3) = (layer1: 3,2).

Và thêm phần +,-,*,/ với số nhập từ bàn phím nữa thì quá tuyệt. Thanks:D

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
levanduy    73

Lisp dùng rất tuyệt bác Tue_NV.Nhưng nay em muốn bác viết bổ sung khả năng cộng hằng số vào text nằm trong attribute block có được không ạ.Em hi vọng rất nhiều.Đợi chờ sản phẩm của bác.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Tue_NV    3.841

Lisp dùng rất tuyệt bác Tue_NV.Nhưng nay em muốn bác viết bổ sung khả năng cộng hằng số vào text nằm trong attribute block có được không ạ.Em hi vọng rất nhiều.Đợi chờ sản phẩm của bác.

Bạn xem bài viết số 1356 nhé :

Chương trình tính toán Cộng trừ Nhân Chia giá trị của Block Attribute; Text với 1 số hoặc 1 biểu thức.

http://www.cadviet.com/forum/index.php?showtopic=13203&st=1340

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

Đăng nhập để thực hiện theo  

×