Jump to content
InfoFile
Tác giả: ketxu
Bài viết gốc: 253930
Tên lệnh: cmg
Scale hình vẽ thì block att, text, dim, hatch không đổi

Quick code. Khái niệm Text, Mtext ở nguyên chính giữa của bạn hơi mơ hồ, vì cái này còn phụ thuộc Base Point trong lệnh scale nữa. Tạm đoán như này :

 

(defun c:CMG(/ lstHatch lstScale handent-next _fake _center ps p s adoc ss)
;Free from Member of CadmagicGroup
; Scale / unchange Text, Mtext, Block scale, Dim value
(vl-load-com)
(grtext -1 "Free from Member of CadmagicGroup")
;;;;;;;;;;;;;;   PRIVATE FUNCTION...
>>

Quick code. Khái niệm Text, Mtext ở nguyên chính giữa của bạn hơi mơ hồ, vì cái này còn phụ thuộc Base Point trong lệnh scale nữa. Tạm đoán như này :

 

(defun c:CMG(/ lstHatch lstScale handent-next _fake _center ps p s adoc ss)
;Free from Member of CadmagicGroup
; Scale / unchange Text, Mtext, Block scale, Dim value
(vl-load-com)
(grtext -1 "Free from Member of CadmagicGroup")
;;;;;;;;;;;;;;   PRIVATE FUNCTION ;;;;;;;;;;
(defun handent-next (hex / lt id str)
 (setq str (vl-string-right-trim "F" hex) id (strlen str))
 (setq lt '(("0" . "1") ("1" . "2") ("2" . "3") ("3" . "4")
            ("4" . "5") ("5" . "6") ("6" . "7") ("7" . "8")
            ("8" . "9") ("9" . "A") ("A" . "B") ("B" . "C")
            ("C" . "D") ("D" . "E") ("E" . "F")))
 (cond ((= str "") (substr "1000000" 1 (1+ (strlen hex))))
       ((= str hex) (strcat (substr str 1 (1- id)) (cdr (assoc (substr str id) lt))))
       (t (strcat (substr str 1 (1- id)) (cdr (assoc (substr str id) lt)) (substr "000000" 1 (- (strlen hex) id))))))

;Fake dim value @THUYLINH	   
(defun _fake(obj / etg) 
	(if (wcmatch (vla-get-textoverride obj) "*<>*,")
		(progn
			(setq h (handent-next (vla-get-handle obj)))
			(while
				(if
				  (and
					   (setq h (handent-next h))
					   (setq etg (handent h))
					   (setq etg (entget etg))
					   (wcmatch (cdr (assoc 0 etg)) "*TEXT")
					   (equal (vlax-get obj 'textposition) (cdr (assoc 10 etg)) 0.0000000001)
					)
					(vla-put-textoverride obj (cdr (assoc 1 etg)))
					t
				)
			)
		)
	)
)
	   
(defun _center (x / p1 p2) 
			(vla-getboundingbox x 'p1 'p2)
			(mapcar  '(lambda (a b) (* 0.5 (+ a b)))
			(vlax-safearray->list p1) (vlax-safearray->list p2))
)

	
(if (setq ps (ssget))
  (progn
		(setq adoc (vla-get-activedocument (vlax-get-acad-object))
			  ss (vla-get-activeselectionset adoc)
		)
		(vlax-for obj ss
			(setq objName (vla-get-objectname obj))			
			(cond
				;Hatch - catch scale :
				((= objName "AcDbHatch")(setq lstHatch (append lstHatch (list (cons obj (vla-get-PatternScale obj))))))
				;Dimfake
				((wcmatch objName "AcDb*Dimension")(_fake obj))
				;Text, Mtext, Block
				((member objName '("AcDbText" "AcDbMText" "AcDbBlockReference"))(setq lstScale (cons obj lstScale)))
			)
		)
		(while 
			(not
				(and
					(setq p (getpoint "\nSpecify base point :"))
					(> (setq s (getdist p "\nSpecify scale factor :")) 0)
				)
			)
		)
					
		(vl-cmdf "_.scale" ps "" p s)
		;Reset Hatch' Scale
		(mapcar '(lambda(x)(vla-put-PatternScale (car x) (cdr x))) lstHatch)
		;Re-Scale Text, Mtext, Block :
		(mapcar '(lambda(x)(vla-ScaleEntity x (vlax-3d-point (_center x)) (/ 1.0 s))) lstScale)
	)
)
(princ)
)

<<

Filename: 253930_cmg.lsp
Tác giả: ketxu
Bài viết gốc: 253968
Tên lệnh: cmg
Scale hình vẽ thì block att, text, dim, hatch không đổi

Mà thôi, tiện sửa bo, về lý thì như thế này sẽ chạy được, bạn còn thức thì test hộ mình. K biết có lỗi cú pháp không

 

(defun c:CMG(/ lstHatch lstBlkScale lstTScale handent-next _fake _center ps p s adoc ss)
;Free from Member of CadmagicGroup
; Scale / unchange Text, Mtext, Block scale, Dim value
(vl-load-com)
(grtext -1 "Free from Member of CadmagicGroup")
;;;;;;;;;;;;;;   PRIVATE FUNCTION...
>>

Mà thôi, tiện sửa bo, về lý thì như thế này sẽ chạy được, bạn còn thức thì test hộ mình. K biết có lỗi cú pháp không

 

(defun c:CMG(/ lstHatch lstBlkScale lstTScale handent-next _fake _center ps p s adoc ss)
;Free from Member of CadmagicGroup
; Scale / unchange Text, Mtext, Block scale, Dim value
(vl-load-com)
(grtext -1 "Free from Member of CadmagicGroup")
;;;;;;;;;;;;;;   PRIVATE FUNCTION ;;;;;;;;;;
(defun handent-next (hex / lt id str)
 (setq str (vl-string-right-trim "F" hex) id (strlen str))
 (setq lt '(("0" . "1") ("1" . "2") ("2" . "3") ("3" . "4")
            ("4" . "5") ("5" . "6") ("6" . "7") ("7" . "8")
            ("8" . "9") ("9" . "A") ("A" . "B") ("B" . "C")
            ("C" . "D") ("D" . "E") ("E" . "F")))
 (cond ((= str "") (substr "1000000" 1 (1+ (strlen hex))))
       ((= str hex) (strcat (substr str 1 (1- id)) (cdr (assoc (substr str id) lt))))
       (t (strcat (substr str 1 (1- id)) (cdr (assoc (substr str id) lt)) (substr "000000" 1 (- (strlen hex) id))))))

;Fake dim value @THUYLINH	   
(defun _fake(obj / etg) 
	(if (wcmatch (vla-get-textoverride obj) "*<>*,")
		(progn
			(setq h (handent-next (vla-get-handle obj)))
			(while
				(if
				  (and
					   (setq h (handent-next h))
					   (setq etg (handent h))
					   (setq etg (entget etg))
					   (wcmatch (cdr (assoc 0 etg)) "*TEXT")
					   (equal (vlax-get obj 'textposition) (cdr (assoc 10 etg)) 0.0000000001)
					)
					(vla-put-textoverride obj (cdr (assoc 1 etg)))
					t
				)
			)
		)
	)
)
	   
(defun _center (x / p1 p2) 
			(vla-getboundingbox x 'p1 'p2)
			(mapcar  '(lambda (a b) (* 0.5 (+ a b)))
			(vlax-safearray->list p1) (vlax-safearray->list p2))
)

	
(if (setq ps (ssget))
  (progn
		(setq adoc (vla-get-activedocument (vlax-get-acad-object))
			  ss (vla-get-activeselectionset adoc)
		)
		(vlax-for obj ss
			(setq objName (vla-get-objectname obj))			
			(cond
				;Hatch - catch scale :
				((= objName "AcDbHatch")(setq lstHatch (append lstHatch (list (cons obj (vla-get-PatternScale obj))))))
				;Dimfake
				((wcmatch objName "AcDb*Dimension")(_fake obj))
				;Block Att
				((and (= objName "AcDbBlockReference") (= (vla-get-HasAttributes obj) :vlax-true)) (setq lstBlkScale (cons obj lstBlkScale)))
				;Text, Mtext
				((member objName '("AcDbText" "AcDbMText" ))(setq lstTScale (cons obj lstTScale)))
			)
		)
		(while 
			(not
				(and
					(setq p (getpoint "\nSpecify base point :"))
					(> (setq s (getdist p "\nSpecify scale factor :")) 0)
				)
			)
		)
					
		(vl-cmdf "_.scale" ps "" p s)
		;Reset Hatch' Scale
		(mapcar '(lambda(x)(vla-put-PatternScale (car x) (cdr x))) lstHatch)
		;Re-Scale AttBlock :
		(mapcar '(lambda(x)(vla-ScaleEntity x (vlax-3d-point (_center x)) (/ 1.0 s))) lstBlkScale)
		;Re-Scale *Text
		(mapcar '(lambda(x)(vla-ScaleEntity x (vlax-3d-point (vlax-get x 'InsertionPoint)) (/ 1.0 s))) lstTScale)
	)
)
(princ)
)

<<

Filename: 253968_cmg.lsp
Tác giả: ndtnv
Bài viết gốc: 254011
Tên lệnh: on off
Xin lisp bật tắt lệnh tắt của cad

Các bạn cho hỏi có lisp nào dùng để on/off chế độ sử dụng phím tắt trong cad không. Vì công ty mình không cho phép chỉnh phím tắt trong cad. nên nếu sếp kiểm tra mình sẽ dùng lisp để on/off cho nhanh.tks các bạn

- Tạo 2 file acad.pgp gốc và đã chỉnh sửa
- Sửa lại path cho...

>>

Các bạn cho hỏi có lisp nào dùng để on/off chế độ sử dụng phím tắt trong cad không. Vì công ty mình không cho phép chỉnh phím tắt trong cad. nên nếu sếp kiểm tra mình sẽ dùng lisp để on/off cho nhanh.tks các bạn

- Tạo 2 file acad.pgp gốc và đã chỉnh sửa
- Sửa lại path cho phù hợp

(defun c:on ( / ) (pgp "D:/CAD/myacad.pgp"))
(defun c:off ( / ) (pgp "D:/CAD/orgacad.pgp"))
(defun pgp (f / )    (vl-file-copy f  "D:/CAD/acad.pgp")    
(vl-cmdf "RE-INIT" 16 )) 

<<

Filename: 254011_on_off.lsp
Tác giả: ketxu
Bài viết gốc: 254161
Tên lệnh: cmg
Scale hình vẽ thì block att, text, dim, hatch không đổi

Block thì chắc ý bạn vầy :

(defun c:CMG(/ lstHatch lstBlkScale lstTScale handent-next _fake _center ps p s adoc ss)
;Free from Member of CadmagicGroup
; Scale / unchange Text, Mtext, Block scale, Dim value
(vl-load-com)
(grtext -1 "Free from Member of CadmagicGroup")
;;;;;;;;;;;;;;   PRIVATE FUNCTION ;;;;;;;;;;
(defun handent-next (hex / lt id str)
 (setq str (vl-string-right-trim "F" hex) id (strlen str))
 (setq lt '(("0" . "1") ("1" . "2")...
>>

Block thì chắc ý bạn vầy :

(defun c:CMG(/ lstHatch lstBlkScale lstTScale handent-next _fake _center ps p s adoc ss)
;Free from Member of CadmagicGroup
; Scale / unchange Text, Mtext, Block scale, Dim value
(vl-load-com)
(grtext -1 "Free from Member of CadmagicGroup")
;;;;;;;;;;;;;;   PRIVATE FUNCTION ;;;;;;;;;;
(defun handent-next (hex / lt id str)
 (setq str (vl-string-right-trim "F" hex) id (strlen str))
 (setq lt '(("0" . "1") ("1" . "2") ("2" . "3") ("3" . "4")
            ("4" . "5") ("5" . "6") ("6" . "7") ("7" . "8")
            ("8" . "9") ("9" . "A") ("A" . "B") ("B" . "C")
            ("C" . "D") ("D" . "E") ("E" . "F")))
 (cond ((= str "") (substr "1000000" 1 (1+ (strlen hex))))
       ((= str hex) (strcat (substr str 1 (1- id)) (cdr (assoc (substr str id) lt))))
       (t (strcat (substr str 1 (1- id)) (cdr (assoc (substr str id) lt)) (substr "000000" 1 (- (strlen hex) id))))))

;Fake dim value @THUYLINH	   
(defun _fake(obj / etg) 
	(if (wcmatch (vla-get-textoverride obj) "*<>*,")
		(progn
			(setq h (handent-next (vla-get-handle obj)))
			(while
				(if
				  (and
					   (setq h (handent-next h))
					   (setq etg (handent h))
					   (setq etg (entget etg))
					   (wcmatch (cdr (assoc 0 etg)) "*TEXT")
					   (equal (vlax-get obj 'textposition) (cdr (assoc 10 etg)) 0.0000000001)
					)
					(vla-put-textoverride obj (cdr (assoc 1 etg)))
					t
				)
			)
		)
	)
)
	   
(defun _center (x / p1 p2) 
			(vla-getboundingbox x 'p1 'p2)
			(mapcar  '(lambda (a b) (* 0.5 (+ a b)))
			(vlax-safearray->list p1) (vlax-safearray->list p2))
)

	
(if (setq ps (ssget))
  (progn
		(setq adoc (vla-get-activedocument (vlax-get-acad-object))
			  ss (vla-get-activeselectionset adoc)
		)
		(vlax-for obj ss
			(setq objName (vla-get-objectname obj))			
			(cond
				;Hatch - catch scale :
				((= objName "AcDbHatch")(setq lstHatch (append lstHatch (list (cons obj (vla-get-PatternScale obj))))))
				;Dimfake
				((wcmatch objName "AcDb*Dimension")(_fake obj))				
				
				;Text, Mtext, Block ATT
				((or (member objName '("AcDbText" "AcDbMText" ))(and (= objName "AcDbBlockReference") (= (vla-get-HasAttributes obj) :vlax-true)))
					(setq lstTScale (cons obj lstTScale)))
			)
		)
		(while 
			(not
				(and
					(setq p (getpoint "\nSpecify base point :"))
					(> (setq s (getdist p "\nSpecify scale factor :")) 0)
				)
			)
		)
					
		(vl-cmdf "_.scale" ps "" p s)
		;Reset Hatch' Scale
		(mapcar '(lambda(x)(vla-put-PatternScale (car x) (cdr x))) lstHatch)
		;Re-Scale AttBlock :
		;(mapcar '(lambda(x)(vla-ScaleEntity x (vlax-3d-point (_center x)) (/ 1.0 s))) lstBlkScale)
		;Re-Scale *Text
		(mapcar '(lambda(x)(vla-ScaleEntity x (vlax-3d-point (vlax-get x 'InsertionPoint)) (/ 1.0 s))) lstTScale)
	)
)
(princ)
)

- Còn dim thì mình thua :) Thua là vì cách bạn truyền đạt ý tới mình. 

+ Bản chất của đối tượng Dim là không thay đổi chiều cao chữ khi scale, trừ khi bị đóng Block. Nếu bạn muốn nó vừa là dim thật, vừa k thay đổi chiều cao chữ trong lúc scale, thì chính là bình thường nó đã thế, k cần lisp can thiệp

 

+ Trong bài 1, bạn tô đậm chữ TEXT không đổi, đồng thời hình minh họa 1 của bạn, cả trước và sau nó đều là 5000, chiều cao chữ không đổi  => đương nhiên phải là dim fake, không thì lúc scale lên 2 nó phải là 10000 chứ => Mình đã phải copy đoạn xử lý fake dim rất dài cho vào code. Giờ bạn lại không ưng ý khi nó là dim fake => -_- . Nếu muốn nó không fake nữa thì code chỉ còn thế này thôi :

 

 

(defun c:CMG(/ lstHatch  lstTScale ps p s adoc ss)
;Free from Member of CadmagicGroup
; Scale / unchange Text, Mtext, Block scale, Dim value
(vl-load-com)
(grtext -1 "Free from Member of CadmagicGroup")
	
(if (setq ps (ssget))
  (progn
		(setq adoc (vla-get-activedocument (vlax-get-acad-object))
			  ss (vla-get-activeselectionset adoc)
		)
		(vlax-for obj ss
			(setq objName (vla-get-objectname obj))			
			(cond
				;Hatch - catch scale :
				((= objName "AcDbHatch")(setq lstHatch (append lstHatch (list (cons obj (vla-get-PatternScale obj))))))							
				
				;Text, Mtext, Block ATT
				((or (member objName '("AcDbText" "AcDbMText" ))(and (= objName "AcDbBlockReference") (= (vla-get-HasAttributes obj) :vlax-true)))
					(setq lstTScale (cons obj lstTScale)))
			)
		)
		(while 
			(not
				(and
					(setq p (getpoint "\nSpecify base point :"))
					(> (setq s (getdist p "\nSpecify scale factor :")) 0)
				)
			)
		)
					
		(vl-cmdf "_.scale" ps "" p s)
		;Reset Hatch' Scale
		(mapcar '(lambda(x)(vla-put-PatternScale (car x) (cdr x))) lstHatch)		
		;Re-Scale *Text
		(mapcar '(lambda(x)(vla-ScaleEntity x (vlax-3d-point (vlax-get x 'InsertionPoint)) (/ 1.0 s))) lstTScale)
	)
)
(princ)
)

Thật là ....


<<

Filename: 254161_cmg.lsp
Tác giả: ketxu
Bài viết gốc: 254243
Tên lệnh: cmg
Scale hình vẽ thì block att, text, dim, hatch không đổi

Giờ mới đẻ ra cái này :) - Không thấy đề cập ở các bài trước. Đáng ra mình chỉ cần 1 file Cad của bạn để xem vấn đề, và cũng chỉ 15p là xong cái code, nhưng tí lại thêm 1 cái ảnh :) , cuối cùng đều phải chờ nhau đến 2 ngày. Qua quá trình mô tả thì thấy bạn đang vẽ theo cách vẽ model và muốn mọi thứ thay đổi tự động khi scale . Thay đối Dimlfac đương nhiên mình làm được, nhưng...

>>

Giờ mới đẻ ra cái này :) - Không thấy đề cập ở các bài trước. Đáng ra mình chỉ cần 1 file Cad của bạn để xem vấn đề, và cũng chỉ 15p là xong cái code, nhưng tí lại thêm 1 cái ảnh :) , cuối cùng đều phải chờ nhau đến 2 ngày. Qua quá trình mô tả thì thấy bạn đang vẽ theo cách vẽ model và muốn mọi thứ thay đổi tự động khi scale . Thay đối Dimlfac đương nhiên mình làm được, nhưng khuyên bạn thật - chẳng ai lại làm thế cả - vì đấy là một cách vẽ khiến cho bạn không quản lý được cái bạn có trong tay. Nếu đã vẽ Model hãy tạo kiểu dim tương ứng với tỉ lệ định vẽ. Hãy tưởng tượng các dim rời rạc, cùng thuộc 1 Dimstyle nhưng qua quá trình chạy lisp thì Scale factor lại khác nhau => quá trình quản lý + sửa của bạn sẽ vất vả

 

Code thì đây, nếu bạn bảo vệ quan điểm

 

(defun c:CMG(/ lstHatch  lstTScale  ps p s adoc ss)
;Free from Member of CadmagicGroup
; Scale / unchange Text, Mtext, Block scale, Dim value
(vl-load-com)
(grtext -1 "Free from Member of CadmagicGroup")
	
(if (setq ps (ssget))
  (progn
		(setq adoc (vla-get-activedocument (vlax-get-acad-object))
			  ss (vla-get-activeselectionset adoc)
		)
		(vlax-for obj ss
			(setq objName (vla-get-objectname obj))			
			(cond
				;Hatch - catch scale :
				((= objName "AcDbHatch")(setq lstHatch (append lstHatch (list (cons obj (vla-get-PatternScale obj))))))
				;Dim
				((wcmatch objName "AcDb*Dimension")(setq lstDim (append lstDim (list (cons obj (vla-get-LinearScaleFactor obj))))))	
				;Text, Mtext, Block ATT
				((or (member objName '("AcDbText" "AcDbMText" ))(and (= objName "AcDbBlockReference") (= (vla-get-HasAttributes obj) :vlax-true)))
					(setq lstTScale (cons obj lstTScale)))
			)
		)
		(while 
			(not
				(and
					(setq p (getpoint "\nSpecify base point :"))
					(> (setq s (getdist p "\nSpecify scale factor :")) 0)
				)
			)
		)
					
		(vl-cmdf "_.scale" ps "" p s)
		;Reset Hatch' Scale
		(mapcar '(lambda(x)(vla-put-PatternScale (car x) (cdr x))) lstHatch)		
		;Re-Scale *Text
		(mapcar '(lambda(x)(vla-ScaleEntity x (vlax-3d-point (vlax-get x 'InsertionPoint)) (/ 1.0 s))) lstTScale)
		;Re-Dimlfac Dimension
		(mapcar '(lambda(x)(vla-put-LinearScaleFactor (car x) (/ (cdr x) s))) lstDim)
	)
)
(princ)
)

 

P/s : mình chưa down lisp nào bạn đưa lên, cũng không bắt chước làm giống ai đâu, tại nhìn hình to thế kia tưởng mình thông minh hiểu được ý bạn, nên biếng down. Bạn bảo làm theo nghe buồn. Chừ giờ cop của ai cũng ghi @ hết, k sau mình k hiểu k tìm được tác giả mà hỏi ^^ 

 

Lần này đoán ý mãi vẫn trật  :o Mình rút lui thôi, hehe ^^

 

Chúc bạn thành công -  


<<

Filename: 254243_cmg.lsp
Tác giả: gia_bach
Bài viết gốc: 32224
Tên lệnh: ex vla
Cách xác định kích thước thật của dimension ?


Đối với AutoCAD phiên bản trước 2004, trước khi sử dụng các hàm vlax- cần phải khởi động ActiveX bằng dòng lệnh (vl-load-com) , tuy nhiên CAD 2004 do ActiveX được mặc định nạp khi khởi động AutoCad nên dòng lệnh (vl-load-com) là không cần thiết nhưng cứ thêm vào cho chắc (dư thì không sao, nếu thiếu thì Cad báo lỗi).


Hàm vlax-get-property hay đơn giản hơn là vlax-get để...
>>


Đối với AutoCAD phiên bản trước 2004, trước khi sử dụng các hàm vlax- cần phải khởi động ActiveX bằng dòng lệnh (vl-load-com) , tuy nhiên CAD 2004 do ActiveX được mặc định nạp khi khởi động AutoCad nên dòng lệnh (vl-load-com) là không cần thiết nhưng cứ thêm vào cho chắc (dư thì không sao, nếu thiếu thì Cad báo lỗi).


Hàm vlax-get-property hay đơn giản hơn là vlax-get để truy xuất CSDL của đối tượng(VLA-object), tương tự như cách chúng ta truy xuất qua các code DXF với Lisp.

Kết quả của lệnh HaveaDump với đốii tượng là TEXT :
Command: HaveaDump
Select object:
; IAcadText: AutoCAD Text Interface
; Property values:
; Alignment = 0
; Application (RO) = #<VLA-OBJECT IAcadApplication 00b5e51c>
; Backward = 0
; Document (RO) = #<VLA-OBJECT IAcadDocument 01268360>
; Handle (RO) = "9B"
; HasExtensionDictionary (RO) = 0
; Height = 175
; Hyperlinks (RO) = #<VLA-OBJECT IAcadHyperlinks 06461014>
; InsertionPoint = (5.96983 16.4748 0.0)
; Layer = "D-STR"
; Linetype = "ByLayer"
; LinetypeScale = 1.0
; Lineweight = -1
; Normal = (0.0 0.0 1.0)
; ObjectID (RO) = 2130005784
; ObjectName (RO) = "AcDbText"
; ObliqueAngle = 0.0
; OwnerID (RO) = 2130005240
; PlotStyleName = "ByLayer"
; Rotation = 0.0
; ScaleFactor = 1.0
; StyleName = "Standard"
; TextAlignmentPoint = (0.0 0.0 0.0)
; TextGenerationFlag = 0
; TextString = "CadViet.com"
; Thickness = 0.0
; TrueColor = #<VLA-OBJECT IAcadAcCmColor 06462a30>
; UpsideDown = 0
; Visible = -1

các dòng màu đỏ cho ta biết :
Height : chiều cao = 175
Layer : lớp = D-STR
TextString : nội dung = CadViet.com

để truy xuất các giá trị này, ta chỉ việc thêm chúng vào sau hàm vlax-get- :
(setq chcao (vla-get-Height eObj) ) ; chiều cao text
(setq lop (vla-get-Layer eObj) ) ; lớp
(setq str (vla-get-TextString eObj) ); noi dung

Ví dụ truy xuất đối tượng TETX


Hy vọng vài dòng trên giúp bạn cách truy xuất CSDL qua ActiveX.
<<

Filename: 32224_ex_vla.lsp
Tác giả: ketxu
Bài viết gốc: 135210
Tên lệnh: e2cc
anh em trợ giúp vấn đề này nhe
Không hẳn là phá sản đâu. Nếu bạn chịu khó ngồi sửa lại điểm InsertPoint của Block trùng vào đúng tâm point đó, mình có thể giúp bạn luôn phần chèn Block vào chỗ đó và lấy tên luôn ^^ Có lẽ, nếu bạn nghĩ như thế là hay hơn thì hãy tạo Block đi, rồi mai mình giúp bạn, vì giờ mình chuẩn bị vào ổ r ^^ .CÒn đây là lời hứa đoạn code vừa nãy.Sau khi chạy E2c để có tên và point, bạn chạy...
>>
Không hẳn là phá sản đâu. Nếu bạn chịu khó ngồi sửa lại điểm InsertPoint của Block trùng vào đúng tâm point đó, mình có thể giúp bạn luôn phần chèn Block vào chỗ đó và lấy tên luôn ^^ Có lẽ, nếu bạn nghĩ như thế là hay hơn thì hãy tạo Block đi, rồi mai mình giúp bạn, vì giờ mình chuẩn bị vào ổ r ^^ .CÒn đây là lời hứa đoạn code vừa nãy.Sau khi chạy E2c để có tên và point, bạn chạy thằng này, quét qua 1 block và 1 text để cập nhật.
Trong code có sử dụng Function bác Hoành và bác Tuệ giới thiệu

<<

Filename: 135210_e2cc.lsp
Tác giả: ndtnv
Bài viết gốc: 254462
Tên lệnh: ii
Lisp thêm đỉnh pline tại giao điểm của pline và các line khác

Mình đã tìm mấy ngày trên diễn đàn cái lisp có chức năng như thế này mà chưa có. Bác nào lỡ ghé qua đọc rồi nếu có thì cho e xin với. Nếu không có thì cũng cái đá đít để e lên top đầu ạ. thank all

 

Chức năng lisp cần tìm.

Có 1 pline A giao với nhiều đường line và pline khác.==> kết...

>>

Mình đã tìm mấy ngày trên diễn đàn cái lisp có chức năng như thế này mà chưa có. Bác nào lỡ ghé qua đọc rồi nếu có thì cho e xin với. Nếu không có thì cũng cái đá đít để e lên top đầu ạ. thank all

 

Chức năng lisp cần tìm.

Có 1 pline A giao với nhiều đường line và pline khác.==> kết quả sau khi chạy lisp là thêm đỉnh cho pline A tại các giao điểm trên

Dùng command của cad thì không hay lắm, nhưng đọc các code khác dài quá nên thôi.

Tôi chỉ viết phần chính. Bạn tự thêm vào bẫy lỗi hoặc xử lý các điểm gần trùng nhau, trùng với đỉnh của pline

 

(defun AppendLs (ls e)(append (if ls ls nil) (list e)))
(defun ObjInters (o1 o2 id / g ps n)
    (setq    g    (vlax-invoke o1 'IntersectWith o2 id)    ps '())
    (while g (setq    ps (AppendLs ps (list (car g) (cadr g) (caddr g))) g (cdddr g))    )    ps
)

(defun C:II ( / sp ls lp lq li o s p m n ob om ss x) ; insert at intersections
    (setq om (getvar "OSMODE")) (setvar "OSMODE" 0)
    (princ "Chon pline:")    (setq ss (ssget ":S") ob (vlax-ename->vla-object (ssname ss 0)) )
    (princ "Chon cac duong giao:")
    (setq ls (mapcar 'vlax-ename->vla-object
                                     (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*LINE"))))))))
    (foreach o ls
        (setq lp (append lp (ObjInters ob o acExtendNone)))    )
    (setq lq (mapcar '(lambda (x) (vlax-curve-getParamAtPoint ob (vlax-curve-getClosestPointTo ob x))) lp))
    (setq n 0 li (vl-sort-i lq '<))
    (foreach p li
        (setq m (fix (nth p lq)))
        (repeat (- m n)
            (setq s (strcat s " \"N\""))    )
        (setq s (strcat s " \"I\" (nth " (itoa p) " lp)") n m)
    )
    (eval (read (strcat "(vl-cmdf \"PEDIT\" ss \"E\"" s "\"X\" \"\")")) )
    (setvar "OSMODE" om)
)

<<

Filename: 254462_ii.lsp
Tác giả: Tue_NV
Bài viết gốc: 254953
Tên lệnh: dcc
Hỏi về lệnh DCO

không biết các phiên bản cad mới 2012, 2013 ... lệnh DCO có thể đánh được giá trị kích thước chưa nhỉ?

CAD 2014 chưa có 

Bạn sử dụng code này :

(defun c:dcc(/ e kthuoc dxf10 dxf14 ang)
  ;write by Tue_NV
(if (setq e (car(entsel "\n Pick chon Dim : ")))
(while (setq kthuoc...
>>

không biết các phiên bản cad mới 2012, 2013 ... lệnh DCO có thể đánh được giá trị kích thước chưa nhỉ?

CAD 2014 chưa có 

Bạn sử dụng code này :

(defun c:dcc(/ e kthuoc dxf10 dxf14 ang)
  ;write by Tue_NV
(if (setq e (car(entsel "\n Pick chon Dim : ")))
(while (setq kthuoc (getreal "\n Nhap kich thuoc :"))
  (setq dxf10 (cdr(assoc 10 (entget e))))
  (setq dxf14 (cdr(assoc 14 (entget e))))
  (setq ang (angle dxf14 dxf10))
    (vl-cmdf "DIMCONTINUE" e "_non" (polar dxf14 (+ ang (/ pi 2.0)) kthuoc) "" "")
  (setq e (entlast))
)
 )
  (princ)
)

<<

Filename: 254953_dcc.lsp
Tác giả: hochoaivandot
Bài viết gốc: 254986
Tên lệnh: ttt
Nhờ viết Lisp xác định lý trình và khoảng cách tới tim
Viết nhanh cho bạn
(defun C:ttt(/ e obj pt pt1 dis lt)
(vl-load-com)
(setq e (car (entsel "Chon PL")))
(setq obj (vlax-ename->vla-object e))
(setq pt (getpoint "Pick diem"))
(setq pt1 (vlax-curve-getClosestPointTo obj pt))
(setq dis (distance pt pt1))
(setq lt (vlax-curve-getDistAtPoint obj pt1))
(alert (strcat "Ly trinh = " (rtos lt 2 2) "\nKhoach cach den tim = " (rtos dis 2 2)))
)

Filename: 254986_ttt.lsp
Tác giả: hochoaivandot
Bài viết gốc: 255059
Tên lệnh: ttt
Nhờ viết Lisp xác định lý trình và khoảng cách tới tim

thai11000, on 27 Sept 2013 - 15:54, said:
Bac hochoaivandot giải quyết được vấn đề cơ bản rồi. Nhưng bác có thể giúp thêm em là ghi cái khoảng cách và lý trình đó ra bản vẽ được không ạ!
Em hay làm thoát nước cũng cần cái này.
Với cả dòng lệnh của bác có thể chỉ chọn PLine 1 lần...

>>

thai11000, on 27 Sept 2013 - 15:54, said:
Bac hochoaivandot giải quyết được vấn đề cơ bản rồi. Nhưng bác có thể giúp thêm em là ghi cái khoảng cách và lý trình đó ra bản vẽ được không ạ!
Em hay làm thoát nước cũng cần cái này.
Với cả dòng lệnh của bác có thể chỉ chọn PLine 1 lần rồi pick nhiều điểm không ?
Ví dụ như hình của emhttp://www.cadviet.com/upfiles/3/70461_vd.dwg
Mong bac giúp đỡ!

Phải như thế này không thai1000
(defun MakeLeader (pt pt1 lmt)
(entmake
(list
(cons 0 "LEADER")
; (cons 8 layer)
; (cons 3 sty)
(cons 100 "AcDbEntity")
(cons 100 "AcDbLeader")
(cons 71 1)
(cons 72 0)
(cons 73 3)
(cons 74 0)
(cons 75 0)
(cons 10 pt)
(cons 10 pt1)
; (cons 10 (getpoint pt1 "\nSpecify Next Point"))
(list -3
(list "ACAD"
(cons 1000 "DSTYLE")
(cons 1002 "{")
(cons 1070 41)
(cons 1040 lmt)
(cons 1002 "}")
)
)
)
)
)
(defun MakeText (point string Height Wid 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 41 Wid)
(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
(defun GetAngleVuong (obj pt)
(+ (angle pt (polar pt (angle '(0 0 0) (vlax-curve-getFirstDeriv obj (vlax-curve-getParamAtPoint obj pt))) 2)) (* pi 0.5))
)
(defun C:ttt(/ e obj pt pt1 dis lt)
(vl-load-com)
(setq e (car (entsel "Chon PL")))
(setq obj (vlax-ename-&gt;vla-object e))
(while (setq pt (getpoint "Pick diem"))
(setq pt1 (vlax-curve-getClosestPointTo obj pt))
(setq dis (distance pt pt1))
(setq lt (vlax-curve-getDistAtPoint obj pt1))
(princ (strcat "Ly trinh = " (rtos lt 2 2) "\nKhoach cach den tim = " (rtos dis 2 2)))

(MakeText pt (strcat "KC=" (rtos dis 2 2)) 2.0 0.7 (GetAngleVuong obj pt1) "BL" nil nil nil nil)
(MakeText pt (strcat "LT=" (rtos lt 2 2)) 2.0 0.7 (GetAngleVuong obj pt1) "TL" nil nil nil nil)
(MakeLeader pt1 pt 1.0)
)
)
<<

Filename: 255059_ttt.lsp
Tác giả: hiepttr
Bài viết gốc: 255168
Tên lệnh: ha
Nhờ các bác chỉnh hộ Lisp vẽ hình chữ nhật

đang luyện công nhưng mạo muội sửa bậy

>>>> hòng học đc nhiều cái hay sau 1 rổ đá :D :D :D

(defun C:HA( / pa pb h1 pc)
 (BAT_DAU)
 (initget 1) (setq pa (getpoint "\nPick diem A: "))
 (initget 1) (setq pb (getpoint pa "\nPick diem B: "))
 (acet-sysvar-set (list "cmdecho" 0))
 (command "ucs" "z" (/ (* 180 (angle pa pb)) pi))
 (setq pa (trans pa 0 1))
 (setq pb (trans pb 0 1))
 (grvecs (list -3 pa pb))
 (acet-sysvar-set...
>>

đang luyện công nhưng mạo muội sửa bậy

>>>> hòng học đc nhiều cái hay sau 1 rổ đá :D :D :D

(defun C:HA( / pa pb h1 pc)
 (BAT_DAU)
 (initget 1) (setq pa (getpoint "\nPick diem A: "))
 (initget 1) (setq pb (getpoint pa "\nPick diem B: "))
 (acet-sysvar-set (list "cmdecho" 0))
 (command "ucs" "z" (/ (* 180 (angle pa pb)) pi))
 (setq pa (trans pa 0 1))
 (setq pb (trans pb 0 1))
 (grvecs (list -3 pa pb))
 (acet-sysvar-set (list "orthomode" 1))
 (if (not h) (setq h 100))
 (setq h1 (getdist pb (strcat "Chieu cao <" (rtos h 2 4) " >: ")))
 (if h1
	(setq h h1)
	)
 (princ (strcat "Nhan chieu cao " (rtos h 2 4)))
 (setq pc (polar pb (/ pi 2) h))
 (command "rectangle" pa pc)
 (redraw)
 (command "ucs" "w")
 (acet-sysvar-restore)
 (KET_THUC)
 (princ))
(defun BAT_DAU()
 (vl-load-com)
 (setq AcDoc (vla-get-activeDocument (vlax-get-acad-object)))
 (vla-StartUndoMark AcDoc)
 (setq err *error* *error* KHI_LOI))
(defun KET_THUC()
 (acet-sysvar-restore)
 (vla-EndUndoMark AcDoc)
 (setq *error* err))
(defun KHI_LOI(msg)
 (acet-sysvar-restore)
 (vla-EndUndoMark AcDoc)
 (redraw)
 (command "u")
 (princ (strcat "\n" msg ", Reset System Variables\n"))
 (setq *error* err))

<<

Filename: 255168_ha.lsp
Tác giả: bach1212
Bài viết gốc: 255127
Tên lệnh: edt
Điền thông số có 2 chữ số sau dấu phẩy (Lisp tính diện tích)

Nhờ các bạn chỉ giúp mình cách làm cho kết quả điền ra luôn là số có 2 chữ số sau dấu phẩy

Hiện tại, nếu kết quả mà chẵn: VD: 90.00 thì chỉ nhận được: 90

(defun c:edt()
  (if (= tl nil) (progn
    (setq tl (getreal "\nDrawing scale<1/> : "))
    (setq ntl tl)
    (setq tl2 (* ntl ntl))
    )
  )
  (setq dtl 0)
  (setq ss (ssadd))
  (setq oslast (getvar "OSMODE"))
  (command...
>>

Nhờ các bạn chỉ giúp mình cách làm cho kết quả điền ra luôn là số có 2 chữ số sau dấu phẩy

Hiện tại, nếu kết quả mà chẵn: VD: 90.00 thì chỉ nhận được: 90

(defun c:edt()
  (if (= tl nil) (progn
    (setq tl (getreal "\nDrawing scale<1/> : "))
    (setq ntl tl)
    (setq tl2 (* ntl ntl))
    )
  )
  (setq dtl 0)
  (setq ss (ssadd))
  (setq oslast (getvar "OSMODE"))
  (command "osnap" "")
  (print)
  (print)
  (setq pt1 (getpoint "\nChon mot diem trong vung dien tich can tinh: "))
  (while (/= pt1 nil)
    (command "-boundary" pt1 "")
    (setq et (entlast))
    (ssadd et ss)
    (command "area" "e" "last")
    (setq vsize ( /(getvar "VIEWSIZE") 3 ))
    (command "hatch" "ANSI31" vsize "0" "last" "")
    (setq et (entlast))
    (ssadd et ss)
    (setq dtcon (getvar "AREA"))
    (setq dtl (+ dtcon dtl))
    (print)
    (print)
    (setq pt1 (getpoint "\nChon mot diem trong vung dien tich tiep theo : "))
  )
  (command "setvar" "OSMODE" oslast)
  (command "erase" ss "")
  (setq ss nil)
  (command "redraw" )
  (setq dtl (* dtl tl2))
  (print dtl)
  (setq elst (entget (car (entsel "Thay cho so: "))))
  (setq elst (subst (cons 1 (rtos dtl 2 2)) (assoc 1 elst) elst))
  (entmod elst)
(command "setvar" "OSMODE" 15359)

http://www.cadviet.com/upfiles/3/40304_edt.lsp


<<

Filename: 255127_edt.lsp
Tác giả: ndtnv
Bài viết gốc: 255012
Tên lệnh: ii
Lisp thêm đỉnh pline tại giao điểm của pline và các line khác

Lisp này chỉ dùng cho lwpolyline, vì vậy bạn dùng lệnh convert của CAD để chuyển thành lwpolyline

 

(defun AppendLs (ls e)(append (if ls ls nil) (list e)))
(defun ObjInters (o1 o2 id / g ps n)
    (setq    g    (vlax-invoke o1 'IntersectWith o2 id)    ps '())
    (while g (setq    ps (AppendLs ps (list (car g) (cadr g) (caddr g))) g (cdddr g))    )    ps
)
(defun Bulge (p1 p2 r / a)
    (setq a...
>>

Lisp này chỉ dùng cho lwpolyline, vì vậy bạn dùng lệnh convert của CAD để chuyển thành lwpolyline

 

(defun AppendLs (ls e)(append (if ls ls nil) (list e)))
(defun ObjInters (o1 o2 id / g ps n)
    (setq    g    (vlax-invoke o1 'IntersectWith o2 id)    ps '())
    (while g (setq    ps (AppendLs ps (list (car g) (cadr g) (caddr g))) g (cdddr g))    )    ps
)
(defun Bulge (p1 p2 r / a)
    (setq a (/ (distance p1 p2) 2 r))
    (setq a (/ (atan (/ a (sqrt (- 1 (* a a))))) 2))
    (/ (sin a) (cos a))
)

(defun C:II ( / b fz i l li lp lq ls n ob om p p1 p2 r ss) ; Insert vertex at intersections
    (setq i 0 fz 0.1) ; sai so giao diem lech so voi dinh pline
    (princ "Chon pline:")    (setq ss (ssget ":S") ob (vlax-ename->vla-object (ssname ss 0)) )
    (princ "Chon cac duong giao:")
    (setq ls (mapcar 'vlax-ename->vla-object
                                     (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*LINE")(8 . "ENTCOC"))))))))
    (foreach o ls
        (setq p (car(ObjInters ob o acExtendNone)) lp (AppendLs lp p))    
        (setq lq (AppendLs lq (vlax-curve-getParamAtPoint ob (vlax-curve-getClosestPointTo ob p)))))
    (setq li (vl-sort-i lq '>) )
    (foreach i li
        (setq n (fix (nth i lq)) p (nth i lp))
        (setq p1 (vlax-curve-getPointAtParam ob n) p2 (vlax-curve-getPointAtParam ob (1+ n)))
        (if (and  (< fz (distance p p1)) (< fz (distance p p2)))
            (progn
                (setq b (vlax-invoke Ob 'GetBulge n))
                (vlax-invoke Ob 'AddVertex (1+ n) (list (car p)(cadr p)))
                (if (/= b 0)
                    (progn
                        (setq r (/ (distance p1 p2) 2 (sin (* 2 (atan b)))))
                        (vlax-invoke Ob 'SetBulge n (Bulge p p1 r))
                        (vlax-invoke Ob 'SetBulge (1+ n) (Bulge p p2 r))))
            )
        ))

)

<<

Filename: 255012_ii.lsp
Tác giả: quansla
Bài viết gốc: 255260
Tên lệnh: thu
lisp lọc các đối tượng trên bản vẽ.

cảm ơn anh đã để ý đến vấn đề của em.vấn đề số tờ  bản đồ không quan trọng.Vì trong một bản vẽ  chỉ có một số tờ bản đồ ví dụ là 22.thì tất cả phía dưới các cụm từ đều là số 22 nên ta sẽ không cần dùng lisp nữa,ta sẽ xóa thủ công bằng lệnh Find anh ạ như thế chỉ mất một số thửa là...

>>

cảm ơn anh đã để ý đến vấn đề của em.vấn đề số tờ  bản đồ không quan trọng.Vì trong một bản vẽ  chỉ có một số tờ bản đồ ví dụ là 22.thì tất cả phía dưới các cụm từ đều là số 22 nên ta sẽ không cần dùng lisp nữa,ta sẽ xóa thủ công bằng lệnh Find anh ạ như thế chỉ mất một số thửa là 22 trùng với số tờ bản đồ bị xóa đi thôi ạ.Quan trọng lọc và đưa các số thửa,loại đất,chủ sử dụng và địa chỉ về đúng lớp là ok rồi anh ạ

Bạn thử Code này xem nào, trình độ viết lisp của mình còn dở lắm về thuật toán thì chắc là rất ngớ ngẩn trước hết cứ đáp ứng nhu cầu của bạn đã, bạn gõ lệnh "THU" (thử) rồi dùng chuột quét chọn hình chữ nhật bao lấy một "cụm Text" mẫu (là cụm gồm đủ 5 Text như bạn đưa ra trên ảnh ý) sau đó nhấn Enter và kiểm tra kết quả.
Chú ý

  •  
  • Để thay đổi bộ lọc của số hiệu đất bạn tạo một file txt mới với nội dung là : mỗi dòng một loại mã hiệu đất (3 ký tự) và lưu lại vào đâu đó khi sử dụng lisp Ngay bước đầu tiên khi Lisp hỏi bạn là hãy quét chọn  Hình chữ nhật bao bộ lọc thi bạn không chọn điểm nữa mà ấn "S" / enter 
  • Cũng ở phần chọn hình chữ nhật bao bộ lọc bạn ấn E lisp sẽ tự thoát 
  • Mẹo: để lisp xử lý triệ để nhất bạn hãy chọn hình bao bộ lọc bao toàn bộ Text mẫu (hoặc bao trùm hẳn ra ngoài Text dài nhất là tốt nhất) vì trong Lisp của mình chỉ xử lý các đối tượng nằm trong khung bằng khung chữ nhật quét ban đầu thôi.

hixx, trình độ văn của mình kém lắm lại đang buồn ngủ, nếu quá khó hiểu bạn cmm lại mình làm video sau. Chúc bạn thành công.
Code

(defun c:thu (/ Setlist_dat newlayer  dis dt enti flag1 i loc ls ls1 N p0 p1 p2 pA pB ss ssdt Tvalue x
     *myerr ang1 ang2 dis1 dis2 enti flag1 i line ls olderr p1 p10 p2 ss0 ssdt Tvalue x)
  (defun *myerr (msg);
    (princ "Error: ")(princ msg)
    (princ)
    (if olderr (setq *error* olderr))
    (princ))
 
  (defun newlayer ( a b c d)
(if (not (tblsearch "layer" a))
(command "-layer" "n" a "c" b a "l" c a "lw" d a "")
;(command "-layer" "s" a "c" b a "l" c a "lw" d a "")
)
  )
 
  
  (defun Setlist_dat (/ duondan f ls)
    (setq duondan (getfiled "\nChon file chua danh sach Ma dat" "" "txt" 2)
 ls (list))
    (setq f (open duondan "r"))
    (while (setq line (read-line f))
      (setq ls (append (list line) ls))
      )
    (close f)
    (setq flag1 T)
    (setq #ls ls)
    ls    
    )
  ;;nhap vl-load,tao bo loc "loc" va khoi tao layer can thiet
  (vl-load-com)
  (setq olderr *error* *error* *myerr)
  (newlayer "so thua" 1 "Continuous " 0)
  (newlayer "loai dat" 2 "Continuous " 0)  
  (newlayer "chu su dung" 3 "Continuous " 0)
  (newlayer "dia chi" 4 "Continuous " 0)
  
  (or #ls (setq #ls '("DXH" "PNK" "DNL" "DBV" "SON" "TON" "DCS" "BCS" "ONT" "ODT" "DGD" "NTD" "SKK"
    "SKX" "MVT" "CQP" "DDT" "DTL" "DGT" "TSC" "RPK" "RDT" "RPT" "RST" "RDN" "RPN"
    "RSN" "MNC" "TSN" "TSL" "SKC" "COC" "SKS" "LNK" "LNQ" "LNC" "DVH" "BHK" "DYT"
    "CAN" "DCH" "TSK" "LMU" "TIN" "DTT" "LUK" "LUC" "LUN")))
  (setq ls #ls)
  (setq loc (mapcar '(lambda (x)(cons 1 x))ls))
  (setq loc (append '(( -4 . "<AND"))
   '((0 . "TEXT,MTEXT"))
   '(( -4 . "<OR"))
   loc
   '(( -4 . "OR>"))
   '(( -4 . "AND>"))))
  ;;;ket thuc khoi tao
 
 
  
  (setq flag1 nil)
  (while (null flag1)
      (initget "Setting Exit")
      (setq p1 (getpoint "\nQuet Hinh chu nhat bao bo loc or <Select>"))
      (cond
( (= p1 "Setting")(setq ls (SETLIST_DAT )))
( (= p1 "Exit")(exit))
( (= 'LIST (type p1))
(progn
  
  (if (setq p2 (getcorner p1)
    ss (acet-ss-to-list(ssget
 "_w"
 p1
 p2
 loc
 ))
    ss0 (car ss))     
    (progn
      (setq flag1 T)
      (setq ang1 (angle (setq p10 (cdr(assoc 10 (entget ss0)))) p1)
    ang2 (angle p10 p2)
    dis1 (distance p10 p1)
    dis2 (distance p10 p2))
      (princ)
      )
    (alert "\nBan da chon vung khong co KH mau dat phu hop\n"))
))
(T (setq flag1 nil)(prompt "\nBan da chon vung khong co DATA phu hop reSected or Exit\n")(princ)))
      )
  (if flag1
    (if (setq ss (acet-ss-to-list(ssget "X" loc)))
      (mapcar '(lambda (x / p10 p1 p2 ssdt)
(setq p10 (cdr(assoc 10 (entget x)))
      p1 (polar p10 ang1 dis1)
      p2 (polar p10 ang2 dis2)
      ssdt (acet-ss-to-list(ssget "_W" p1 p2)))
(foreach i ssdt
  (setq Tvalue (cdr(assoc 1 (setq enti (entget i)))))
  (cond
    ( ( wcmatch Tvalue "Th*#") (entmod(subst (cons 8 "dia chi") (assoc 8 enti) enti)))
    ( (> (atoi Tvalue) 0) (entmod(subst (cons 8 "so thua") (assoc 8 enti) enti)))
    ( (and (= (strlen Tvalue) 3) (member (car(list Tvalue)) ls))
     (entmod(subst (cons 8 "loai dat") (assoc 8 enti) enti)))
    (T (entmod(subst (cons 8 "chu su dung") (assoc 8 enti) enti)))
    )
  ))
     ss)
      )
    )
  (command "_change" "_all" "" "p" "co" "bylayer" "")
  (if olderr (setq *error* olderr))
  (princ)
  )

 

101306_63415_loc_du_lieu.jpg


<<

Filename: 255260_thu.lsp
Tác giả: Tue_NV
Bài viết gốc: 65704
Tên lệnh: tg%3Cspan+clas
Hỏi cách thêm kí tự bất kỳ vào text

Tue_NV nâng cấp Lisp thêm text giữa theo ý của bạn

Các bạn sử dụng thử và cho mình biết ý kiến nhé.

Filename: 65704_tg%3Cspan+clas.lsp
Tác giả: metavn
Bài viết gốc: 255209
Tên lệnh: btk
Nhờ viết lisp dim kích thước các pline và xuất ra file cel

Nhờ các bác viết dùm lisp như này:
- Lisp 1: ghi kích thước theo dimstyle hiện hành
Có các thanh thép là các đường pline, line như trong file đính kèm (phần "ban đầu"), em muốn đo các kích thước của các thanh thép đó như phần "Dùng lisp" có cả kích thước chiều dài cung tròn, kích thước bán kính cung tròn, góc nghiêng.
Chú ý là thanh X3 đo kích thước cung tròn bằng lệnh 'dar' thì không đẹp,...

>>

Nhờ các bác viết dùm lisp như này:
- Lisp 1: ghi kích thước theo dimstyle hiện hành
Có các thanh thép là các đường pline, line như trong file đính kèm (phần "ban đầu"), em muốn đo các kích thước của các thanh thép đó như phần "Dùng lisp" có cả kích thước chiều dài cung tròn, kích thước bán kính cung tròn, góc nghiêng.
Chú ý là thanh X3 đo kích thước cung tròn bằng lệnh 'dar' thì không đẹp, các bác có thể viết lisp thay thế bằng lệnh đo góc 'dan' mà giá trị ghi vẫn là chiều dài cung đó được ko.
- Lisp 2: Tính chiều dài và điền vào text, xuất sang cel
Cụ thể là pick vào từng thanh một sẽ tính chiều dài thanh đó (có thể là line hoặc pline) rồi pick vào từng text sẽ điền giá trị chiều dài thanh đó vào phần cuối của text.
VD: pick vào hình vẽ thanh X1 sẽ hiện lên command "điền giá trị vào text" rồi pick vào text "x1-d25, l=" sẽ thành "x1-d25, l=4545", sau đó hiện lên command "chọn thanh tiếp theo" pick vào thanh x2 rồi pick vào text "x2-d16, l=" v.v.....
Kết thúc bằng lệnh enter sẽ xuất chiều dài các thanh vừa pick sang file excel với giá trị chiều dài các thanh nằm trên 1 cột như file đính kèm
 
http://www.cadviet.com/upfiles/3/83908_cotthep_1.rar
Mong các bác giúp đỡ, em xin cám ơn trước.
 
P/S: Em cũng tìm mấy hôm trên diễn đàn về lisp tính chiều dài pline và xuất sang excel thì chưa tìm được lisp đúng ý.
Lisp này thì tính chiều dài từng phần trong pline mà ko tính tổng, lại ko tính liên tục các pline được, nhờ các bác sửa giúp em

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=43033
(defun c:p2E(/ i ent ss lstV pt_lst nb)
; Polyline Vertex Length to Excel
; @ gia_bach
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "*POLYLINE"))))
    (progn
    (repeat (setq i (sslength ss))
	(setq ent (ssname ss (setq i (1- i))) 
		  nb (strcat "Pline " (rtos (- (sslength ss) i) 2 0)) 
		  lstV (append (list(list nb))(pll ent)))
	(foreach pt lstV
	  (setq pt_lst (append pt_lst (list pt)))
	))	  
      (if (vlax-get-or-create-object "Excel.Application")
	(WriteToExcel pt_lst)
	(WriteToCSV pt_lst) )))
  (princ))

(defun WriteToExcel (lst_data / col row x xlApp xlCells)
  (setq xlApp (vlax-get-or-create-object "Excel.Application")
	xlCells (vlax-get-property
		  (vlax-get-property
		    (vlax-get-property
		      (vlax-invoke-method
			(vlax-get-property xlApp "Workbooks")
			"Add")
		      "Sheets")
		    "Item" 1)
		  "Cells"))
  (setq row 3)
  (foreach pt lst_data
    (setq col 3)
    (foreach coor pt
      (vlax-put-property xlCells 'Item row col coor)
      (setq col (1+ col)))
    (setq row (1+ row)) )
  (vla-put-visible xlApp :vlax-true)
  (mapcar
    (function (lambda (x)
		(vl-catch-all-apply (function (lambda ()(if x (vlax-release-object x)))))))
    (list xlCells xlApp))
  (gc) (gc) )

(defun WriteToCSV (lst_data / fl)  
  (if (setq fl (getfiled "Output File" "" "csv" 1))
    (if (setq fl (open fl "w"))
      (progn
	(foreach pt lst_data 
	  (write-line (strcat (rtos (car pt)) "," (rtos (cadr pt)) "," (rtos (caddr pt))) fl) )
	(close fl) ) ) )
  (princ))
  
  
  
  (defun pll ( e / j)         
  (setq j (1- (vlax-curve-getStartParam e)) lst '())
  (while (<= (setq j (1+ j)) (vlax-curve-getEndParam e))
    (setq lst
        (cons 
          (list (- (vlax-curve-getDistatParam e j)
             (if (zerop j) 0
             (vlax-curve-getDistatParam e (1- j)))))
		lst
		)
	)
  )
	(setq lst (cdr (reverse lst)))
	lst
)

 
Hoặc lisp này thì lại chỉ tính được line:

 

(defun c:btk ( / plst e p0 p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 n i obj els pa pf ps len txt fn fw ans)
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq plst (list)  i 0)
(alert "\n Chon cac doan can thong ke")
(setq e  (entsel "\n Chon doan can thong ke"))
(While e
        (princ (strcat " 1 found. " (rtos (1+ i) 2 0) "total"))
        (setq plst (cons e plst)
                  e (entsel "\n Chon doan tiep theo")
                  i (1+ i)
        )
)
(setq plst (reverse plst))
(setq p1 (getpoint "\n Chon diem dat bang thong ke")
          p2 (polar p1 0 2.5)
          p3 (polar p2 0 5.5)
          p4 (polar p3 0 5.5)
          p5 (polar p4 0 5.5)
          n (length plst)
          p6 (polar p1 (* 1.5 pi) (* (1+ n) 1.5))
          p7 (polar p2 (* 1.5 pi) (* (1+ n) 1.5))
          p8 (polar p3 (* 1.5 pi) (* (1+ n) 1.5))
          p9 (polar p4 (* 1.5 pi) (* (1+ n) 1.5))
          p10 (polar p5 (* 1.5 pi) (* (1+ n) 1.5))
)
(command "line" p1 p5 p10 p6 p1 "")
(command "line" p2 p7 "")
(command "line" p3 p8 "")
(command "line" p4 p9 "")
(styleset)
(command "text" "j" "mc" (list (+ (car p1) 1.25) (- (cadr p1) 0.75)) 0.3 0 "TT  &#208;O\\U+1EA0N" )
(command "text" "j" "mc" (list (+ (car p2) 2.75) (- (cadr p1) 0.75)) 0.3 0 "T\\U+1EEA  &#208;I\\U+1EC2M" )
(command "text" "j" "mc" (list (+ (car p3) 2.75) (- (cadr p1) 0.75)) 0.3 0 "T\\U+1EDAI  &#208;I\\U+1EC2M" )
(command "text" "j" "mc" (list (+ (car p4) 2.75) (- (cadr p1) 0.75)) 0.3 0 "CHI\\U+1EC0U  D&#192;I")
(command "text" "j" "mc" (list (+ (car p1) 9.5) (+ (cadr p1) 0.5 )) 0.5 0 "B\\U+1EA2NG XU\\U+1EA4T RA K\\U+1EBET QU\\U+1EA2")
(setq ans (getstring "\n Ban muon luu sang file cvs khong?? <Y or N>: "))
(if (= (strcase ans) "Y")
    (progn
            (setq fn (getfiled "Chon file de save" "" "csv" 1)
   	       fw (open fn "w"))
       	(princ  "BANG XUAT TOA DO RA FILE CSV \n" fw)
                  (princ " TT doan , Tu diem , Toi diem , Chieu dai \n" fw)
   )
)
(setq i 0)
(foreach a plst
   	(setq i (1+ i)
                obj (vlax-ename->vla-object (car a))
                els (entget (car a))
                p0 (polar p1 (* 1.5 pi) 1.5)
                p1 p0
   	)
   	(cond
         	( (or (= (cdr (assoc 0 els)) "LWPOLYLINE") (= (cdr (assoc 0 els)) "POLYLINE"))
                  (setq pa (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (cadr a)))
                            pf (vlax-curve-getpointatparam obj (fix pa))
                            ps (vlax-curve-getpointatparam obj (1+ (fix pa)))
                            len (- (vlax-curve-getdistatpoint obj ps) (vlax-curve-getdistatpoint obj pf))                          
                  ) )
         	( (= (cdr (assoc 0 els)) "LINE")
                  (setq pf (cdr (assoc 10 els))
                       	ps (cdr (assoc 11 els))
                       	len (distance pf ps)
                  ) )
         	( (or (= (cdr (assoc 0 els)) "SPLINE") (=  (cdr (assoc 0 els)) "ARC") )
                  (setq pf (vlax-curve-getstartpoint obj)
                       	ps (vlax-curve-getendpoint obj)
                       	len (vlax-curve-getdistatpoint obj ps)
                  ) )
         	(T nil)
   	)
   	(setq txt (strcat (rtos i 2 0) "," "X=" (rtos (car pf) 2 4) "  Y=" (rtos (cadr pf) 2 4) "," "X=" (rtos (car ps) 2 4) "  Y=" (rtos (cadr ps) 2 4) "," (rtos len 2 4) "\n"))
   	(command "line" p0 (polar p0 0 19) "")
   	(command "text" "j" "mc" (list (+ (car p0) 1.25) (- (cadr p0) 0.75)) 0.2 0 (rtos i 2 0) )
   	(command "text" "j" "mc" (list (+ (car p0) 5.25) (- (cadr p1) 0.75)) 0.2 0 (strcat "X=" (rtos (car pf) 2 4) "  Y=" (rtos (cadr pf) 2 4)) )
   	(command "text" "j" "mc" (list (+ (car p0) 10.75) (- (cadr p1) 0.75)) 0.2 0 (strcat "X=" (rtos (car ps) 2 4) "  Y=" (rtos (cadr ps) 2 4)) )
   	(command "text" "j" "mc" (list (+ (car p0) 16.25) (- (cadr p1) 0.75)) 0.2 0 (rtos len 2 4))
   	(if (= (strcase ans) "Y")
       	(princ txt fw)
   	)
)
(if fw
   (close fw)
)
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)
 
(defun styleset ()
(setq stl (getvar "textstyle")
     	h (getvar "textsize"))
(if (/= h 0) (command "style" stl "" 0 "" "" "" "" ""))
)                  


<<

Filename: 255209_btk.lsp
Tác giả: metavn
Bài viết gốc: 255209
Tên lệnh: p2e
Nhờ viết lisp dim kích thước các pline và xuất ra file cel

Nhờ các bác viết dùm lisp như này:
- Lisp 1: ghi kích thước theo dimstyle hiện hành
Có các thanh thép là các đường pline, line như trong file đính kèm (phần "ban đầu"), em muốn đo các kích thước của các thanh thép đó như phần "Dùng lisp" có cả kích thước chiều dài cung tròn, kích thước bán kính cung tròn, góc nghiêng.
Chú ý là thanh X3 đo kích thước cung tròn bằng lệnh 'dar' thì không đẹp,...

>>

Nhờ các bác viết dùm lisp như này:
- Lisp 1: ghi kích thước theo dimstyle hiện hành
Có các thanh thép là các đường pline, line như trong file đính kèm (phần "ban đầu"), em muốn đo các kích thước của các thanh thép đó như phần "Dùng lisp" có cả kích thước chiều dài cung tròn, kích thước bán kính cung tròn, góc nghiêng.
Chú ý là thanh X3 đo kích thước cung tròn bằng lệnh 'dar' thì không đẹp, các bác có thể viết lisp thay thế bằng lệnh đo góc 'dan' mà giá trị ghi vẫn là chiều dài cung đó được ko.
- Lisp 2: Tính chiều dài và điền vào text, xuất sang cel
Cụ thể là pick vào từng thanh một sẽ tính chiều dài thanh đó (có thể là line hoặc pline) rồi pick vào từng text sẽ điền giá trị chiều dài thanh đó vào phần cuối của text.
VD: pick vào hình vẽ thanh X1 sẽ hiện lên command "điền giá trị vào text" rồi pick vào text "x1-d25, l=" sẽ thành "x1-d25, l=4545", sau đó hiện lên command "chọn thanh tiếp theo" pick vào thanh x2 rồi pick vào text "x2-d16, l=" v.v.....
Kết thúc bằng lệnh enter sẽ xuất chiều dài các thanh vừa pick sang file excel với giá trị chiều dài các thanh nằm trên 1 cột như file đính kèm
 
http://www.cadviet.com/upfiles/3/83908_cotthep_1.rar
Mong các bác giúp đỡ, em xin cám ơn trước.
 
P/S: Em cũng tìm mấy hôm trên diễn đàn về lisp tính chiều dài pline và xuất sang excel thì chưa tìm được lisp đúng ý.
Lisp này thì tính chiều dài từng phần trong pline mà ko tính tổng, lại ko tính liên tục các pline được, nhờ các bác sửa giúp em

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=43033
(defun c:p2E(/ i ent ss lstV pt_lst nb)
; Polyline Vertex Length to Excel
; @ gia_bach
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "*POLYLINE"))))
    (progn
    (repeat (setq i (sslength ss))
	(setq ent (ssname ss (setq i (1- i))) 
		  nb (strcat "Pline " (rtos (- (sslength ss) i) 2 0)) 
		  lstV (append (list(list nb))(pll ent)))
	(foreach pt lstV
	  (setq pt_lst (append pt_lst (list pt)))
	))	  
      (if (vlax-get-or-create-object "Excel.Application")
	(WriteToExcel pt_lst)
	(WriteToCSV pt_lst) )))
  (princ))

(defun WriteToExcel (lst_data / col row x xlApp xlCells)
  (setq xlApp (vlax-get-or-create-object "Excel.Application")
	xlCells (vlax-get-property
		  (vlax-get-property
		    (vlax-get-property
		      (vlax-invoke-method
			(vlax-get-property xlApp "Workbooks")
			"Add")
		      "Sheets")
		    "Item" 1)
		  "Cells"))
  (setq row 3)
  (foreach pt lst_data
    (setq col 3)
    (foreach coor pt
      (vlax-put-property xlCells 'Item row col coor)
      (setq col (1+ col)))
    (setq row (1+ row)) )
  (vla-put-visible xlApp :vlax-true)
  (mapcar
    (function (lambda (x)
		(vl-catch-all-apply (function (lambda ()(if x (vlax-release-object x)))))))
    (list xlCells xlApp))
  (gc) (gc) )

(defun WriteToCSV (lst_data / fl)  
  (if (setq fl (getfiled "Output File" "" "csv" 1))
    (if (setq fl (open fl "w"))
      (progn
	(foreach pt lst_data 
	  (write-line (strcat (rtos (car pt)) "," (rtos (cadr pt)) "," (rtos (caddr pt))) fl) )
	(close fl) ) ) )
  (princ))
  
  
  
  (defun pll ( e / j)         
  (setq j (1- (vlax-curve-getStartParam e)) lst '())
  (while (<= (setq j (1+ j)) (vlax-curve-getEndParam e))
    (setq lst
        (cons 
          (list (- (vlax-curve-getDistatParam e j)
             (if (zerop j) 0
             (vlax-curve-getDistatParam e (1- j)))))
		lst
		)
	)
  )
	(setq lst (cdr (reverse lst)))
	lst
)

 
Hoặc lisp này thì lại chỉ tính được line:

 

(defun c:btk ( / plst e p0 p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 n i obj els pa pf ps len txt fn fw ans)
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq plst (list)  i 0)
(alert "\n Chon cac doan can thong ke")
(setq e  (entsel "\n Chon doan can thong ke"))
(While e
        (princ (strcat " 1 found. " (rtos (1+ i) 2 0) "total"))
        (setq plst (cons e plst)
                  e (entsel "\n Chon doan tiep theo")
                  i (1+ i)
        )
)
(setq plst (reverse plst))
(setq p1 (getpoint "\n Chon diem dat bang thong ke")
          p2 (polar p1 0 2.5)
          p3 (polar p2 0 5.5)
          p4 (polar p3 0 5.5)
          p5 (polar p4 0 5.5)
          n (length plst)
          p6 (polar p1 (* 1.5 pi) (* (1+ n) 1.5))
          p7 (polar p2 (* 1.5 pi) (* (1+ n) 1.5))
          p8 (polar p3 (* 1.5 pi) (* (1+ n) 1.5))
          p9 (polar p4 (* 1.5 pi) (* (1+ n) 1.5))
          p10 (polar p5 (* 1.5 pi) (* (1+ n) 1.5))
)
(command "line" p1 p5 p10 p6 p1 "")
(command "line" p2 p7 "")
(command "line" p3 p8 "")
(command "line" p4 p9 "")
(styleset)
(command "text" "j" "mc" (list (+ (car p1) 1.25) (- (cadr p1) 0.75)) 0.3 0 "TT  &#208;O\\U+1EA0N" )
(command "text" "j" "mc" (list (+ (car p2) 2.75) (- (cadr p1) 0.75)) 0.3 0 "T\\U+1EEA  &#208;I\\U+1EC2M" )
(command "text" "j" "mc" (list (+ (car p3) 2.75) (- (cadr p1) 0.75)) 0.3 0 "T\\U+1EDAI  &#208;I\\U+1EC2M" )
(command "text" "j" "mc" (list (+ (car p4) 2.75) (- (cadr p1) 0.75)) 0.3 0 "CHI\\U+1EC0U  D&#192;I")
(command "text" "j" "mc" (list (+ (car p1) 9.5) (+ (cadr p1) 0.5 )) 0.5 0 "B\\U+1EA2NG XU\\U+1EA4T RA K\\U+1EBET QU\\U+1EA2")
(setq ans (getstring "\n Ban muon luu sang file cvs khong?? <Y or N>: "))
(if (= (strcase ans) "Y")
    (progn
            (setq fn (getfiled "Chon file de save" "" "csv" 1)
   	       fw (open fn "w"))
       	(princ  "BANG XUAT TOA DO RA FILE CSV \n" fw)
                  (princ " TT doan , Tu diem , Toi diem , Chieu dai \n" fw)
   )
)
(setq i 0)
(foreach a plst
   	(setq i (1+ i)
                obj (vlax-ename->vla-object (car a))
                els (entget (car a))
                p0 (polar p1 (* 1.5 pi) 1.5)
                p1 p0
   	)
   	(cond
         	( (or (= (cdr (assoc 0 els)) "LWPOLYLINE") (= (cdr (assoc 0 els)) "POLYLINE"))
                  (setq pa (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (cadr a)))
                            pf (vlax-curve-getpointatparam obj (fix pa))
                            ps (vlax-curve-getpointatparam obj (1+ (fix pa)))
                            len (- (vlax-curve-getdistatpoint obj ps) (vlax-curve-getdistatpoint obj pf))                          
                  ) )
         	( (= (cdr (assoc 0 els)) "LINE")
                  (setq pf (cdr (assoc 10 els))
                       	ps (cdr (assoc 11 els))
                       	len (distance pf ps)
                  ) )
         	( (or (= (cdr (assoc 0 els)) "SPLINE") (=  (cdr (assoc 0 els)) "ARC") )
                  (setq pf (vlax-curve-getstartpoint obj)
                       	ps (vlax-curve-getendpoint obj)
                       	len (vlax-curve-getdistatpoint obj ps)
                  ) )
         	(T nil)
   	)
   	(setq txt (strcat (rtos i 2 0) "," "X=" (rtos (car pf) 2 4) "  Y=" (rtos (cadr pf) 2 4) "," "X=" (rtos (car ps) 2 4) "  Y=" (rtos (cadr ps) 2 4) "," (rtos len 2 4) "\n"))
   	(command "line" p0 (polar p0 0 19) "")
   	(command "text" "j" "mc" (list (+ (car p0) 1.25) (- (cadr p0) 0.75)) 0.2 0 (rtos i 2 0) )
   	(command "text" "j" "mc" (list (+ (car p0) 5.25) (- (cadr p1) 0.75)) 0.2 0 (strcat "X=" (rtos (car pf) 2 4) "  Y=" (rtos (cadr pf) 2 4)) )
   	(command "text" "j" "mc" (list (+ (car p0) 10.75) (- (cadr p1) 0.75)) 0.2 0 (strcat "X=" (rtos (car ps) 2 4) "  Y=" (rtos (cadr ps) 2 4)) )
   	(command "text" "j" "mc" (list (+ (car p0) 16.25) (- (cadr p1) 0.75)) 0.2 0 (rtos len 2 4))
   	(if (= (strcase ans) "Y")
       	(princ txt fw)
   	)
)
(if fw
   (close fw)
)
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)
 
(defun styleset ()
(setq stl (getvar "textstyle")
     	h (getvar "textsize"))
(if (/= h 0) (command "style" stl "" 0 "" "" "" "" ""))
)                  


<<

Filename: 255209_p2e.lsp
Tác giả: bach1212
Bài viết gốc: 255806
Tên lệnh: tgl
Thêm chức năng làm tròn số cho lisp tính chiều dài

Hiện tại mình có lisp tính tổng chiều dài các đường thẳng , và kết quả thay vào 1 số có sẵn.

Mình muốn, kết quả đó được làm tròn số luôn thì phải làm như thế nào?

Hiện tại mình có 2 lisp riêng lẻ này: 1 là tính chiều dài, 2 là làm tròn số, không biết kết hợp lại như thế nào để được như ý?

;; free lisp from...
>>

Hiện tại mình có lisp tính tổng chiều dài các đường thẳng , và kết quả thay vào 1 số có sẵn.

Mình muốn, kết quả đó được làm tròn số luôn thì phải làm như thế nào?

Hiện tại mình có 2 lisp riêng lẻ này: 1 là tính chiều dài, 2 là làm tròn số, không biết kết hợp lại như thế nào để được như ý?

;; free lisp from cadviet.com
;;;--------------------------------------------------------------------
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:TGL( / ss L e)
(setq
ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
L 0.0
)
(vl-load-com)
(while (setq e (ssname ss 0))
(setq L (+ L (length1 e)))
(ssdel e ss)
)


(setq te (entget(car(entsel"\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
)
;;;--------------------------------------------------------------------
;; free lisp from cadviet.com
;;;-------------------------------------------------------
(defun etype (e);;;Entity Type
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------------
(defun C:LTT( / ss n i oldDimzin e d v S)
(if (not n0) (setq n0 2))
(setq
ss (ssget '((0 . "TEXT,MTEXT")))
n (getint (strcat "\nSo chu so thap phan <" (itoa n0) ">:"))
i 0
oldDimzin (getvar "dimzin")
)
(if n (setq n0 n) (setq n n0))
(setvar "dimzin" 8)
(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)))
S (rtos v 2 n)
d (subst (cons 1 S) (assoc 1 d) d)
)
(entmod d)
(setq i (1+ i))
)
(setvar "dimzin" oldDimzin)
(princ)
)

http://www.cadviet.com/upfiles/3/40304_ltt_n.lsp

http://www.cadviet.com/upfiles/3/40304_tgl.lsp


<<

Filename: 255806_tgl.lsp
Tác giả: thanhduan2407
Bài viết gốc: 255744
Tên lệnh: vn
Nhờ các bác chỉnh hộ Lisp vẽ hình chữ nhật

Không biết ý của chủ thớt có phải là vẽ nhà không nhỉ?

Mình viết cái Lisp vẽ nhà này lâu rồi.

Bạn thử xem có ổn không? Cần chỉnh sửa gì ko?

(defun c:vn() ;Ve nha
  (command "un" "be")
  (setq i 1)
  (while
    (progn
  	(command "osnap" "cen,end,mid,node")
	(setq P1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 nh\U+1EA5t: ")
	      P2 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9...
>>

Không biết ý của chủ thớt có phải là vẽ nhà không nhỉ?

Mình viết cái Lisp vẽ nhà này lâu rồi.

Bạn thử xem có ổn không? Cần chỉnh sửa gì ko?

(defun c:vn() ;Ve nha
  (command "un" "be")
  (setq i 1)
  (while
    (progn
  	(command "osnap" "cen,end,mid,node")
	(setq P1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 nh\U+1EA5t: ")
	      P2 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 hai: ")
	      P3a (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 ba ")
	)
  	(setq Phia (CCW P1 P2 P3a))
	(setq  D23 (distance P2 P3a))
        (setq Goc12 (angle P1 P2))
        (setq Goc21 (angle P2 P1))
        (if (= Phia "PH")
	  (progn
	      (setq P4 (polar P1 (+ Goc12 (DTR 270)) D23)
	            P3 (polar P2 (+ Goc21 (DTR 90)) D23)
	      )
	  )
	  (progn
	      (setq P4 (polar P1 (+ Goc12 (DTR 90)) D23)
	            P3 (polar P2 (+ Goc21 (DTR 270)) D23)
	      )
	  )
	)
  	(setq TD (list (/ (+ (car p1) (car P3)) 2)(/ (+ (cadr p1) (cadr P3)) 2)))
  	(if (< (distance p1 p2) (distance p2 p3))
	  (progn
	  	(setq TD1 (list (/ (+ (car p1) (car P2)) 2)(/ (+ (cadr p1) (cadr P2)) 2)))
	  	(setq TD2 (list (/ (+ (car p3) (car P4)) 2)(/ (+ (cadr p3) (cadr P4)) 2)))
	  	(setq K1 (polar TD1 (angle TD1 TD2) (/ (distance TD1 TD2) 3)))
	  	(setq K2 (polar TD1 (angle TD1 TD2) (* 2 (/ (distance TD1 TD2) 3))))
  	  	(command "osnap" "off")
	  	(command "pline" p1 p2 p3 p4 p1 "")
	  	(command "pline" p1 k1 k2 p3 "")
		(command "pline" p2 k1 k2 p4 "")
	  )
	  (progn
	  	(setq TD1 (list (/ (+ (car p3) (car P2)) 2)(/ (+ (cadr p3) (cadr P2)) 2)))
	  	(setq TD2 (list (/ (+ (car p1) (car P4)) 2)(/ (+ (cadr p1) (cadr P4)) 2)))
	  	(setq K1 (polar TD1 (angle TD1 TD2) (/ (distance TD1 TD2) 3)))
	  	(setq K2 (polar TD1 (angle TD1 TD2) (* 2 (/ (distance TD1 TD2) 3))))
  	  	(command "osnap" "off")
	  	(command "pline" p1 p2 p3 p4 p1 "")
	  	(command "pline" p1 k2 k1 p3 "")
		(command "pline" p2 k1 k2 p4 "")
	  )
	)
        (setq i (+ i 1))
      )
    )
  (command "un" "end")
  (princ)
)

(defun CCW  (P1 P2 P /) ;Xac dinh diem P nam ben trai hay phai doan thang P1 P2
  (setq BP "PH")
  (setq BT "TR" )
  (setq dX  ( - (car P) (car P1))
	dY  ( - (cadr P) (cadr P1))
	dX0 ( - (car P2) (car P1))
	dY0 ( - (cadr P2) (cadr P1))
	d   ( - (* dX dY0) (* dY dX0))
  )
  (if (> d 0)
    BP
    BT
  )
)
(defun DTR (A) (/ (* A pi) 180)) ; Degrees to Radian

 


<<

Filename: 255744_vn.lsp

Trang 143/303

143