Jump to content
InfoFile
Tác giả: hiepttr
Bài viết gốc: 424320
Tên lệnh: ns
Nội suy cao độ trên chiếu bằng

Đang rảnh, múc tới cho bạn vậy ^^

;lisp noi suy
(defun c:NS( / CD CD1 CD2 DIS1 DIS2 LST_VA OLD PL1 PL2 PT TEXT1 TEXT2)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(4 0))
(setq pl1 (car (entsel "\n Chon dinh (hoac chan) ta luy: "))
	  text1 (car (entsel "\n Chon text cao do tuong ung: "))
	  pl2 (car (entsel "\n Chon chan (hoac dinh)...
>>

Đang rảnh, múc tới cho bạn vậy ^^

;lisp noi suy
(defun c:NS( / CD CD1 CD2 DIS1 DIS2 LST_VA OLD PL1 PL2 PT TEXT1 TEXT2)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(4 0))
(setq pl1 (car (entsel "\n Chon dinh (hoac chan) ta luy: "))
	  text1 (car (entsel "\n Chon text cao do tuong ung: "))
	  pl2 (car (entsel "\n Chon chan (hoac dinh) ta luy: "))
	  text2 (car (entsel "\n Chon text cao do tuong ung: "))
	  )
(if (and pl1 pl2 text2 text2)
	(progn
		(setq cd1 (atof (Replace_First_Comma_by_Dot (cdr (assoc 1 (entget text1)))))
			  cd2 (atof (Replace_First_Comma_by_Dot (cdr (assoc 1 (entget text2)))))
		
			;  pl1 (vlax-ename->vla-object pl1)
			;  pl2 (vlax-ename->vla-object pl2)
			)
		(while
			(setq pt (getpoint "\n Pick diem can noi suy cao do <Enter de thoat>: "))
				(setq pt (reverse (cdr (reverse pt)))
					  dis1 (distance pt (vlax-curve-getClosestPointTo pl1 pt))
					  dis2 (distance pt (vlax-curve-getClosestPointTo pl2 pt))
					  cd (+ cd1 (* dis1 (/ (- cd2 cd1) (+ dis1 dis2))))
					  )
				(princ (strcat "\n Cao do tai diem nay la: " (rtos cd 2 4)))
		)
	)
	(princ "\n Bam lung tung roi ^^ Lam lai!")
)
;;xong tra ve:
(mapcar 'setvar lst_va old)
(princ)
)
;;;===================================
(defun Replace_First_Comma_by_Dot (string_with_comma / STR STR1 STR2 VT)
(cond
	((setq vt (vl-string-position (ascii ",") string_with_comma))
		(setq str1 (substr string_with_comma 1 vt)
			  str2 (substr string_with_comma (+ vt 2))
			  str (strcat str1 "." str2)
			  )
			  )
	(t (setq str string_with_comma))
)
)

 


<<

Filename: 424320_ns.lsp
Tác giả: dothanhdatvtchd
Bài viết gốc: 215223
Tên lệnh: ctpl
Chọn tất cả đối tượng nằm trong polyline khép kín hoặc wipe out

1). Bạn lấy lisp này cho dễ thấy:
 (defun c:ctpl() (setq plst (acet-geom-vertex-list (car (entsel "\n Chon pline khep kin")))) (setq...
>>
1). Bạn lấy lisp này cho dễ thấy:
 (defun c:ctpl() (setq plst (acet-geom-vertex-list (car (entsel "\n Chon pline khep kin")))) (setq SST (ssget "wp" plst)) (sssetfirst nil sst)) 

2). Một vấn đề thì bạn không được mở 2 topic như thế, phạm quy đấy!

1). Bạn lấy lisp này cho dễ thấy:
 (defun c:ctpl() (setq plst (acet-geom-vertex-list (car (entsel "\n Chon pline khep kin")))) (setq SST (ssget "wp" plst)) (sssetfirst nil sst)) 

2). Một vấn đề thì bạn không được mở 2 topic như thế, phạm quy đấy!

Bạn cho mình hỏi: Mình đã làm như hướng dẫn, nhưng Pline của mình đứt nhiều đoạn thì nó sẽ ko chọn được, báo nil nill là sao vậy?? Có thể khắc phục được không ?

Mình cám ơn.


<<

Filename: 215223_ctpl.lsp
Tác giả: hiepttr
Bài viết gốc: 424347
Tên lệnh: ns
Nội suy cao độ trên chiếu bằng

Uhm, thì tạo text vậy ^^

;lisp noi suy
(defun c:NS( / CD CD1 CD2 DIS1 DIS2 LST_VA OLD PL1 PL2 PT TEXT1 TEXT2)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(4 0))
(setq pl1 (car (entsel "\n Chon dinh (hoac chan) ta luy: "))
	  text1 (car (entsel "\n Chon text cao do tuong ung: "))
	  pl2 (car (entsel "\n Chon chan (hoac dinh) ta luy: "))
	 ...
>>

Uhm, thì tạo text vậy ^^

;lisp noi suy
(defun c:NS( / CD CD1 CD2 DIS1 DIS2 LST_VA OLD PL1 PL2 PT TEXT1 TEXT2)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(4 0))
(setq pl1 (car (entsel "\n Chon dinh (hoac chan) ta luy: "))
	  text1 (car (entsel "\n Chon text cao do tuong ung: "))
	  pl2 (car (entsel "\n Chon chan (hoac dinh) ta luy: "))
	  text2 (car (entsel "\n Chon text cao do tuong ung: "))
	  )
(if (and pl1 pl2 text2 text2)
	(progn
		(setq cd1 (atof (Replace_First_Comma_by_Dot (cdr (assoc 1 (entget text1)))))
			  cd2 (atof (Replace_First_Comma_by_Dot (cdr (assoc 1 (entget text2)))))
		
			;  pl1 (vlax-ename->vla-object pl1)
			;  pl2 (vlax-ename->vla-object pl2)
			)
		(while
			(setq pt (getpoint "\n Pick diem can noi suy cao do <Enter de thoat>: "))
				(setq pt (reverse (cdr (reverse pt)))
					  dis1 (distance pt (vlax-curve-getClosestPointTo pl1 pt))
					  dis2 (distance pt (vlax-curve-getClosestPointTo pl2 pt))
					  cd (+ cd1 (* dis1 (/ (- cd2 cd1) (+ dis1 dis2))))
					  )
				(princ (strcat "\n Cao do tai diem nay la: " (rtos cd 2 4)))
				(MakeText (trans pt 1 0) (rtos cd 2 2) 1 0 "L" nil nil nil nil)
		)
	)
	(princ "\n Bam lung tung roi ^^ Lam lai!")
)
;;xong tra ve:
(mapcar 'setvar lst_va old)
(princ)
)
;;;===================================
(defun Replace_First_Comma_by_Dot (string_with_comma / STR STR1 STR2 VT)
(cond
	((setq vt (vl-string-position (ascii ",") string_with_comma))
		(setq str1 (substr string_with_comma 1 vt)
			  str2 (substr string_with_comma (+ vt 2))
			  str (strcat str1 "." str2)
			  )
			  )
	(t (setq str string_with_comma))
)
)
;;;=======================================
(defun MakeText (point string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial	
(setq Lst (list '(0 . "TEXT")
				(cons 8 (if Layer Layer (getvar "Clayer")))									
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 Height)									
				(cons 1 string)									
				(if Ang (cons 50 Ang))									
				(cons 7 (if Style Style (getvar "Textstyle")))									
				(cons -3 (if xdata (list xdata) nil)))				
				justify (strcase justify))	
				(cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))				
					  ((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))				
					  ((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))				
					  ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))					
					  ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))				
					  ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
					  )	
					  (entmakex Lst)
);end

 


<<

Filename: 424347_ns.lsp
Tác giả: hiepttr
Bài viết gốc: 424346
Tên lệnh: cptk
Copy theo đối tượng có sẵn

Lại vọc bậy vậy

Lưu ý:

- Cad có cài bộ express

- Các thao tác chọn trắc ngang chuẩn / trắc ngang cần paste thực ra la chỉ cần chon được  2D polyline "PLINEMATPHAI" là được

- Tất nhiên là lisp chỉ chậy được trên BV tương tự BV mẫu, dạng khác thì ko chắc :D :D :D

;;;Lisp co cong nang tuong tu lenh...
>>

Lại vọc bậy vậy

Lưu ý:

- Cad có cài bộ express

- Các thao tác chọn trắc ngang chuẩn / trắc ngang cần paste thực ra la chỉ cần chon được  2D polyline "PLINEMATPHAI" là được

- Tất nhiên là lisp chỉ chậy được trên BV tương tự BV mẫu, dạng khác thì ko chắc :D :D :D

;;;Lisp co cong nang tuong tu lenh copy thiet ke trong nova
(defun c:CPTK( / BASE_POINT LST_VA OLD SS SS1 SS2)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon doi tuong can copy:")
(setq ss (ssget))
(prompt "\nChon trac ngang lam chuan:")
;(setq ss1 (ssget '((8 . "PLINEMATPHAI,PLINEMATTRAI"))))
(setq ss1 (ssget '((8 . "PLINEMATPHAI"))))
(prompt "\nChon trac ngang can paste:")
;(setq ss2 (ssget '((8 . "PLINEMATPHAI,PLINEMATTRAI"))))
(setq ss2 (ssget '((8 . "PLINEMATPHAI"))))
(if (and ss ss1 ss2)
	(progn
		(setq base_point (car (acet-geom-vertex-list (ssname ss1 0)))
			  ss2 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
		(foreach elem ss2
			(vl-cmdf ".copy" ss "" base_point (car (acet-geom-vertex-list elem)))
		)
		(princ (strcat "\nDa copy doi tuong ra " (itoa (length ss2)) " ban!"))
	)
	(princ "\nXay ra loi roi, nghien cuu lai!")
)
;;xong tra ve:
(mapcar 'setvar lst_va old)
(princ)
)

 


<<

Filename: 424346_cptk.lsp
Tác giả: letruong295
Bài viết gốc: 365354
Tên lệnh: ex3f
không explore được đối tượng 3D face!!

Lệnh ex3f (explode 3dFace) dưới đây sẽ làm điều đó.

 

 

(defun c:ex3f ()
(defun ex3fone...
>>

Lệnh ex3f (explode 3dFace) dưới đây sẽ làm điều đó.

 

 

(defun c:ex3f ()
(defun ex3fone (ent)
(setq
p1 (dxf ent 10)
p2 (dxf ent 11)
p3 (dxf ent 12)
p4 (dxf ent 13)
)
(ml p1 p2)
(ml p2 p3)
(ml p3 p4)
(ml p4 p1)
)
(sudung ex3fone (setq ss (ssget '((0 . "3DFACE")))))
(initget "Yes No")
(if (/= (getkword "\nErase 3DFace(s)? (<Yes>/No): ") "No")
(command ".erase" ss "")
)
(princ)
)
(defun dxf (ent c)
(cdr (assoc c (entget ent)))
)
(defun ml (p1 p2)
(entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
)
(defun sudung (ham ss / sodt index entdt soapp)
(setq sodt (if ss
(sslength ss)
0
)
soapp 0
index 0
)
(repeat sodt
(setq entdt (ssname ss index)
index (1+ index)
)
(if (ham entdt)
(setq soapp (1+ soapp))
)
)
soapp
)

Bác Hoành ơi!

 

 Cái lisp này có explode  được hình Polyface Mesh không?  Hoặc bác cho em cái Lisp để Explode hình Polyface Mesh nhé! Thanks!

 VD cái hình này!


<<

Filename: 365354_ex3f.lsp
Tác giả: Phiphi-
Bài viết gốc: 55223
Tên lệnh: olt
lisp offset liên tục

Đây bạn. Lisp Tue_NV cải tiến chạy theo đúng ý bạn nè :

(defun c:olt()
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)

(while (null (setq ss...
>>
Đây bạn. Lisp Tue_NV cải tiến chạy theo đúng ý bạn nè :

(defun c:olt()
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)

(while (null (setq ss (car(entsel "\n Chon doi tuong offset :")))) 
(Prompt "\n Hay chon lai doi tuong :")
)

(setq po(getpoint "\n phia offset:")) 
(setq kc(getdist "\n khoang cach offset:")) 
(setq n(getint "\n so lan offset:"))
(setq m 0 )
(setq p1 (vlax-curve-getClosestPointTo ss po))
(setq p2 (list (/ (- (* 2 (car p1)) (car po)) 2) (/ (- (* 2 (cadr p1)) (cadr po)) 2) 0.0))

(repeat n
(setq m(+ m 1))
(command "offset" (* m kc) ss po "")
) 

(initget "Y N") ;;;Init keywords
(setq ans (getkword "\n Ban co muon offset sang 2 ben khong?  :")) ;;;Get answer from user
(if (= ans "Y") 
(Progn
(setq m 0 )
(repeat n
(setq m(+ m 1))
(command "offset" (* m kc) ss p2 "")
) 
)
)
(setvar "osmode" oldos)
)

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

Cghúc thành công nhé :cheers:

Trong trường hợp cần lặp lại thì lệnh Lisp này yêu cầu User phải input lại các thông số cũ, nhờ Bác upgrade thêm để User khỏi phải input lại.

Lisp tham khảo dưới đây của Ssg có chức năng để khắc phục vấn đề trên. Thanks.

(defun C:OO(/ kc kc1 e msg)
(if (<= (setq kc (getvar "OFFSETDIST")) 0) (setq kc 20))
(setq msg (strcat "\nSpecial offset command\nOffset distance <" (rtos kc) ">:"))
(if (setq kc1 (getreal msg)) (setq kc kc1))
(while (setq e (car (entsel)))
(command "offset" kc e pause "")
(command "change" "L" "" "P" "LA" (getvar "clayer") "LT" (getvar "celtype") "")
)
)


<<

Filename: 55223_olt.lsp
Tác giả: dacvien2007
Bài viết gốc: 95689
Tên lệnh: lb2
Viết lisp theo yêu cầu [phần 2]
Hề hề hê,

Mình chạy thử rồi, nó đây nè bạn:

Kết quả chạy:

>>

Hề hề hê,

Mình chạy thử rồi, nó đây nè bạn:

Kết quả chạy:

http://www.cadviet.com/upfiles/2/lb2.jpg

lb2.jpg

Còn đây là cái lisp đã sửa nè:

(defun c:lb2 ()
(vl-load-com)
(command "undo" "be")
(setq en (entsel "\n Chon pline ")
ob (vlax-ename->vla-object (car en))
n (vlax-curve-getEndParam ob)
i 0
li1 (list)
)
(setq pb (getpoint "\n Chon diem dat bang")
h (getreal "\n Nhap chieu cao chu: ")
k (getreal "\n Nhap do rong cot: ")
)
(entmake (list (cons 0 "TEXT") (cons 10 pb) (cons 40 h) (cons 1 "BANG KET QUA")))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (car pb) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "STT")))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "X")))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Y")))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Z")))
(while (<= i n)
(setq p (vlax-curve-getPointAtParam ob i) 
li1 (append li1 (list p))
y (- (cadr pb) (* (+ 2 i) 1.5 h))
)
(entmake (list (cons 0 "TEXT") (cons 10 (list (car p) (+ (cadr p) 5))) (cons 40 1.0)
(cons 1 (strcat "X=" (rtos (car p) 2 2)))))
(entmake (list (cons 0 "TEXT") (cons 10 (list (car p) (+ (cadr p) 2.5))) (cons 40 1.0)
(cons 1 (strcat "Y=" (rtos (cadr p) 2 2)))))
(entmake (list (cons 0 "TEXT") (cons 10 (list (car p) (cadr p))) (cons 40 1.0)
(cons 1 (strcat "Z=" (rtos (caddr p) 2 2)))))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (car pb) y)) (cons 40 h) (cons 1  (rtos (1+ i) 2 0))))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) y)) (cons 40 h) (cons 1 (rtos (car p ) 2 2))))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) y)) (cons 40 h) (cons 1 (rtos (cadr p ) 2 2))))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) y)) (cons 40 h) (cons 1 (rtos (caddr p) 2 2))))
(setq i (1+ i))
)
(command "undo" "e")
(princ)
)

 

Hề hề hề, bạn xem xem có giống cái bạn đã sửa không hỉ????

Nhờ bạn giúp cho việc chèn các nút vào các đỉnh đường.

Cám ơn.


<<

Filename: 95689_lb2.lsp
Tác giả: SoftvnBin
Bài viết gốc: 204638
Tên lệnh: vtl1
Lisp rải taluy trên đường cong

Đây là lisp tôi sưu tầm và chỉnh sửa lại chút ít, có thể rải taluy cho các loại line, pline, spline, arc, circle ...

(Mới dừng ở việc...

>>

Đây là lisp tôi sưu tầm và chỉnh sửa lại chút ít, có thể rải taluy cho các loại line, pline, spline, arc, circle ...

(Mới dừng ở việc vẽ taluy cho 1 đường, phần vẽ mái taluy giữa 2 đường tôi chưa sửa xong)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;vtl;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun nsl () 
(if (/= scale nil)
   (progn
     (setq thongbao (strcat "Ty le ban ve ?, <1/" (itoa scale) ">:"))
     (if (not (setq scaletmp (getint thongbao)))
        (setq scaletmp scale)
     )
   )
   (progn
     (setq thongbao "Ty le ban ve ? <1/1000>:")
     (if (not (setq scaletmp (getint thongbao)))
         (setq scaletmp 1000)
     )
  )
)
(setq scale scaletmp)
(setq Defaultdist (* (* scale 2) 0.002))
(if (setq tg (getreal (strcat "\nKhoang cach ky hieu ta luy <" (rtos Defaultdist 2 2) ">:" ))) 
    (setq Defaultdist tg)
)
(setq	chieutaluy1 	1	sodoan 0  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun nsl1 ()
(setq ktdoantaluy1 2    tg (getreal (strcat "\nChieu dai doan ngan<"  (rtos ktdoantaluy1 2 2)  ">:" ))  )
(if tg 
  (setq ktdoantaluy1 tg)
)
(setq ktdoantaluy2 6    tg (getreal (strcat "\nChieu dai doan dai<" (rtos ktdoantaluy2 2 2) ">:" ))  )
(if tg
   (setq ktdoantaluy2 tg)
)
(setq khoangcachtl 2    tg (getreal (strcat "\nKhoang cach giua cac doan<"  (rtos khoangcachtl 2 2)  ">:"  ))  )
(if tg
   (setq khoangcachtl tg)
)
(setq sodoanngan 3    tg (getint (strcat "\nSo doan ngan trong 1 doan dai<" (rtos sodoanngan 2 0)  ">:"  ))  )
(if tg 
   (setq sodoanngan tg)
)
)
(Defun PlMake (Plist)			;  Create polyline entities
(entmake '((0 . "POLYLINE")))
(setq	n  (length Plist)	ic 0  )
(while (< ic n)
   (entmake (list (cons 0 "VERTEX") (cons 10 (nth ic Plist)))) 
   (setq ic (1+ ic))
)
(entmake '((0 . "SEQEND")))
)
;;;----------------------------------------------------------------
(defun ve1doantaluy (p1 p2 / pvt diemcu ktdoantaluy ketthuc)
 (setq pvt (+ (angle p1 p2) (* (/ pi 2) chieutaluy)))
 (setq ketthuc 1)
 (if (< sodoan sodoanngan)
   (progn
     (setq ktdoantaluy ktdoantaluy1)
     (setq sodoan (1+ sodoan))
   )
   (progn
     (setq ktdoantaluy ktdoantaluy2)
     (setq sodoan 0)
   )
)
(setq p2 (polar p1 pvt ktdoantaluy))
(plmake (list p1 p2))
(setq dem (1+ dem))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun xddsd (com epl kc / e0 e p dsd)
 (setq e0 (entlast))
 (while e0
   (setq e e0)
   (setq e0 (entnext e0))
 )
 (command com epl kc)
 (setq e (entnext e))
 (while e
   (setq p (cdr (assoc 10 (entget e))))
   (if	p
     (setq dsd (cons p dsd))
   )
   (setq e (entnext e))
 )
 (command "_.Undo" 1)
 (setq dsd dsd)
)				   
;;; ve ta luy cho 1 doi tuong
(Defun vetaluy (ep / le e ketthuc them dsd thutu)
 (setq dem 0)
 (setq e (entget (car ep)))
 (if (or (= (cdr (assoc 0 e)) "LWPOLYLINE") (= (cdr (assoc 0 e)) "POLYLINE") (= (cdr (assoc 0 e)) "SPLINE") (= (cdr (assoc 0 e)) "LINE")
          (= (cdr (assoc 0 e)) "ARC") (= (cdr (assoc 0 e)) "CIRCLE") )
     (setq ketthuc 1)
     (prompt "\nDoi tuong duoc chon khong hop le")
 )
 (if ketthuc
   (progn
     (setq thutu 0)
     (setq dsd (xddsd "_.Measure" ep khoangcachtl))
     (setq p1 (car dsd))
     (repeat (1- (length dsd))
         (setq thutu (1+ thutu))
         (setq p2 (nth thutu dsd))
         (ve1doantaluy p1 p2)
         (setq p1 p2)
     )
   )
 )
 (setq dem dem)
)
;;;==================================================
(Defun C:vtl1 (/ ep chon lai solan chon)
 (setvar "cmdecho" 0)
 (setvar "blipmode" 0)
 (command "undo" "g")
 (nsl)
 (setq ep 1)
 (while ep
   (setq solan	0  	chieutaluy 1    )
   (setq ep (entsel "\nChon doi tuong ve ta luy..."))
   (if	ep
     (progn
       (nsl1)
       (setq solan (vetaluy ep))
       (initget "Undo Change")
       (while  	(setq chon (getkword "Undo/Change <enter for exit>: "))
            (if (= chon "Undo")
                (command "_.Undo" solan)
            )
            (if (= chon "Change")
                (progn
                   (nsl1)
                   (setq chieutaluy -1)
                   (command "_.Undo" solan)
                   (setq solan (vetaluy ep))
                )
            )
            (initget "Undo Change")
        )
     )
   )
)
(command "undo" "e")
)

Nhờ các bác chỉnh sửa lại lisp giúp em các vấn đề sau:

 

1. Lưu số liệu lần nhập trước

2. Sau khi kết thúc lệnh bằng Enter (Undo/Change <enter for exit>) thì tự đóng block đối tượng vừa sinh ra với tên block cho nhập mới vào (với layer hiện hành)

3. Kết thúc bằng Enter không thực hiện tiếp lệnh VTL1

4. Khắc phục nill khi kết thúc lệnh Enter

5. Khi thực hiện lệnh để thay đổi phía rải taluy, không hỏi lại các tham số nữa mà thực hiện luôn

6. Khắc phục không đổi lệnh VLT1 thành lệnh khác được (giả sử thành lệnh VTL) (em thấy các lisp khác đổi lệnh được thông qua ký tự C:LLL thành tên lệnh mong muốn)

6. Khắc phụ lỗi không rải taluy hết đường và không vuông góc với đường như hình:17200_17200_hinh.jpg


<<

Filename: 204638_vtl1.lsp
Tác giả: SƠN MÈO
Bài viết gốc: 412061
Tên lệnh: tt
Bóc Khối Lượng Block Dynamic Tích Hợp Nhiều Đối Tượng

 

Được voi đòi lung tung, cung may cái đòi lung tung đó không phải sửa nhiều, xài thử cái này.

>>

 

Được voi đòi lung tung, cung may cái đòi lung tung đó không phải sửa nhiều, xài thử cái này.

(defun c:tt (/ LM:al-effectivename LM:getdynprops blk blk_name ent i lst_blk pt row ss tblobj x y htxt)
 (defun LM:al-effectivename  (ent / blk rep)
  (if (wcmatch (setq blk (cdr (assoc 2 (entget ent)))) "`**")
   (if (and (setq rep (cdadr (assoc -3 (entget (cdr (assoc 330 (entget (tblobjname "block" blk)))) '("AcDbBlockRepBTag")))))
            (setq rep (handent (cdr (assoc 1005 rep)))))
    (setq blk (cdr (assoc 2 (entget rep))))))
  blk
 )
 
 (defun LM:getdynprops  (blk)
  (mapcar '(lambda (x) (cons (vla-get-propertyname x) (vlax-get x 'value)))
          (vlax-invoke blk 'getdynamicblockproperties)))
 
 (or (> (setq htxt (getvar 'TEXTSIZE)) 0) (setq htxt (setvar 'TEXTSIZE 250)))
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
  (progn (vl-load-com)
         (setq i -1)
         (while (setq ent (ssname ss (setq i (1+ i))))
          (setq blk (vlax-ename->vla-object ent))
          (setq blk_name
(if (= "*" (substr (cdr (assoc 2 (entget ent))) 1 1))
(strcat (LM:al-effectivename ent) ": " (cdar (LM:getdynprops blk)))
(LM:al-effectivename ent)
))
          (if (not (assoc blk_name lst_blk))
           (setq lst_blk (cons (cons blk_name 1) lst_blk))
           (setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk)))) (assoc blk_name lst_blk) lst_blk))))
         (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)))))
         (setq pt     (getpoint "\nSpecify insertion point: ")
               TblObj (vla-addtable (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
                                    (vlax-3d-point pt) (+ (length lst_blk) 2) 4 (* 1.5 htxt) (* 6 htxt)))
         (vla-SetColumnWidth TblObj 0 (* 4 htxt))
         (vla-SetColumnWidth TblObj 1 (* 12 htxt))
         (vla-put-vertcellmargin TblObj (* 0.2 htxt))
         (mapcar '(lambda (x y) (vla-setTextHeight TblObj x y))
                 (list acTitleRow acHeaderRow acDataRow)
                 (list htxt htxt (* 0.75 htxt)))
         (mapcar '(lambda (x) (vla-setAlignment TblObj x 8)) (list acTitleRow acHeaderRow acDataRow))
         (vla-MergeCells TblObj 0 0 0 2)
         (vla-setText TblObj 0 0 "Bang thong ke khoi luong")
         (vla-setText TblObj 1 0 "STT")
         (vla-setText TblObj 1 1 "Ten")
         (vla-setText TblObj 1 2 "Don vi")
         (vla-setText TblObj 1 3 "So luong")
         (setq row 2
               i   1)
         (foreach pt  lst_blk
          (vla-setText TblObj row 0 (itoa i))
          (vla-setText TblObj row 1 (car pt))
          (vla-setText TblObj row 2 "cai")
          (vla-setText TblObj row 3 (itoa (cdr pt)))
          (setq row (1+ row)
                i   (1+ i))))
  (vlax-release-object TblObj))
 (princ))

ĐÁNH LỆNH 'TT' KO ĐƯỢC BÁC AH


<<

Filename: 412061_tt.lsp
Tác giả: quan_elec
Bài viết gốc: 95859
Tên lệnh: blkqty
Viết lisp theo yêu cầu [phần 2]
Vụ chèn hình là “chuyện nhỏ” cũng không phải "giữ bí mật" nhưng vì muốn giải quyết rốt ráo nên chậm Update cho anh em.

Nhưng nay thấy "AKA...

>>
Vụ chèn hình là “chuyện nhỏ” cũng không phải "giữ bí mật" nhưng vì muốn giải quyết rốt ráo nên chậm Update cho anh em.

Nhưng nay thấy "AKA buông súng" nên Post lên anh em sài thử!

 

- cột số lượng nếu <10 thì thêm số 0 vào trước ví dụ: 02

thọat nghe có vẽ có lý, nhưng t/hợp cột số lượng có giá trị hàng trăm (hàng ngàn) thì các số khác cũng phải biểu thị cùng format.

VD : 001 002 010 … với hàng ngàn còn rối mắt hơn.

Để giải quyết t/hợp này chỉ cần căn lề phải các số là hợp lý.

 

- Sort column  :

mặc định LISP sort cột Tên theo mẫu tự ABC tên của BLOCK

việc sort theo cột số lượng là t/hợp ít khi dùng nên bỏ qua (đôi khi vẫn sử dụng) :rolleyes:

các t/hợp khác cần phải viết thêm hộp thoại cho USER chọn lựa → banghead.gif

 

Sau  02 bà rồi sẽ là cái này :333.jpg

 

Bổ sung tùy chọn : nhập ký hiệu Block

Code :

(defun c:BlkQty (/ blk_id blk_len blk_name blks cur_var ent h header_lsp height i
	 ins j len0 lst_blk msp pt row ss str tblobj width width1 width2 x y)
;;  By : Gia Bach, gia_bach @  www.CadViet.com             ;;
(defun TxtWidth (val h msp / txt minp maxp)
 (setq	txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) h))
 (vla-getBoundingBox txt 'minp 'maxp )
 (vla-Erase txt)
 (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))  )

(defun GetOrCreateTableStyle (tbl_name / name namelst objtblsty objtblstydic tablst txtsty)
 (setq objTblStyDic (vla-item (vla-get-dictionaries *adoc) "ACAD_TABLESTYLE") )  
 (foreach itm (vlax-for itm objTblStyDic
	 (setq tabLst (append tabLst (list itm))))
   (if (not
  (vl-catch-all-error-p
    (setq name (vl-catch-all-apply 'vla-get-Name (list itm)))))
     (setq nameLst (append nameLst (list name)))  )  )
 (if (not (vl-position tbl_name nameLst))
   (vla-addobject objTblStyDic tbl_name "AcDbTableStyle"))
 (setq objTblSty (vla-item objTblStyDic tbl_name)
TxtSty (variant-value (vla-getvariable *adoc "TextStyle")))
 (mapcar '(lambda (x)(vla-settextstyle objTblSty x TxtSty))
      (list acTitleRow acHeaderRow acDataRow) )
 (vla-setvariable *adoc "CTableStyle" tbl_name) )

(defun GetObjectID (obj)
 (if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
   (vlax-invoke-method
     (setq Utility
       (cond
  (Utility)
         ((vla-get-Utility *adoc))))
     'GetObjectIdString obj :vlax-false )
   (vla-get-Objectid obj)))  
;main
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
   (progn
     (vl-load-com)
     (setq i -1 len0 8)
     (while (setq ent (ssname ss (setq i (1+ i))))
(setq blk_name (vla-get-name (vlax-Ename->Vla-Object ent)))
(if (> (setq blk_len (strlen blk_name)) len0)
  (setq str blk_name len0 blk_len) )	
(if (not (assoc blk_name lst_blk))
  (setq lst_blk (cons (cons blk_name 1) lst_blk))
  (setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk))))
		       (assoc blk_name lst_blk) lst_blk)))	    )
     (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)) ) ))
     (setq cur_var (mapcar 'getvar '("DYNMODE" "DYNPROMPT")))
     (mapcar 'setvar '("DYNMODE" "DYNPROMPT") '(1 1))
     (initget "Yes No")
     (setq ins (getkword "\nChen ki hieu Block   : ") )
     (or ins (setq ins "Yes"))
     (mapcar 'setvar '("DYNMODE" "DYNPROMPT") cur_var)      
     (or *h* (setq *h* (* (getvar "dimtxt")(getvar "dimscale"))))
     (initget 6)
     (setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))      
     (if h (setq *h* h) (setq h *h*) )
     (setq *adoc (vla-get-ActiveDocument (vlax-get-acad-object))
    msp (vla-get-modelspace *adoc)
    blks (vla-get-blocks *adoc))      
     (setq width1 (* 2 (TxtWidth "STT" h msp))
    width (* 2 (TxtWidth "So luong" h msp))
    height (* 2 h))
     (if str
(setq width2 (* 1.5 (TxtWidth (strcase str) h msp)))
(setq width2 width))
     (if (> h 3)
(setq width (* (fix (/ width 10))10)
      width1 (* (fix (/ width1 10))10)
      width2 (* (fix (/ width2 10))10)
      height (* (fix (/ height 5))5)))
     (GetOrCreateTableStyle "CadViet")
     (setq pt (getpoint "\nDiem dat Bang :")
    TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst_blk) 2) 5 height width))
     (vla-put-regeneratetablesuppressed TblObj :vlax-true)
     (vla-SetColumnWidth TblObj 0 width1)
     (vla-SetColumnWidth TblObj 1 width2)
     (vla-put-vertcellmargin TblObj (* 0.75 h))
     (vla-put-horzcellmargin TblObj (* 0.75 h))
     (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
      (list acTitleRow acHeaderRow acDataRow) )
     (mapcar '(lambda (x)(vla-setAlignment TblObj x 2))
      (list acTitleRow acHeaderRow acDataRow))      
     (vla-MergeCells TblObj 0 0 0 3)
     (vla-setText TblObj 0 0 "Bang thong ke")
     (setq j -1 header_lsp (list "STT" "Ten" "Don vi" "So luong" "Ky hieu")) 
     (repeat (length header_lsp)
(vla-setText TblObj 1 (setq j (1+ j)) (nth j header_lsp)))
     (setq row 2 i 1)    
     (foreach pt lst_blk
(setq blk_name (car pt) j -1)
(mapcar '(lambda (x)(vla-setText TblObj row (setq j (1+ j)) x))
	(list i blk_name "cai" (cdr pt)))
(if (= ins "Yes")
  (vla-SetBlockTableRecordId TblObj row 4 (GetObjectID (vla-item blks blk_name)) :vlax-true))
(vla-SetCellAlignment TblObj row 1 7)
(vla-SetCellAlignment TblObj row 3 9)
(setq row (1+ row) i (1+ i))	)
     (vla-put-regeneratetablesuppressed TblObj :vlax-false)
     (vlax-release-object TblObj) )  )
 (princ))

Lisp này gia_bach có thể viết thêm phần hỗ trợ các Block có tên tiếng Việt (Unicode) không ? Được thì hay quá pác. Thanks u


<<

Filename: 95859_blkqty.lsp
Tác giả: duvanngoc
Bài viết gốc: 288122
Tên lệnh: dt
Đổi tên Block được chọn !

 

Xin lỗi các bạn hôm trước mình đã sửa rồi quên up lại nên bị sai tí chút

code fix

>>

 

Xin lỗi các bạn hôm trước mình đã sửa rồi quên up lại nên bị sai tí chút

code fix

(defun c:dt ()
  (setq oldos (getvar "osmode"))
  (setvar "osmode" 0)
  (command "undo" "be")
  (setq ten (cdr(assoc 2 (entget(car(entsel "\nChon block dien hinh: "))))))
  (princ "\nChon block can doi ten: ")
  (setq	ssc (ssget (list(cons 0 "INSERT")(cons 2 ten)))
	tm (getstring "\nNhap ten moi: ")
	)
  (command "rename" "b" ten tm)
  (command "copyclip" ssc "")
  (command "block" "block_temp" "0,0" ssc "")
  (command "insert" "block_temp" "0,0" 1 1 0)
  (setq el (entlast))
  (setq pt (car(acet-ent-geomextents el)))
  (command "undo" "e"
	   "undo" 1)
  (command "erase" ssc "")
  (command "pasteclip" pt)
  (setvar "osmode" oldos)
  )

Bạn cho hiển thị tên block cũ vào trước đoạn chèn tên block mới thì tốt, dễ kiểm soát (xem hình đính kèm)

1609588_638393552882417_6017030616240096

Mình trích

(vl-load-com)
(or *kpblc-activedoc*
    (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of or

(defun c:vla-rename (/ ent name)
  (vla-startundomark *kpblc-activedoc*)
  (if
    (and (not (vl-catch-all-error-p
		(vl-catch-all-apply
		  '(lambda ()
		     (setq ent (car (entsel "\nSelect a block to be renamed")))
		     ) ;_ end of lambda
		  ) ;_ end of vl-catch-all-apply
		) ;_ end of vl-catch-all-error-p
	      ) ;_ end of not
	 ent
	 (= (cdr (assoc 0 (entget ent))) "INSERT")
	 (/= (substr (cdr (assoc 2 (entget ent))) 1 2) "*U")
	 (not (vl-catch-all-error-p
		(vl-catch-all-apply
		  '(lambda ()
		     (setq name	(getstring t
					   (strcat "\nEnter new name <"
						   (cdr (assoc 2 (entget ent)))
						   "> : "
						   ) ;_ end of strcat
					   ) ;_ end of getstring
			   ) ;_ end of setq
		     ) ;_ end of lambda
		  ) ;_ end of vl-catch-all-apply
		) ;_ end of vl-catch-all-error-p
	      ) ;_ end of not
	 (/= (vl-string-trim " " name))
	 ) ;_ end of and
     (if (vl-catch-all-error-p
	   (vl-catch-all-apply
	     '(lambda ()
		(vla-put-name
		  (vla-item (vla-get-blocks *kpblc-activedoc*)
			    (cdr (assoc 2 (entget ent)))
			    ) ;_ end of vla-item
		  name
		  ) ;_ end of vla-put-name
		) ;_ end of lambda
	     ) ;_ end of vl-catch-all-apply
	   ) ;_ end of vl-catch-all-error-p
       (princ (strcat "\nCan't rename a block "
		      (cdr (assoc 2 (entget ent)))
		      " with new name "
		      name
		      ) ;_ end of strcat
	      ) ;_ end of princ
       ) ;_ end of if
     (princ (strcat "\nA error has been catched:"
		    "\nSelection error | Selected entity isn't a block "
		    "| It's a unnamed or dynamic block"
		    ) ;_ end of strcat
	    ) ;_ end of princ
     ) ;_ end of if
  (vla-endundomark *kpblc-activedoc*)
  (princ)
  ) ;_ end of defun 

 

đoạn code có tính năng đó lên cho bạn tham khảo:


<<

Filename: 288122_dt.lsp
Tác giả: vbao
Bài viết gốc: 71944
Tên lệnh: dm2t
Viết Lisp theo yêu cầu
Bạn chạy thử Lisp này :

(defun c:dm2t (/ cmd ssPoint ePoint pt Left Right entLeft entRight dataLeft str);Data Mia to Text
 (defun dxf (tag obj) (cdr (assoc tag obj)))
 (defun...
>>
Bạn chạy thử Lisp này :

(defun c:dm2t (/ cmd ssPoint ePoint pt Left Right entLeft entRight dataLeft str);Data Mia to Text
 (defun dxf (tag obj) (cdr (assoc tag obj)))
 (defun p3(d x y) (polar (polar d 0 x) (* 0.5 pi) y))

 (command "undo" "be")
 (setq cmd (getvar "cmdecho"))
 (setvar "cmdecho" 0)
 (princ "\nChon cac Point (diem Mia) can noi Text voi nhau: ")
 (if (setq ssPoint (ssget (list (cons 0 "POINT") (cons 8 "AMIA"))))
   (foreach ePoint (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssPoint))))
     (setq pt (dxf 10 ePoint))
     (if (and
    (setq Left (ssget "_C" (p3 pt -3 3) pt (list (cons 0 "TEXT") (cons 8 "AMIA") ) ))
    (= (sslength Left) 1)
    (setq Right (ssget "_C" pt (p3 pt 3 -1) (list (cons 0 "TEXT") (cons 8 "AMIA") ) ))
    (= (sslength Right) 1)
    (not (equal (setq entLeft (ssname Left 0)) (setq entRight (ssname Right 0))))
    )
(progn
  (setq dataLeft (entget entLeft)
	str (strcat (dxf 1 dataLeft) "." (dxf 1 (entget entRight)))
	dataLeft (subst (cons 1 str) (assoc 1 dataLeft) dataLeft))
  (entmod dataLeft)
  (entdel entRight)
  )
)
     )
   )
 (setvar "cmdecho" cmd)
 (command "undo" "e")(princ)
)

 

anh gia_bach có thể thêm phần options : nhập layer các đối tượng cần nối, theo yêu cầu người sử dụng, chương trình sẽ linh động hơn. Cảm ơn anh


<<

Filename: 71944_dm2t.lsp
Tác giả: longbjch
Bài viết gốc: 278076
Tên lệnh: ha
đo chiều dài đường cong tại hai điểm bất kỳ

Đây bạn.

 

(defun C:HA( / obj1 obj2 p1 p2)
 (vl-load-com)
 (setq obj1 (car (entsel "\nChon duong cong: "))
 ...
>>

Đây bạn.

 

(defun C:HA( / obj1 obj2 p1 p2)
 (vl-load-com)
 (setq obj1 (car (entsel "\nChon duong cong: "))
       p1 (getpoint "\nP1: ")
  p2 (getpoint p1 "\nP2: ")
       obj2 (vlax-ename->vla-object (car (entsel "\nChon text: "))))
 (vla-put-TextString obj2 (rtos (abs (- (vlax-curve-getDistAtPoint obj1 p1) (vlax-curve-getDistAtPoint obj1 p2))) 2))
 (vla-put-Color obj2 1)
 (princ))
 

 anh ơi em hỏi đến bước chon text thì mình ấn gì để ra kết quả.


<<

Filename: 278076_ha.lsp
Tác giả: w1nDream
Bài viết gốc: 75613
Tên lệnh: ist
viết chữ theo đường thẳng bất kỳ bằng auto Lisp
Mình sửa lại như sau, tên lệnh đổi lại là ist vì int trùng với intersect của acad. Cao chữ nhập 1 lần, lần sau nếu k muốn đổi thì enter.

(defun c:ist(/...
>>
Mình sửa lại như sau, tên lệnh đổi lại là ist vì int trùng với intersect của acad. Cao chữ nhập 1 lần, lần sau nếu k muốn đổi thì enter.

(defun c:ist(/ chu os ent obj ndai p1 p2 pm ang caoc)
 (setq	chu (getstring "Chen chu :")
caoc (getreal (strcat "\nCao chu <" (rtos (getvar "USERR1")) ">:"))
	os (getvar "OSMODE")
ent (car (entsel "\nChon duong de chen :")))
 (setvar "OSMODE" 0)
 (if (not caoc) (setq caoc (getvar "USERR1")) (setvar "USERR1" caoc))
 (while ent
(setq obj  (vlax-ename->vla-object ent)
  ndai (/ (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)) 2)
  pr   (vlax-curve-getParamAtDist obj ndai)  
  p1   (vlax-curve-getPointAtParam obj (- pr 0.1))
  p2   (vlax-curve-getPointAtParam obj (+ pr 0.1))
  pm   (vlax-curve-getPointAtParam obj pr)
  ang  (if (< (car p1) (car p2)) (angle p1 p2) (angle p2 p1))
)
(command "text" "j" "BC" pm caoc (* 180 (/ ang pi)) chu)
(setq ent (car (entsel "\nChon duong de chen :")))
 )
 (setvar "OSMODE" os)
)

 

Pác q288 có thể fát triển nó thành viết chữ theo đường path có sẵn được hok?Cái này cũng đã nhiều người hỏi nhưng chắc vẫn chưa có câu trả lời xác đáng.

Hiện tại thì chi viết dạng Arctext (chỉ nhận đường arc).Còn Pl và Spl thì chịu.Hi vọng pác q288 và các tiền bối có thể giúp đỡ.thks!

:bigsmile:


<<

Filename: 75613_ist.lsp
Tác giả: master_c2
Bài viết gốc: 212593
Tên lệnh: ha
đo chiều dài đường cong tại hai điểm bất kỳ

(defun C:HA( / obj p1)
(setq obj (car (entsel "\nChon duong cong: ")))
(abs (- (vlax-curve-getDistAtPoint obj (setq p1 (getpoint "\nP1:...
>>

(defun C:HA( / obj p1)
(setq obj (car (entsel "\nChon duong cong: ")))
(abs (- (vlax-curve-getDistAtPoint obj (setq p1 (getpoint "\nP1: "))) (vlax-curve-getDistAtPoint obj (getpoint p1 "\nP2: ")))))

bạn ơi. mình mới chỉ đọc qua lisp nên chưa hiểu lắm.

đại khái là down về rồi. load rồi. sau đó chạy : HA --> chọn đường cong --> (nó hiện ra P1. mình bấm chọn tọa độ thì nó bến mất --> ko đo được gì)( mình làm thế đúng ko. bạn chỉ hộ mình cụ thể tí nhé.)


<<

Filename: 212593_ha.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 178351
Tên lệnh: at2t
Lisp Ghép Text Cần Giúp Đỡ

Hoặc là bạn chuyển phương thức chọn thành ssget như của bác Bình, hoặc nếu muốn giữ code bác gia_bach thì thêm redraw vào :

>>

Hoặc là bạn chuyển phương thức chọn thành ssget như của bác Bình, hoặc nếu muốn giữ code bác gia_bach thì thêm redraw vào :

(defun c:at2t (/  data edata ent i sel ss str);All Text to Text
 (defun dxf (tag obj) (cdr (assoc tag obj)))
 (setq ss (ssadd))
 (while (setq sel (entsel "\nChon cac Text can noi voi nhau: "))
(setq ent (car sel))
(if (= (dxf 0 (entget ent)) "TEXT")
(progn
 (ssadd ent ss)
(redraw ent 3)
)
))
 (if (> (sslength ss) 0)
(progn
  (setq i 0    
 data (entget (ssname ss 0))
 str (dxf 1 data))
  (while (setq ent (ssname ss (setq i (1+ i))))
 (setq edata (entget ent)
 str (strcat str " " (dxf 1 edata))  )
 (entdel ent) )
  (entmod (subst (cons 1 str) (assoc 1 data) data))  )
(princ "\nKhong chon duoc Text !"))
 (princ))

Hề hề hề,

É é, bác ketxu ơi, hình như còn phải thêm (redraw ent 4) nữa thì phải?????

@ Bác DoanVanHa: Chắc bác chửa cho nó ăn sáng mà bắt no làm việc ngay nên nó đơ thui mà..... Cho nó một suất 75.000 VNĐ là nó lại chạy veo véo bác ạ....


<<

Filename: 178351_at2t.lsp
Tác giả: dkkx3a
Bài viết gốc: 85120
Tên lệnh: ex1
HỎI VỀ DIALOG
- Thứ 1: pó tay

- Thứ 2: bạn tham khảo Lisp tính toán cộng trừ nhân chia

(defun c:ex1(/ $value dcl_id kqua num1 num2 phepchon ttu)
(defun TinhKqua()
 (if (and num1...
>>
- Thứ 1: pó tay

- Thứ 2: bạn tham khảo Lisp tính toán cộng trừ nhân chia

(defun c:ex1(/ $value dcl_id kqua num1 num2 phepchon ttu)
(defun TinhKqua()
 (if (and num1 num2 ttu )
   (if (and (= (atof num2) 0) (= ttu "/"))
     (progn
(alert "Khong the thuc hien phep chia cho so 0."  )
(mode_tile "sh2" 2)	)
     (progn
(setq kqua (rtos(apply(read ttu) (list (atof num1) (atof num2)))) )
(set_tile "kqua" kqua) )      )
   (cond
     ((not num1) (Ktra_Num num1 "sh1"))
     ((not num2) (Ktra_Num num1 "sh2"))
     ((not ttu)  (Ktra_Ttu ttu "ttu"))   ) ) )

(defun Ktra_Num(val key)
 (if (member (type (distof val)) '(REAL INT) )
   (TinhKqua)
   (progn
     (alert "So hang nhap khong hop le."  )
     (set_tile "kqua" "nil")
     (mode_tile key 2))  ) )

(defun Ktra_Ttu(val key)
 (if (and (= 1 (strlen val))
   (wcmatch val "+,-,`*,/") )
   (TinhKqua)
   (progn
     (alert "Toan tu nhap khong hop le."  )
     (set_tile "kqua" "nil")
     (mode_tile key 2))  ) )  
 (setq dcl_id (load_dialog "Caculator_Ex.dcl")
phepchon 1)
 (or num1 (setq num1 "10.5"))
 (or num2 (setq num2 "8"))
 (or ttu (setq ttu "*"))
 (or kqua (setq kqua "84"))
 (while (/= 0 phepchon)
   (if (not (new_dialog "Ex1" dcl_id))(exit))
   (set_tile "sh1" num1)
   (set_tile "sh2" num2)
   (set_tile "ttu" ttu)
   (set_tile "kqua" kqua)
   (action_tile "sh1" "(setq num1 $value)(Ktra_Num num1 \"sh1\")")
   (action_tile "sh2" "(setq num2 $value)(Ktra_Num num2 \"sh2\")")
   (action_tile "ttu" "(setq ttu $value)(Ktra_Ttu ttu \"ttu\")")
   (action_tile "accept" "(done_dialog 1)")
   (action_tile "cancel" "(done_dialog 0)")
   (setq phepchon (start_dialog))
   (if (= phepchon 1)  (alert (strcat num1 ttu num2 " = " kqua )) )
   );end while
 (start_dialog)
 (unload_dialog DCL_ID)
 (princ)
)

 

file Caculator_Ex.dcl

//Ten file: Caculator_Ex.dcl
//muc dich: su dung ham Action_tile de tinh gia tri cua edit_box
Ex1: dialog {
label = "Vi du Phep toan + - * /";
: edit_box { label = "&So hang 1"; edit_width = 15; key = "sh1"; }
: row {
     : edit_box { label = "&Toan tu (+-*/)"; edit_width = 2; key = "ttu"; }
  : spacer {width = 12;}
  }
: edit_box { label = "&So hang 2"; edit_width = 15; key = "sh2"; }
: edit_box { label = "&Ket Qua"; edit_width = 15; key = "kqua"; }
ok_cancel_err;
}
//Ket thuc file

 

Cảm ơn GiaBach đã trả lời, mình ứng dụng được rồi, nhân đây cho hỏi thêm vấn đề này nữa: Mình đang tạo một cái lisp trong đó có sử dụng các Phép tính + - * /, Mình thấy trong LISP của bạn có hàm tính toán và nó đúng với các số nguyên lớn, nhưng phép tính trên đơn thuần là Phép + hoặc trừ nên dùng hàm Apply, còn trường hợp phép tính có nhiều loại toán tử mình dùng hàm (c:cal str) thì khi có các sô nguyên lớn thì nó báo lỗi,

Ví dụ: (c:cal "99999999999999999*999999999999999999999+2365-52")

Error:

Integer numbers must be between 2147483647 and -2147483648

Vậy làm sao để khi áp dụng các phép tính này không báo lỗi và đôi khi lại cho kết quả không chính xác. Mong GiaBach và mọi người trên diễn đàn giúp đỡ. Thanks


<<

Filename: 85120_ex1.lsp
Tác giả: whatcholingon
Bài viết gốc: 388611
Tên lệnh: themtext bottext
Hỏi cách thêm kí tự bất kỳ vào text
>>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:THEMTEXT (/ c e ss txt cmde ttdangs ttdangt)
  (command "undo" "be")
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq ttdangt (getstring 5"\nChuoi muon them phia truoc:")) 
  (setq ttdangs (getstring 5"\nChuoi muon them phia sau:")) 
  (if (null ttdangt)(setq ttdangt ""))
  (if (null ttdangs)(setq ttdangs ""))
 (prompt "\nChon chu muon chinh.")
  (setq ss (ssget))
  (setq c 0)
  (if ss (setq e (ssname ss c)))
  (while e
    (setq e (entget e))
    ; Ensure entity is text
    (if (= (cdr (assoc 0 e)) "TEXT")
        (progn
                 (setq txt (strcat ttdangt (cdr (assoc 1 e)) ttdangs))
           (setq e (subst (cons 1 txt) (assoc 1 e) e))
           (entmod e)
        )
    )
    (setq c (1+ c)) ; Increment counter.
    (setq e (ssname ss c))  ; Obtain next entity.
   )
   (setvar "CMDECHO" cmde)
   (command "undo" "end")
      (Prin1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:BOTTEXT (/ c e ss txt cmde tbdangs tbdangt)
  (command "undo" "be")
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq tbdangt (getreal "\nSo ky tu muon bot phia truoc:")) 
  (setq tbdangs (getreal "\nSo ky tu muon bot phia sau:")) 
  (if (null tbdangt)(setq tbdangt 0))
  (if (null tbdangs)(setq tbdangs 0))
  (setq sotru (+ tbdangt tbdangs))
 (prompt "\nChon chu muon chinh.")
  (setq ss (ssget))
  (setq c 0)
  (if ss (setq e (ssname ss c)))
  (while e
    (setq e (entget e))
    ; Ensure entity is text
    (if (= (cdr (assoc 0 e)) "TEXT")
        (progn
(setq sochu (strlen (cdr (assoc 1 e))))
(if (> sochu sotru)
(progn
(setq txt (substr (cdr (assoc 1 e)) (fix (+ 1 tbdangt)) (fix (- sochu tbdangt tbdangs))))
           (setq e (subst (cons 1 txt) (assoc 1 e) e))
           (entmod e)
)
)

        )
    )
    (setq c (1+ c)) ; Increment counter.
    (setq e (ssname ss c))  ; Obtain next entity.
   )
   (setvar "CMDECHO" cmde)
   (command "undo" "end")
      (Prin1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Mr. Duy và mọi người giúp mình với 

mình load lisp lên báo lỗi như này:

Command:

Command: ap

APPLOAD themtextvabottex.lsp successfully loaded.

Command: ; error: syntax error

Thanks all.

Lệnh là  THEMTEXT và  BOTTEXT

 

 
 
Mr. Duy và mọi người giúp mình với 
mình load li sp lên báo lỗi như này:
Command:
Command: ap
APPLOAD themtextvabottex.lsp successfully loaded.
Command: ; error: syntax error
Thanks all.

<<

Filename: 388611_themtext_bottext.lsp
Tác giả: Lisp123
Bài viết gốc: 76066
Tên lệnh: eob
lisp xóa tất cả các đối tượng trong 1 vùng kín
Chào namhai

Với các đối tượng nằm trong và ngoài curve : Lisp làm việc bình thuờng.

Với đối tượng có giao với curve trên mặt bằng nhưng nếu trong không...

>>
Chào namhai

Với các đối tượng nằm trong và ngoài curve : Lisp làm việc bình thuờng.

Với đối tượng có giao với curve trên mặt bằng nhưng nếu trong không gian chúng không giao nhau (không đồng phẳng) thì Lisp không xử lý đuợc.

Bạn có thể dùng Lisp này để xóa tất cả đối tượng nằm ngoài curve. (không phân biệt có giao trên mặt bằng hay giao trong không gian)

(defun C:EOB (  / en ss lst ssall bbox) ;EOB -> Erasre Out Boudary
(vl-load-com)
 (if (and (setq en (car(entsel "\n Chon duong bao : ")))
          (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE"))
   (progn
     (setq bbox (ACET-ENT-GEOMEXTENTS en))
     (setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
     (setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-3))
     (ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list en)))
     (command "_.Zoom" "0.95x")
     (if (null etrim)(load "extrim.lsp"))
     (etrim en (polar
                 (car bbox)
                 (angle (car bbox)(cadr bbox))
                 (* (distance (car bbox)(cadr bbox)) 1.1)))
     (if (and
           (setq ss (ssget "_CP" lst))
           (setq ssall (ssget "_X" (list (assoc 410 (entget en)))))
          )
       (progn
         (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
         (foreach e1 lst (ssdel e1 ssall))
         (ACET-SS-ENTDEL ssall)
         )
       )
     )
   )
 )

Ơ em tưởng cái líp này dùng lệnh extrim thì nó phải extrim được cả Hatch chứ nhỉ? Sao em dùng với hatch mà không được???


<<

Filename: 76066_eob.lsp
Tác giả: thanhduan2407
Bài viết gốc: 320693
Tên lệnh: copy2
Sử dụng ClipBoard trong LISP : Copy và Paste dữ liệu kiểu Text

1./ Có lẽ anh gia_bach đã nhầm. Đoạn video đó load file *.vlx

2./ Thanhduan thử đoạn code sau...

>>

1./ Có lẽ anh gia_bach đã nhầm. Đoạn video đó load file *.vlx

2./ Thanhduan thử đoạn code sau :

 

(defun SetClipBoardText (text / htmlfile result ) ; By XShrimp
  (if (= 'STR (type text))
    (progn
      (setq htmlfile (vlax-create-object "htmlfile")
        result (vlax-invoke (vlax-get (vlax-get htmlfile 'ParentWindow ) 'ClipBoardData) 'SetData "Text" text )
      )
      (vlax-release-object htmlfile)
      text
    )
    )
  )
(defun c:copy2 (/ ss i ename entg str)
  (setq i -1 str "")
  (if (setq ss (ssget '((0 . "TEXT"))))
    (while (setq ename (ssname ss (setq i (1+ i))))
      (setq entg (entget ename))
      (setq str (strcat str "X = " (rtos (cadr (assoc 10 entg))) "\t"
                "Y = " (rtos (caddr (assoc 10 entg))) "\t"


            "Z = " (rtos (caddr (assoc 10 entg))) "\t"
                (cdr(assoc 1 (entget ename))) "\n"
        ))
    )
  )
  (SetClipBoardText str)
)

Cách sử dụng :

Dùng lệnh Copy2 -> Chọn Text -> Mở Excel -> Nhấn Ctrol+V

Ok. Vậy là em hiểu rồi ạ.

Cảm ơn anh Tue_NV nhiều


<<

Filename: 320693_copy2.lsp

Trang 253/304

253