Jump to content
InfoFile
Tác giả: pphung183
Bài viết gốc: 386714
Tên lệnh: gd
Lisp Lọc Đường Thẳng Theo Độ Dốc!

 

hehe hay quá, đúng cái mình cần rồi. Với cả hiện tại mình có cái lisp này để ghi độ dốc cho polyline, nhưng chỉ chọn...

>>

 

hehe hay quá, đúng cái mình cần rồi. Với cả hiện tại mình có cái lisp này để ghi độ dốc cho polyline, nhưng chỉ chọn được một đối tượng polyline, các bạn có thể giúp mình chỉnh sửa chọn được nhiều polyline (nếu là nhiều line được thì càng tốt) không ạ.

(defun c:gd (/ entpl p1 cao_text sp ep ang dodoc thap_phan)
(vl-load-com)
(setq entpl (entsel "\n Hay chon polyline can ghi do doc")
      entob (vlax-ename->vla-object (car entpl))
)
(setq x (getreal "\n Hay nhap ty le theo truc x: ")
      y (getreal "\n Hay nhap ty le theo truc y: "))
(setq cao_text (getreal "\n Hay nhap chieu cao text: ")
      h (getreal "\n Hay nhap khoang cach tu text toi pline: ")
      i 0
      thap_phan 2
      p1 (cadr entpl)
      ent (car entpl)
      m (vlax-curve-getendparam ent))
(while (< i m)
(setq sp (vlax-curve-getPointatparam ent i)
      ep (vlax-curve-getPointatparam ent (1+ i))
      ang (angle sp ep)
      x1 (car sp)
      y1 (cadr sp)
      x2 (car ep)
      y2 (cadr ep)
      dodoc (* (abs (/ (/ (- y2 y1) y) (/ (- x2 x1) x 100))) )
      dodoc (strcat (rtos dodoc 2 thap_phan) ))
(if (< (car sp) (car ep))
    (progn
    (setq pt (vlax-curve-getpointatparam ent (+ i 0.1)))
    (command "_.text" (list (- (car pt) (* h (sin ang))) (+ (cadr pt) (* h (cos ang)))) cao_text (/ (* ang 180) pi)(strcat dodoc))
    )
    (if (> (car sp) (car ep))
    (progn
    (setq pt (vlax-curve-getpointatparam ent (+ i 0.9)))
    (command "_.text" (list (+ (car pt) (* h (sin ang))) (+ (cadr pt) (* h (cos ang)))) cao_text (+ 180 (/ (* ang 180) pi)) (strcat dodoc))
    )
    (progn
    (setq pt (vlax-curve-getpointatparam ent (+ i 0.5)))
    (command "_.text" (list (+ (car pt) h) (cadr pt)) cao_text 90 (strcat dodoc))
    )
    )
)
(setq i (1+ i))

Bạn copy Lisp này ở đâu mà thiếu của tác giả thế :wacko: ... Tuy nhiên Lisp trên còn thiếu trường hợp khi x1 = x2 sẽ dừng chạy chương trình :) . Thêm Line thì cũng tương tự thôi nhưng đơn giản hơn.


<<

Filename: 386714_gd.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 192275
Tên lệnh: cat
lisp cắt 1 đoạn thẳng

:)

Chỉ cần thế này thôi :

(defun c:cat()(command "lengthen" "DE"))

Có nghĩa là hãy dùng...

>>

:)

Chỉ cần thế này thôi :

(defun c:cat()(command "lengthen" "DE"))

Có nghĩa là hãy dùng giá trị âm trong lệnh Lengthen -> Delta nếu muốn cắt, và + nếu muốn thêm. Giá trị này tất nhiên sẽ được CAD lưu giữ cho lần tiếp theo

Ồ! Thằng "lengthen" này còn có chức năng hay ghê mà lâu nay đâu có biết. Thank Ket nhiều!


<<

Filename: 192275_cat.lsp
Tác giả: Tue_NV
Bài viết gốc: 69231
Tên lệnh: scdo
Hỏi về chỉnh kích thước hình tròn vẽ bằng lệnh donut

Tue_NV đã chỉnh lại.

Bạn thử Code này xem :

(defun c:scdo()
(vl-load-com)
(setq ss (ssget '((0 . "*POLYLINE"))) i 0)
(setq tle (getdist "\n Nhap he so ti le :...
>>
Tue_NV đã chỉnh lại.

Bạn thử Code này xem :

(defun c:scdo()
(vl-load-com)
(setq ss (ssget '((0 . "*POLYLINE"))) i 0)
(setq tle (getdist "\n Nhap he so ti le : "))

(while ((setq ent (ssname ss i))
(setq diem1 (cdr (assoc 10 (entget (entnext ent)))))
(setq diem2 (cdr (assoc 10 (entget(entnext (entnext ent))))))

(setq po (list (/ (+ (car diem1) (car diem2)) 2) (/ (+ (cadr diem1) (cadr diem2)) 2) 0))
(command "scale" ent "" po tle)
(setq i (1+ i))
)
(princ)
)

 

Đoạn viết này nó còn sai tọa độ nằm trên trục Y còn nhiều hơn code trước,mình gửi file đính kèm nhờ bạn xem giúp.Thanks

http://www.cadviet.com/upfiles/2/new_block.dwg

Chào 790312. Bạn thử file này với code trên xem sao. Nó không bị lỗi nữa.

http://www.cadviet.com/upfiles/2/drawing1.dwg

 

Còn vấn đề của bạn thì Tue_NV đã tìm ra nguyên nhân rồi có điều là mình chưa có thời gian chữa lại. Bạn chịu chờ nhé :


<<

Filename: 69231_scdo.lsp
Tác giả: saycaphe
Bài viết gốc: 419314
Tên lệnh: test
Lisp Tự Mirror, Sau Đó Join Các Đường Đã Mirror

 

Quả Lisp thô sơ này chắc chạy ngon. Nhớ move chuẩn trục Y ở 0.0 nhé. ^_^

(defun c:test (/ ss n ss1)
 ...
>>

 

Quả Lisp thô sơ này chắc chạy ngon. Nhớ move chuẩn trục Y ở 0.0 nhé. ^_^

(defun c:test (/ ss n ss1)
  (setq ss (ssget))
  (setq n 0)
  (setq ss1 (ssadd))
  (repeat (sslength ss)
    (setq ss1 (ssadd (ssname ss n) ss1))    
    (command "mirror" ss1 "" "0,0" "0,1" "N" "")
    (setq ss1 (ssadd (entlast) ss1))
    (command ".PEDIT" "m" ss1 "" "j" "0.025" "" )
    (setq ss1 (ssadd))
    (setq n (1+ n))
    )
  (princ)
  )

Bác ơi.

Lisp này, chẳng hạn mình muốn chạy lệnh qua 1 đường tự chọn(điểm đầu, điểm cuối) chứ không mặc định qua trục,thì làm sao bác.

Em thêm cái đoạn đánh dấu đỏ, mà nó chỉ mirror 1 đường, không join, rồi dừng lại.

 

(defun c:minj (/ ss n ss1)

(setq ss (ssget))

(setq n 0)

(setq ss1 (ssadd))

(setq stap (getpoint "\nStart point of Mirror line (line may intersect every polyline only once!): "))

(setq endp (getpoint stap "\nEnd point of Mirror line: "))

(repeat (sslength ss)

(setq ss1 (ssadd (ssname ss n) ss1))

(command "mirror" ss1 "" "stap" "endp" "N" "")

(setq ss1 (ssadd (entlast) ss1))

(command ".PEDIT" "m" ss1 "" "j" "0.025" "" )

(setq ss1 (ssadd))

(setq n (1+ n))

)

(princ)

)

 

Bác xem giúp em với.

Thanks :blush:


<<

Filename: 419314_test.lsp
Tác giả: hung37cespk
Bài viết gốc: 355088
Tên lệnh: ttt
Nhờ giúp đỡ: Viết lisp chỉnh sửa kí tự trong text.

 

Hế hế hế,

Muốn lisp thì có isp đây:

(defun c:ttt (/ ss old...
>>

 

Hế hế hế,

Muốn lisp thì có isp đây:

(defun c:ttt (/ ss old new)
(vl-load-com)
  (setq old (getstring "\n Nhap chuoi can thay the: ")
          new (getstring "\n Nhap chuoi gia tri thay the: ") )
 (alert "\n Chon cac text can thay the")
 (setq sst (acet-ss-to-list (ssget (list (cons 0 "*text")))))
(foreach a ssl
   (setq txt (cdr (assoc 1 (setq el (entget a))))
             txt (vl-string-translate old new txt) )
   (entmod (subst (cons 1 txt) (assoc 1 el) el))
)
)

Dạ, lisp bị sai rồi ạ


<<

Filename: 355088_ttt.lsp
Tác giả: tien2005
Bài viết gốc: 435317
Tên lệnh: gt cl
Nhờ sửa lip tính cốt đai và ghi vào trong dim

Đây nè Bạn, theo đúng yêu cầu. Hết

;-------------------------------------------------------------------------------------------------------------------------
;          ==============>>  GT: TINH SL DAI VA GHI VAO DIM <<================ 
;-------------------------------------------------------------------------------------------------------------------------

(defun C:gt (/ ctc ss)
 ...
>>

Đây nè Bạn, theo đúng yêu cầu. Hết

;-------------------------------------------------------------------------------------------------------------------------
;          ==============>>  GT: TINH SL DAI VA GHI VAO DIM <<================ 
;-------------------------------------------------------------------------------------------------------------------------

(defun C:gt (/ ctc ss)
  (or *ctc* (setq *ctc* 200))
  (initget 6)
  (setq	ctc (getint
	      (strcat "\nNh\U+1EADp b\U+01B0\U+1EDBc th\U+00E9p < "
		      (itoa *ctc*)
		      ">:"
	      ) ;_ end of strcat
	    ) ;_ end of getint
  ) ;_ end of setq
  (if ctc
    (setq *ctc* ctc)
  ) ;_ end of if
  (if (setq ss (ssget "_:L" (list (cons 0 "DIMENSION"))))
    (progn
      (command "_.undo" "_begin")
      (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
	(vla-put-TextOverride
	  (vlax-ename->vla-object ent)
	  (strcat
	    "<>\\X"
;;;	    (itoa (+ (fix (/ (cdr (assoc 42 (entget ent))) *ctc*)) 1))
	    (itoa (+ (fix (/ (- (cdr (assoc 42 (entget ent)))200) *ctc*)) 1))
	    "%%c10A"
	    (itoa *ctc*)
	  ) ;_ end of strcat
	) ;_ end of vla-put-TextOverride
      ) ;_ end of foreach
      (command "_.undo" "_end")
      (princ)
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of defun
(defun C:cl (/ num ss)
  (if (setq ss (ssget "_:L"))
    (progn
      (command "_.undo" "_begin")
      (or *num* (setq *num* 15))
      (initget 4)
      (setq num (getint (strcat "\nNhap color <" (itoa *num*) ">:")))
      (while (not (if num
		    (<= num 256)
		    T
		  ) ;_ end of if
	     ) ;_ end of not
	(princ "\nGia tri <=256.")
	(setq num (getint (strcat "\nNhap color <" (itoa *num*) ">:")))
      ) ;_ end of while
      (if num
	(setq *num* num)
      ) ;_ end of if
      (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
	(vla-put-Color (vlax-ename->vla-object ent) *num*)
      ) ;_ end of foreach
      (command "_.undo" "_end")
      (princ)
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of defun

 


<<

Filename: 435317_gt_cl.lsp
Tác giả: cuongtk2
Bài viết gốc: 435230
Tên lệnh: test
Giúp e phần lisp này!!!

Bạn thử cái này coi

(defun c:test ( / a r goc d ent p1)
(setq a (
>>

Bạn thử cái này coi

(defun c:test ( / a r goc d ent p1)
(setq a (getreal "\nLuoi A=")
      r (getreal "\nLuoi R=")
      goc (atan (/ r a))
      d (* a (sin goc) 8 )
      ent (car (entsel "\nChon khung Pline khep kin:"))
      p1 (getpoint "\nDiem moc co dinh luoi"))
   (setvar "hpname" "Line" )
   (setvar "hpscale" d )
   (setvar "hpang" goc)
  (command "bhatch" "o" "s" p1 "y" "s" ent "" "")
   (setvar "hpang" (- 0 goc))
 (command "bhatch" "o" "s" p1 "y" "s" ent "" "")
  )

 


<<

Filename: 435230_test.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435338
Tên lệnh: jl jr jc
Lisp Canh Lề Text nhanh

Em dùng quen Cad 2014 nên chưa có lệnh TextAlign, và em nghĩ cũng có nhiều người chưa nâng cấp lên cad đời cao quá vì thói quen ^^

Sửa lại 1 chút Lisp của chủ tus để dùng được với cả MTEXT. Lệnh vẫn như cũ.

(Mtext mình hay dùng kiểu TOP Left, Top Right, Top Center. Bạn nào dùng kiểu khác như Middle Left, bottom left thì đổi các kí tự đầu  tương ứng vào (command "_.justifytext" #sset ""...

>>

Em dùng quen Cad 2014 nên chưa có lệnh TextAlign, và em nghĩ cũng có nhiều người chưa nâng cấp lên cad đời cao quá vì thói quen ^^

Sửa lại 1 chút Lisp của chủ tus để dùng được với cả MTEXT. Lệnh vẫn như cũ.

(Mtext mình hay dùng kiểu TOP Left, Top Right, Top Center. Bạn nào dùng kiểu khác như Middle Left, bottom left thì đổi các kí tự đầu  tương ứng vào (command "_.justifytext" #sset "" "_TC") nhé ^^

(defun c:JL( / qa #sset osmode pt2 ssl pcanh te pt ptnew tent)
  (prompt "\nCh\U+1ECDn TEXT c\U+1EA7n ch\U+1EC9nh s\U+1EEDa: ")
  (setq #sset (ssget '((0 . "MTEXT,TEXT"))))
  (setq qa (getvar 'QAFLAGS)
	      oldos (getvar 'osmode))
  (setvar 'QAFLAGS 1)
  (command "_.justifytext" #sset "" "_TL")
  (setq pcanh (getpoint "\nPick \U+0111i\U+1EC3m c\U+0103n l\U+1EC1 tr\U+00E1i!"))
  
  
  (setq ssl (sslength #sset))
  
  (while (> ssl 0)
    (setq te (ssname #sset (setq ssl (1- ssl))))
    (if (= (cdr (assoc 0 (entget te))) "TEXT") (progn
    (setq pt (cdr (assoc 11 (entget te))))
    (if (equal pt '(0.0 0.0 0.0))
      (setq pt (cdr (assoc 10 (entget te))))
    )
    (setq ptnew (list (car pcanh) (cadr pt) 0.0))
    (setq tent (entget te))
    (setq tent (subst (cons 73 2) (assoc 73 tent) tent))
    (setq tent (subst (cons 72 0) (assoc 72 tent) tent))
    (setq tent (subst (cons 11 ptnew) (assoc 11 tent) tent))
    (entmod tent)
  )
    (progn
      (setq pt (cdr (assoc 10 (entget te))))
      (setq pt2  (list (car pcanh) (cadr pt) (caddr pt)))
      (setvar "osmode" 0)
      (command "MOVE" te "" pt pt2)
      (setvar "osmode" oldos)
      
      ))
  (princ)
)
(setvar 'QAFLAGS qa)
)
;======================================================================================================================================================================
(defun c:JR ( / qa #sset osmode pt2 ssl pcanh te pt ptnew tent)
  (prompt "\nCh\U+1ECDn TEXT c\U+1EA7n ch\U+1EC9nh s\U+1EEDa: ")
 (setq #sset  (ssget '((0 . "MTEXT,TEXT"))))
  (setq qa (getvar 'QAFLAGS)
	      oldos (getvar 'osmode))
  (setvar 'QAFLAGS 1)
  (command "_.justifytext" #sset "" "_TR")
  (setq pcanh (getpoint "\nPick \U+0111i\U+1EC3m c\U+0103n l\U+1EC1 ph\U+1EA3i!"))
  (setq ssl (sslength #sset))
  (while (> ssl 0)
    (setq te (ssname #sset (setq ssl (1- ssl))))
    (if (= (cdr (assoc 0 (entget te))) "TEXT") (progn
    (setq pt (cdr (assoc 11 (entget te))))
    (if (equal pt '(0.0 0.0 0.0))
      (setq pt (cdr (assoc 10 (entget te))))
    )
    (setq ptnew (list (car pcanh) (cadr pt) 0.0))
    (setq tent (entget te))
    (setq tent (subst (cons 73 2) (assoc 73 tent) tent))
    (setq tent (subst (cons 72 2) (assoc 72 tent) tent))
    (setq tent (subst (cons 11 ptnew) (assoc 11 tent) tent))
    (entmod tent)
  )  (progn
      (setq pt (cdr (assoc 10 (entget te))))
      (setq pt2  (list (car pcanh) (cadr pt) (caddr pt)))
      (setvar "osmode" 0)
      (command "MOVE" te "" pt pt2)
      (setvar "osmode" oldos)
      ))
  (princ)
)
(setvar 'QAFLAGS qa))
;======================================================================================================================================================================
(defun c:JC( / qa #sset osmode pt2 ssl pcanh te pt ptnew tent)
  (prompt "\nCh\U+1ECDn TEXT c\U+1EA7n ch\U+1EC9nh s\U+1EEDa: ")
  (setq #sset  (ssget '((0 . "MTEXT,TEXT"))))
  (setq qa (getvar 'QAFLAGS)
	      oldos (getvar 'osmode))
  (setvar 'QAFLAGS 1)
  (command "_.justifytext" #sset "" "_TC")
  (setq pcanh (getpoint "\nPick \U+0111i\U+1EC3m c\U+0103n l\U+1EC1 gi\U+1EEFa!"))

  (setq ssl (sslength #sset))
  
  (while (> ssl 0)
    (setq te (ssname #sset (setq ssl (1- ssl))))
    (if (= (cdr (assoc 0 (entget te))) "TEXT") (progn
    (setq pt (cdr (assoc 11 (entget te))))
    (if (equal pt '(0.0 0.0 0.0))
      (setq pt (cdr (assoc 10 (entget te))))
    )
    (setq ptnew (list (car pcanh) (cadr pt) 0.0))
    (setq tent (entget te))
    (setq tent (subst (cons 73 2) (assoc 73 tent) tent))
    (setq tent (subst (cons 72 1) (assoc 72 tent) tent))
    (setq tent (subst (cons 11 ptnew) (assoc 11 tent) tent))
    (entmod tent)
  )(progn
      (setq pt (cdr (assoc 10 (entget te))))
      (setq pt2  (list (car pcanh) (cadr pt) (caddr pt)))
      (setvar "osmode" 0)
      (command "MOVE" te "" pt pt2)
      (setvar "osmode" oldos)
      ))
  
  (princ)
)
(setvar 'QAFLAGS qa))

 


<<

Filename: 435338_jl_jr_jc.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435336
Tên lệnh: daa
HỎI ĐÁP VỀ ĐO KÍCH THƯỚC
17 giờ trước, Doan Van Ha đã nói:

Cái này dùng Lisp thì OK, nhưng...

>>
17 giờ trước, Doan Van Ha đã nói:

Cái này dùng Lisp thì OK, nhưng viết Lisp để phục vụ việc cỏn con này thì vô duyên quá.

Cháu đồng ý với bác đúng là việc cỏn con thật ^^

Nhưng giả sử nếu thực hiện nó nhiều lần thì đúng là vẫn nên viết Lisp để đỡ tốn công

Như cháu có lúc hay phải đo chiều dài các thanh thép hình để tính khối lượng mà mỗi thanh nghiêng 1 góc khác nhau, mà đổi ucs thủ công thì đúng là mất thời gian.

Nên cháu có viết 1 Lisp này, không biết tối ưu nhất chưa nhưng cũng đủ dùng cho công việc. 

Share cho bạn thớt và những ai chưa biết dùng tạm.

ezgif.com-video-to-gif.gif.ce30bd464f866c279dfa27f71a504943.gif

(defun c:daa (/ p1 p2 p3 p4 osm)
  (setq p1 (getpoint "\nPick \U+0111i\U+1EC3m \U+0111\U+1EA7u ti\U+00EAn.")
	p2 (getpoint "\nPick H\U+01B0\U+1EDBng"))
  (setq p3 (polar (list (/ (+ (car p1) (car p2)) 2) (max (cadr p1) (cadr p2)) (caddr p1)) (/ pi 2) 100))	
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (vl-cmdf "_UCS" "N" "3" p1 p2 p3)
  (setvar 'osmode osm)
 (if  (setq p4 (getpoint "\nPick \U+0111i\U+1EC3m ti\U+1EBFp theo")) (progn
	(setvar 'osmode 0)					   
  (vl-cmdf "_dimlinear" (list 0.0 0.0 0.0) p4 pause)
	(setvar 'osmode osm)
  (vl-cmdf "_UCS" "W")) (progn
(setvar 'osmode osm)
   (vl-cmdf "_UCS" "W")))
  )

 


<<

Filename: 435336_daa.lsp
Tác giả: NTD
Bài viết gốc: 203232
Tên lệnh: cotxx
Đánh cốt tự động bằng lisp DC

Bạn có thể thêm vào lệnh sau Cotxx : dùng để định nghĩa cốt bất kỳ (tương tự cốt 0.00)

(defun c:cotxx ()  (setq...
>>

Bạn có thể thêm vào lệnh sau Cotxx : dùng để định nghĩa cốt bất kỳ (tương tự cốt 0.00)

(defun c:cotxx ()  (setq Cotxx (getreal "\nNhap cot can dinh nghia: ")      Cot00 (+ (cadr (getpoint (strcat "\nDiem co cot " (rtos cotxx 2 3) ": "))) Cotxx)    )  (princ))

 

Bạn cũng có thể kết hợp với lệnh tăng giảm cốt đồng loạt, tham khảo tại đây

http://www.cadviet.com/forum/index.php?sho...ost&p=37756

 

 

đoạn mã của bác là

(defun c:cotxx ()

(setq Cotxx (getreal "\nNhap cot can dinh nghia: ")

Cot00 (+ (cadr (getpoint (strcat "\nDiem co cot " (rtos cotxx 2 3) ": "))) Cotxx)

)

(princ)

)

 

em thấy phải thay dấu cộng + thanh dấu trừ - mới chuẩn, em đã thử rồi , sẽ viết lại là :

 

(defun c:cotxx ()

(setq Cotxx (getreal "\nNhap cot can dinh nghia: ")

Cot00 (- (cadr (getpoint (strcat "\nDiem co cot " (rtos cotxx 2 3) ": "))) Cotxx)

)

(princ)

)


<<

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

 

Thay đổi chiều cao Text/Mtext

;Doan Van Ha - CADViet.com. 27-11-2011. Thay doi chieu cao Text/Mtext.
(defun C:HT...
>>

 

Thay đổi chiều cao Text/Mtext

;Doan Van Ha - CADViet.com. 27-11-2011. Thay doi chieu cao Text/Mtext.
(defun C:HT (/ ss i heig size)
(vl-load-com)
(setq i 0)
(princ "\nChon cac Text/Mtext can thay doi chieu cao...")
(setq ss (ssget '((-4 . "<OR") (0 . "MTEXT") (0 . "TEXT") (-4 . "OR>"))))
(if ss
 (progn
  (setq size (getvar "textsize"))
  (setq hei (getdist (strcat "\nSpecify text height <" (rtos size 2) ">: ")))
  (if (= hei nil) (setq hei size))
  (repeat (sslength ss)
(vla-put-height (vlax-ename->vla-object (ssname ss i)) hei)
(setq i (1+ i)))))
(princ))

 

 

Cảm ơn anh DVH, nhưng anh xem lại cái Rtos giúp em với. Nó luôn luôn lưu giá trị là 2, mà cái cần lưu là giá trị nhập của lần trước ạ !


<<

Filename: 183600_ht.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435417
Tên lệnh: te
Lisp đổi vị trí text trong cùng 1 dòng
(defun c:te (/ ss ent n)
  (if (setq ss (acet
>>
(defun c:te (/ ss ent n)
  (if (setq ss (acet-ss-to-list (ssget (list (cons 0 "MTEXT,TEXT"))))) (progn
  (foreach ent ss
    (if  (setq n (vl-string-search "-" (cdr (assoc 1 (entget ent))))) (progn
(entmod (subst (cons 1 (strcat (substr (cdr (assoc 1 (entget ent))) (+ n 2) ) "-"
			       (substr (cdr (assoc 1 (entget ent))) 1 n)))
	       (assoc 1 (entget ent)) (entget ent)))
)))
  (princ)))
  )

Bạn test thử xem được chưa


<<

Filename: 435417_te.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 435422
Tên lệnh: te
Lisp đổi vị trí text trong cùng 1 dòng
(defun c:te (/ a i ss ent ReplaceString old_str new_str strr )
  (defun ReplaceString 
>>
(defun c:te (/ a i ss ent ReplaceString old_str new_str strr )
  (defun ReplaceString (old_str new_str strr / m n)
(setq m 0 n (strlen new_str))
(while (setq m (vl-string-search old_str strr m))
(setq strr (vl-string-subst new_str old_str strr m))
(setq m (+ n m))
)strr )
 (if (setq ss (acet-ss-to-list (ssget (list (cons 0 "TEXT"))))) (progn
  (foreach ent ss
    (setq str (cdr (assoc 1 (entget ent))))
    (if  (vl-string-search "-" str) (progn
(if  (vl-string-search "%%U"  str) 
   	(progn (setq a "%%U")
(setq str (ReplaceString "%%U" "" str))
	  ) (progn
	(setq    a "")))
(setq i (vl-string-search "-" str))
(entmod (subst (cons 1 (strcat a (substr str (+ i 2) ) "-"
			       (substr str 1 i)))
	       (assoc 1 (entget ent)) (entget ent)))
)))
  (princ)))
 )

Cái này chỉ dùng cho trường hợp đổi tất cả text có gạch chéo, không dùng cho trường hợp có gạch chéo 1 vài vị trí text 


<<

Filename: 435422_te.lsp
Tác giả: hmt
Bài viết gốc: 327021
Tên lệnh: doitxt
xin giúp về đổi chỗ 2 text cho nhau

Lisp hoán đổi giá trị của hai Text cùng layer :

(defun C:doiTxt(/ obj1 obj2 ss tmp)
  (princ "Chon 2 Text cung layer...
>>

Lisp hoán đổi giá trị của hai Text cùng layer :

(defun C:doiTxt(/ obj1 obj2 ss tmp)
  (princ "Chon 2 Text cung layer :")
  (if (and
	(setq ss (ssget (list (cons 0 "TEXT")) ))
	(= 2 (sslength ss))
	(setq obj1 (vlax-ename->vla-object (ssname ss 0)))
	(setq obj2 (vlax-ename->vla-object (ssname ss 1)))
	(eq (vla-get-Layer obj1) (vla-get-Layer obj2)	) )
    (progn      
      (setq tmp (vla-get-TextString obj1))
      (vla-put-TextString obj1 (vla-get-TextString obj2))
      (vla-put-TextString obj2 tmp)))
  (princ))

Thank bác gia bạch , thế này vẫn phải pick từng cụm text nhỉ, có cách nào quét 1 phát tất cả các cụm text đó mà chúng đổi chỗ cho nhau dc k ạ


<<

Filename: 327021_doitxt.lsp
Tác giả: cuongtk2
Bài viết gốc: 435416
Tên lệnh: test
Lisp đổi vị trí text trong cùng 1 dòng

Đây

(defun c:test ( / ss i str ent n vitri trai phai )
 (vl-load
>>

Đây

(defun c:test ( / ss i str ent n vitri trai phai )
 (vl-load-com)
  (setq ss (ssget '(( 0 . "TEXT"))))
  (setq n (sslength ss) i 0)
  (while (< i n)
    (progn
       (if
     (setq     ent (entget (ssname ss i))
              str (cdr (assoc 1 ent))
              vitri (vl-string-position (ascii "-") str)     )
    (setq     phai (substr str 1 vitri)
              trai (substr str  (+ vitri 2))
              str (strcat trai "-" phai)
        ent (subst (cons 1 str) (assoc 1 ent) ent)))
    (entmod ent)
    )
  (setq i (1+ i))
     )
  )


 


<<

Filename: 435416_test.lsp
Tác giả: Gatesi
Bài viết gốc: 85271
Tên lệnh: gb
Lisp tính diện tích
Thực ra Lisp đã giải bài toán đó rồi. Chỉ cần chỉnh lại 1 chút cho phù hợp mà thôi.

ndn386 thử lại code này xem nhé :

(defun c:gb(/ p ss S frome...
>>
Thực ra Lisp đã giải bài toán đó rồi. Chỉ cần chỉnh lại 1 chút cho phù hợp mà thôi.

ndn386 thử lại code này xem nhé :

(defun c:gb(/ p ss S frome cur toe tt)
(setq p (getpoint "\n Pick 1 diem vao mien trong hinh kin :") 
ss (ssadd) S 0)
(while p
(setq frome (entlast))
(command ".boundary" "A" "O" "R" "" p "")
(setq toe (entlast));; 
(setq cur frome
)
(while (not (eq cur toe))
(setq cur (entnext cur)
ss (ssadd cur ss))
(command "area" "S" "O" ss "" "")
(setq tt (getvar "area"))
(setq S (+ S tt))
)
(command "area" "A" "O" "L" "" "")
(setq tt (getvar "area"))
(setq S (+ S (* tt 2))) 
(sssetfirst ss ss)
(setq p (getpoint "\n Pick 1 diem vao mien trong hinh kin / An phim bat ki de xem ket qua:"))

)
(if (> (sslength ss) 0)
(alert (strcat "Area = " (rtos (abs S) 2 2)))
(alert "\n Ban chua Pick vao mien kin nao ca ")
)
(command "erase" ss "")
(Princ)
)

Theo em nghĩ nên có 1,2 tính năng thêm nữa. Đầu tiên có lẽ là việc gán giá trị diên tích vào text trên màn hình, 2 là việc lựa chọn đưn vị diện tích( chỉ làm 1 lần đối với 1 bản vẽ mở ra), 3 là 1 việc hơi khó, e thấy trên mạng có lisp tính diện tích xong rồi tự cập nhật diện tích theo hình (Từ trang này :http://www.offshore-lisp.com/download1/text.html

), bác nào xem hoàn thiện theo lisp này sẽ rất hay.


<<

Filename: 85271_gb.lsp
Tác giả: hhhhgggg
Bài viết gốc: 43266
Tên lệnh: nk
Lisp nhân thêm hệ số K vào Text ???????????
Hy vọng lần này đúng ý các bạn. Chương trình chấp nhận các đối tượng là TEXT lẫn MTEXT:

 

;;;-------------------------------------------------------
(defun...
>>
Hy vọng lần này đúng ý các bạn. Chương trình chấp nhận các đối tượng là TEXT lẫn MTEXT:

 

;;;-------------------------------------------------------
(defun etype (e) ;;;Entity Type
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------------
(defun rnd(x) ;;;Round x, return INT
(if (>= x 0) (fix (+ x 0.5)) (fix (- x 0.5)))
) 
;;;-------------------------------------------------------
(defun round2(x / S i j S1 S2)
(setq S (itoa (rnd (* (abs x) 100))))
(if (= (strlen S) 1) (setq S (strcat "00" S)))
(if (= (strlen S) 2) (setq S (strcat "0" S)))
(setq
   i (strlen S)
   j (- i 2)
  S1 (substr S 1 j)
  S2 (substr S (1+ j) 2)
)
(if (>= x 0) (strcat S1 "." S2) (strcat "-" S1 "." S2))
)
;;;-------------------------------------------------------
(defun C:NK( / ss k i e d v S)
(setq
   ss (ssget '((0 . "TEXT,MTEXT")))
   k (getreal "\nNhan voi he so k = ")
   i 0
)
(repeat (sslength ss)
   (setq e (ssname ss i))
   (if (= (etype e) "MTEXT") (progn
       (command "explode" e "")
       (setq e (entlast))
   ))
   (setq
       d (entget e)
       v (* (atof (cdr (assoc 1 d))) k)
       S (round2 v)
       d (subst (cons 1 S) (assoc 1 d) d)
   )
   (entmod d)
   (setq i (1+ i))
)
(princ)
)
;;;-------------------------------------------------------

@duy782006: không được bạn ơi! Ví dụ:

Command: (rtos 1.0023 2 2)

return "1" -> không đúng ý các bạn ấy!

@giabach:

1. Dùng rtos không giải quyết triệt để được như đã nói trên.

2. Bạn thêm Isnumeric thì tốt thôi, nhưng liệu có cần đến mức ấy không? Dù sao, user cũng phải tự chịu trách nhiệm về những gì mình làm chứ?

Okk !!! Bác SSG đã giải quyết được vấn đề rùi. Cảm ơn bác đã nhiệt tình giúp đỡ !!!!!!!


<<

Filename: 43266_nk.lsp
Tác giả: anhGeodesy
Bài viết gốc: 435493
Tên lệnh: gt cl
Nhờ sửa lip tính cốt đai và ghi vào trong dim
16 giờ trước, laivanyen đã nói:

Em không muốn xuống dòng mà để...

>>
16 giờ trước, laivanyen đã nói:

Em không muốn xuống dòng mà để ngang ở trên và sửa lại  ví dụ 8000=40x200  hoặc 40x200=8000 thì sửa như nào anh giúp em với

Xin phép @tien2005 sửa thế này không biết có đúng ý của chủ thớt không?

; https://www.cadviet.com/forum/topic/175922-nhờ-sa-lip-tính-ctai-và-ghi-vào-trong-dim/

;-------------------------------------------------------------------------------------------------------------------------
;          ==============>>  GT: TINH SL DAI VA GHI VAO DIM <<================ 
;-------------------------------------------------------------------------------------------------------------------------

(defun C:gt (/ ctc ss)
  (or *ctc* (setq *ctc* 200))
  (or *d* (setq *d* 10))
  (initget 6)
  (setq    ctc (getint
          (strcat "\nNh\U+1EADp b\U+01B0\U+1EDBc th\U+00E9p < "
              (itoa *ctc*)
              ">:"
          ) ;_ end of strcat
        ) ;_ end of getint
  ) ;_ end of setq
  (if ctc
    (setq *ctc* ctc)
  ) ;_ end of if
  (setq    d (getstring
          (strcat "\nNh\U+1EADp \U+0110\U+01B0\U+1EDDng k\U+00EDnh th\U+00E9p (Phi) < "
               *d*
              ">:"
          ) ;_ end of strcat
        ) ;_ end of getint
  )
  (if d
    (setq *d* d)
  )
  (if (setq ss (ssget "_:L" (list (cons 0 "DIMENSION"))))
    (progn
      (command "_.undo" "_begin")
      (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (vla-put-TextOverride
      (vlax-ename->vla-object ent)
;;;      (strcat
;;;        "<>\\X"
;;;;;;        (itoa (+ (fix (/ (cdr (assoc 42 (entget ent))) *ctc*)) 1))
;;;        (itoa (+ (fix (/ (- (cdr (assoc 42 (entget ent)))200) *ctc*)) 1))
;;;        ;"%%c10A"
;;;        (strcat "%%c" d "a")
;;;        (itoa *ctc*)
;;;      ) ;_ end of strcat

(strcat
;;;        (itoa (+ (fix (/ (cdr (assoc 42 (entget ent))) *ctc*)) 1))
  "<> ="
        (itoa (+ (fix (/ (- (cdr (assoc 42 (entget ent)))200) *ctc*)) 1))
        ;"%%c10A"
            (strcat "%%c" d "a")
        (itoa *ctc*)
;;;" - <>"
      ) ;_ end of strcat?

      
    ) ;_ end of vla-put-TextOverride
      ) ;_ end of foreach
      (command "_.undo" "_end")
      (princ)
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of defun
(defun C:cl (/ num ss)
  (if (setq ss (ssget "_:L"))
    (progn
      (command "_.undo" "_begin")
      (or *num* (setq *num* 15))
      (initget 4)
      (setq num (getint (strcat "\nNhap color <" (itoa *num*) ">:")))
      (while (not (if num
            (<= num 256)
            T
          ) ;_ end of if
         ) ;_ end of not
    (princ "\nGia tri <=256.")
    (setq num (getint (strcat "\nNhap color <" (itoa *num*) ">:")))
      ) ;_ end of while
      (if num
    (setq *num* num)
      ) ;_ end of if
      (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (vla-put-Color (vlax-ename->vla-object ent) *num*)
      ) ;_ end of foreach
      (command "_.undo" "_end")
      (princ)
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of defun

 


<<

Filename: 435493_gt_cl.lsp
Tác giả: tuan_thietkedien
Bài viết gốc: 43162
Tên lệnh: chuyen
Lisp đổi kiểu nét thành Hidden2 và Line type scale = 0.2?
Sao bạn đòi hỏi nhiều quá vây? :cheers:

 

(Defun c:chuyen ( ) 
(Prompt "\nChon doi tuong muon chuyen ...")
(Setq chuyen (Ssget))
(command "Layer" "m" "daydien" "C" "1"...
>>
Sao bạn đòi hỏi nhiều quá vây? :cheers:

 

(Defun c:chuyen ( ) 
(Prompt "\nChon doi tuong muon chuyen ...")
(Setq chuyen (Ssget))
(command "Layer" "m" "daydien" "C" "1" "" "")
(command "style" "Standard" "" "" "0.8" "" "" "" "")
(command "chprop" chuyen "" "LA" "daydien" "Color" "1" "lt" "HIDDEN2" "s" "0.8" "")
(Princ)
)

 

Chào bạn

Tớ đang làm cho cty Nhật nên yêu cầu quản lý tiêu chuẩn khi thiết kế bản vẽ khắt khe lắm.

Cám ơn bạn nhiều nha.

Sau này mong được chỉ giáo thêm. B)

À, không biết mọi người trong diễn đàn có mở lớp dạy viết Lisp không nhỉ?


<<

Filename: 43162_chuyen.lsp
Tác giả: phamngoctukts
Bài viết gốc: 111906
Tên lệnh: ndt
Viết lisp theo yêu cầu [phần 2]
Ý thứ 1 là : Lisp của bạn bao giờ cũng xuất toạ độ của toàn bộ nhóm đối tượng. Trong khi đó, User chỉ muốn xuất chỉ 1 nhóm mà thôi. Mình chỉ chọn 1 nhóm để xử...
>>
Ý thứ 1 là : Lisp của bạn bao giờ cũng xuất toạ độ của toàn bộ nhóm đối tượng. Trong khi đó, User chỉ muốn xuất chỉ 1 nhóm mà thôi. Mình chỉ chọn 1 nhóm để xử lý mà thôi, bạn à. Vì theo Tue_NV biết là sẽ có các nhóm thửa độc lập với nhau, không liên quan đến nhau.

Ý thứ 2 : Về việc xử lý trong Lisp của bạn, Tue_NV đọc qua thôi, chứ chua lấn sâu vô nhiều, nên không thể đưa ra lời góp ý cho bạn được. Bạn thông cảm. Chỉ có điều là việc xử lý điểm đầu và điểm cuối LINE của bạn rất hay

Ý thứ 3 : Hàm getfiled cho xuất ra hộp thoại và cho phép User lưu ở đâu? cho phép đặt tên khác nhau, và đương nhiên là sẽ lưu file sang .txt hay .xls

Ý thứ 4 :

Bạn có thể tham khảo cái này

(defun c:ndt(/ ss lst);Nhom doi tuong
(setq i 1)
(princ (strcat "\n Chon nhom doi tuong thu : " (itoa i)))
(while (setq ss (ssget))
(if ss (setq lst (append lst (list ss))))
(princ (strcat "\n Chon nhom doi tuong thu : " (itoa (setq i (1+ i)))))
)
(alert (strcat "\n Co " (itoa (length lst)) " nhom doi tuong duoc chon" (vl-princ-to-string lst)))
)

Thank bác! từ trước đến nay em cứ nghĩ nhóm selectionset không tạo thành list được.


<<

Filename: 111906_ndt.lsp

Trang 289/330

289