Bạn thử cái này xem sao: (Không biết cad2014 và cad2015 có khác nhau hay không?)

(defun c:N1+N2 (/...
>>

Bạn thử cái này xem sao: (Không biết cad2014 và cad2015 có khác nhau hay không?)

(defun c:N1+N2 (/ ss)

(vl-load-com)

(if (setq ss (ssget '((0 . "*line,arc"))))

(if (< (atof (substr (getvar "acadver") 1 4)) 20.0)

(vl-cmdf ".pedit" "m" ss "" "y" "j" "0" "")

(vl-cmdf ".pedit" "m" ss "" "j" "0" "")))

(princ))

Không được bác ạ. Với 2 pline thì được nhưng cứ có line là lại yêu cầu convert.

<<

Download lisp

Filename: 374223_n1%2Bn2.lsp

Chào study_forever

Lisp trên đã được Tue_NV hoàn thiện lại :

(defun c:cpp( / ss frome toe cur obj po1 po2)
(Command "undo" "be")
(setq frome...
>>

Chào study_forever

Lisp trên đã được Tue_NV hoàn thiện lại :

(defun c:cpp( / ss frome toe cur obj po1 po2)
(Command "undo" "be")
(setq frome (entlast));;
(Prompt "\nChon doi tuong :")
(setq obj (ssget))
(sssetfirst obj obj)
(setq po1 (getpoint "\n Base point : "))
(command "line" '(0 0 0) '(1 1 1) "")
(setq obj (ssadd (entlast) obj))

(command "copy" obj "" po1)
(while (< 0 (getvar "CMDACTIVE")) (command pause))

(setq dc (cdr(assoc 10 (entget (entlast)))))
(setq obj (ssdel (entlast) obj))
(entdel (entlast))
(setq kc (distance '(0 0 0) dc))
(setq ang (angle '(0 0 0) dc))
(setq po2 (polar po1 ang kc))

(setq toe (entlast))

(setq cur frome
ss (ssadd)
)
(while (not (eq cur toe))
(setq
cur (entnext cur)
ss (ssadd cur ss)
)
)

(setq po1 po2)

(while po2
 (setq frome (entlast))
(command "line" '(0 0 0) '(1 1 1) "")
(setq ss (ssadd (entlast) ss))
(command "copy" ss "" po1)
   	 (while (< 0 (getvar "CMDACTIVE")) (command pause))
  	(setq dc (cdr(assoc 10 (entget (entlast)))))
(setq ss (ssdel (entlast) ss))
(entdel (entlast))
(setq kc (distance '(0 0 0) dc))
(setq ang (angle '(0 0 0) dc))
(setq po2 (polar po1 ang kc))
(setq toe (entlast))
(setq cur frome; khoi tao
ss (ssadd)
)
(while (not (eq cur toe))
(setq
cur (entnext cur)
ss (ssadd cur ss)
)
)
(setq po1 po2)
)
(Command "undo" "end")
(princ)
)

Chúc các bạn một buổi sáng tốt lành

Edit : Chức năng Download Lisp File của diễn đàn bị lỗi -> bạn hãy nhấn nút Reply bài viết này của Tue_NV -> copy hết code này về chạy thử nhé

:undecided:

Sử dụng lệnh chọn lai đối tượng vừa copy xong cua ban TUE_VNC thi ok...nhung ma dung lenh copy tham so m...de copy nhieu doi tuong thi lai.....ko dc..TUE oi giup minh voi....??? co cach nao thoa man ca hai ko nhi?????

<<

Đây em

(defun c:hcncheo( / ANG ANG1 DIST E ENT ENTS H L1 L2 LISTDINH NAME OBJ...
>>

Đây em

(defun c:hcncheo( / ANG ANG1 DIST E ENT ENTS H L1 L2 LISTDINH NAME OBJ P1 P2 P3 P4 P5 P6 PARAM PE PS PT)
(setq ents (entsel "\nPick entity"))
(if (null ents) (exit))
(setq pt (cadr ents)
      ent (car ents)
      name (acet-dxf 0 (entget ent)))
(if (null (or (= name "LWPOLYLINE")
	(= name "LINE"))
	  )
  (exit)
  )
(if (= name "LWPOLYLINE")
(setq obj (vlax-ename->vla-object ent)
      pt (vlax-curve-getclosestpointto obj pt)
      param (fix (vlax-curve-getParamAtPoint obj pt))
      ps (vlax-curve-getPointAtParam obj param)
      pe (vlax-curve-getPointAtParam obj (+ param 1))
      )
  )
(if (= name "LINE")
  (setq ps (acet-dxf 10 (entget ent))
	pe (acet-dxf 11 (entget ent))
	)
  )

(setq p1 (if (< (car ps) (car pe)) ps pe)
      p2 (if (< (car ps) (car pe)) pe ps)
      ang (angle p1 p2)
      ang1 (+ ang (* pi 0.5))
      dist (DISTANCE p1 p2))
(alert (strcat "L= "  (rtos dist 2 2)))
(setq l1 (getdist "\nL1:"))
(setq l2 (getdist "\nL2:"))
(if (> (+ l1 l2) dist)
  (alert "Tong L1 + L2  qua lon")
  )
(setq h (getdist "\nH:"))

(setq p3 (polar p1 ang l1)
      p4 (polar p2 ang (- 0 l2))
      p5 (polar p4 ang1 h)
      p6 (polar p3 ang1 h)
      )

(DEFUN make_lwpolyline  (list_dinh dong_lai do_day layer / dlist elist1 e_list n i)
  (SETQ n (LENGTH list_dinh))
  (SETQ dlist nil)
  (SETQ i 0)
  (WHILE (< i n)
    (SETQ dlist (APPEND dlist
                        (list_point_pline (NTH i list_dinh) do_day)
                        )
          )
    (SETQ i (1+ i))
    )

  (SETQ elist1 (LIST (CONS 0 "LWPOLYLINE")
                     (CONS 100 "AcDbEntity")
                     (CONS 410 "Model")
                     (CONS 8 layer)
                     (CONS 100 "AcDbPolyline")
                     (CONS 90 n)
                     (CONS 70 dong_lai)
 ;(cons 43 0.0)
                     (CONS 38 0.0)
                     (CONS 39 0.0)))
  (SETQ e_list nil)
  (SETQ e_list (APPEND elist1 dlist))
  (SETQ e_list (APPEND e_list (LIST '(210 0.0 0.0 1.0))))
  (ENTMAKE e_list)
  )

(DEFUN make_dim_y1  (style p1 p2 p3  ang layer / d e_list basepoint p4)
  
  (SETQ e_list (LIST
                 (CONS 0 "DIMENSION")
                 (CONS 100 "AcDbEntity")
                 (CONS 67 0)
                 (CONS 410 "Model")
                 (CONS 8 layer)
                 (CONS 100 "AcDbDimension")
                 (cons 10 p3)
                 (cons 11 p3)
                 (LIST 12 0.0 0.0 0.0)
                 (CONS 70 32)
                 (CONS 1 "")
                 (CONS 71 5)
                 (CONS 72 1)
                 (CONS 41 1.0)
                 (CONS 42 0)
                 (CONS 52 0.0)
                 (CONS 53 0.0)
                 (CONS 54 0.0)
                 (CONS 51 0.0)
                 (LIST 210 0.0 0.0 1.0)
                 (CONS 3 style)
                 (CONS 100 "AcDbAlignedDimension")
                 (cons 13 p1)
                 (cons 14 p2)
                 (LIST 15 0.0 0.0 0.0)
                 (LIST 16 0.0 0.0 0.0)
                 (CONS 40 0.0)
                 (CONS 50 ang)
                 (CONS 100 "AcDbRotatedDimension")
		 )
        )
  (ENTMAKE e_list)


  )

(setq listdinh (mapcar '(lambda (e) (list (car e) (cadr e))
			  )
		       (list p3 p4 p5 p6))
      )
(MAKE_LWPOLYLINE listdinh 1 0 "chunhat")

(MAKE_DIM_Y1 "Standard" p3 p6 (polar p1 (- 0 ang) (+ h h)) ang1 "dim")
(MAKE_DIM_Y1 "Standard" p1 p3 (polar p1 ang1 (+ h h)) ang  "dim")
(MAKE_DIM_Y1 "Standard" p4 p2 (polar p1 ang1 (+ h h)) ang  "dim")


)

(defun c:hcncheo( / ANG ANG1 DIST E ENT ENTS H L1 L2 LISTDINH NAME OBJ P
>>

(defun c:hcncheo( / ANG ANG1 DIST E ENT ENTS H L1 L2 LISTDINH NAME OBJ P1 P2 P3 P4 P5 P6 PARAM PE PS PT)
(setq ents (entsel "\nPick entity"))
(if (null ents) (exit))
(setq pt (cadr ents)
      ent (car ents)
      name (acet-dxf 0 (entget ent)))
(if (null (or (= name "LWPOLYLINE")
	(= name "LINE"))
	  )
  (exit)
  )
(if (= name "LWPOLYLINE")
(setq obj (vlax-ename->vla-object ent)
      pt (vlax-curve-getclosestpointto obj pt)
      param (fix (vlax-curve-getParamAtPoint obj pt))
      ps (vlax-curve-getPointAtParam obj param)
      pe (vlax-curve-getPointAtParam obj (+ param 1))
      )
  )
(if (= name "LINE")
  (setq ps (acet-dxf 10 (entget ent))
	pe (acet-dxf 11 (entget ent))
	)
  )

(setq p1 (if (< (car ps) (car pe)) ps pe)
      p2 (if (< (car ps) (car pe)) pe ps)
      ang (angle p1 p2)
      ang1 (+ ang (* pi 0.5))
      dist (DISTANCE p1 p2))
(alert (strcat "L= "  (rtos dist 2 2)))
(setq l1 (getdist "\nL1:"))
(setq l2 (getdist "\nL2:"))
(if (> (+ l1 l2) dist)
  (alert "Tong L1 + L2  qua lon")
  )
(setq h (getdist "\nH:"))

(setq p3 (polar p1 ang l1)
      p4 (polar p2 ang (- 0 l2))
      p5 (polar p4 ang1 h)
      p6 (polar p3 ang1 h)
      )
(DEFUN list_point_pline  (p1 w)
  (LIST (LIST 10 (CAR p1) (CADR p1)) (CONS 40 w) (CONS 41 w) (CONS 42 0.0))
  )
(DEFUN make_lwpolyline  (list_dinh dong_lai do_day layer / dlist elist1 e_list n i)
  (SETQ n (LENGTH list_dinh))
  (SETQ dlist nil)
  (SETQ i 0)
  (WHILE (< i n)
    (SETQ dlist (APPEND dlist
                        (list_point_pline (NTH i list_dinh) do_day)
                        )
          )
    (SETQ i (1+ i))
    )

  (SETQ elist1 (LIST (CONS 0 "LWPOLYLINE")
                     (CONS 100 "AcDbEntity")
                     (CONS 410 "Model")
                     (CONS 8 layer)
                     (CONS 100 "AcDbPolyline")
                     (CONS 90 n)
                     (CONS 70 dong_lai)
 ;(cons 43 0.0)
                     (CONS 38 0.0)
                     (CONS 39 0.0)))
  (SETQ e_list nil)
  (SETQ e_list (APPEND elist1 dlist))
  (SETQ e_list (APPEND e_list (LIST '(210 0.0 0.0 1.0))))
  (ENTMAKE e_list)
  )

(DEFUN make_dim_y1  (style p1 p2 p3  ang layer / d e_list basepoint p4)
  
  (SETQ e_list (LIST
                 (CONS 0 "DIMENSION")
                 (CONS 100 "AcDbEntity")
                 (CONS 67 0)
                 (CONS 410 "Model")
                 (CONS 8 layer)
                 (CONS 100 "AcDbDimension")
                 (cons 10 p3)
                 (cons 11 p3)
                 (LIST 12 0.0 0.0 0.0)
                 (CONS 70 32)
                 (CONS 1 "")
                 (CONS 71 5)
                 (CONS 72 1)
                 (CONS 41 1.0)
                 (CONS 42 0)
                 (CONS 52 0.0)
                 (CONS 53 0.0)
                 (CONS 54 0.0)
                 (CONS 51 0.0)
                 (LIST 210 0.0 0.0 1.0)
                 (CONS 3 style)
                 (CONS 100 "AcDbAlignedDimension")
                 (cons 13 p1)
                 (cons 14 p2)
                 (LIST 15 0.0 0.0 0.0)
                 (LIST 16 0.0 0.0 0.0)
                 (CONS 40 0.0)
                 (CONS 50 ang)
                 (CONS 100 "AcDbRotatedDimension")
		 )
        )
  (ENTMAKE e_list)


  )

(setq listdinh (mapcar '(lambda (e) (list (car e) (cadr e))
			  )
		       (list p3 p4 p5 p6))
      )
(MAKE_LWPOLYLINE listdinh 1 0 "chunhat")

(MAKE_DIM_Y1 "Standard" p3 p6 (polar p1 (- 0 ang) (+ h h)) ang1 "dim")
(MAKE_DIM_Y1 "Standard" p1 p3 (polar p1 ang1 (+ h h)) ang  "dim")
(MAKE_DIM_Y1 "Standard" p4 p2 (polar p1 ang1 (+ h h)) ang  "dim")


)

thử lại nhé

Hàm round vẫn chạy tốt, và cũng không mất thời gian! Bạn thử với lisp sau xem, trong đó có sử dụng hàm round. Tên lệnh NK:

 

>>

Hàm round vẫn chạy tốt, và cũng không mất thời gian! Bạn thử với lisp sau xem, trong đó có sử dụng hàm round. Tên lệnh NK:

 

;;;-------------------------------------------------------
(defun round(x i / j)
   (setq j (expt 10 i))
   (/ (float (fix (+ 0.5 (* x j)))) j) 
)
;;;-------------------------------------------------------
(defun C:NK( / ss k e d v1 v2)
(setq
   ss (ssget '((0 . "TEXT")))
   k (getreal "\nNhan voi he so k = ")
)
(while (setq e (ssname ss 0))
   (setq
       d (entget e)
       v1 (atof (cdr (assoc 1 d)))
       v2 (round (* k v1) 2)
       d (subst (cons 1 (rtos v2)) (assoc 1 d) d)
   )
   (entmod d)
   (ssdel e ss)
)
(princ)
)
;;;-------------------------------------------------------

 

Có lẽ có một sự hiểu lầm, ssg đã nghĩ rằng đoạn lisp bạn post là của bạn viết ra. Đã viết được như vậy đương nhiên sẽ biết cách đưa hàm round vào chương trình. Ssg không làm đến nơi đến chốn không phải vì... lười biếng mà có ý khuyến khích tất cả các bạn tự lập trình cho mình. Nếu có vướng mắc, ssg cũng như các bạn đã tương đối thành thạo Lisp trên diễn đàn sẽ trợ giúp.

Nếu bạn thật sự chưa biết về lập trình lisp, khi có nhu cầu, cứ nêu yêu cầu bạn muốn hơn là post lên một đoạn lisp của ai đó không biết, không đúng ý bạn. Xin nói rõ hơn để bạn hiểu: lập một chương trình mới tốn chừng 1/5 đến 1/10 thời gian dò và sửa một chương trình có sẵn bị lỗi hoặc hoạt động không đúng ý user!

Lisp của bác SSG chạy lỗi trong trường hợp hệ số k=0 và nó chưa có thể định dạng phía sau dấu phẩy hai chữ số ( cho kết quả bằng 0 chứ ko phải 0.00 , hoặc khi Text = 5 nhân thêm k=2 vào nó cho kết quả = 10 chứ ko phải 10,00 ) mong bác sửa giúp em được ko ? Vì em không biết viết Lisp. Cảm ơn bác nhìu nhé !!!!!!!!

<<

(defun C:00	(/ DAITHEP NDUNG OBJTHEPDAI PNTDAT)
	(vl-load-com)
	(defun *error* (msg)
		(if	Olmode
			(setvar 'osmode Olmode)
		)
		(if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
			(princ (strcat "\nError: " msg))
		)
		(princ)
	)
	(setvar 'CMDECHO 0)
	(setq Olmode (getvar "OSMODE"))
	(setvar "OSMODE" 0)
	(setq	ObjThepdai
				 (car
					 (LM:SelectIf
						 "\nCh\U+1ECDn th\U+00E9p \U+0111ai "
						 (lambda...
>>

(defun C:00	(/ DAITHEP NDUNG OBJTHEPDAI PNTDAT)
	(vl-load-com)
	(defun *error* (msg)
		(if	Olmode
			(setvar 'osmode Olmode)
		)
		(if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
			(princ (strcat "\nError: " msg))
		)
		(princ)
	)
	(setvar 'CMDECHO 0)
	(setq Olmode (getvar "OSMODE"))
	(setvar "OSMODE" 0)
	(setq	ObjThepdai
				 (car
					 (LM:SelectIf
						 "\nCh\U+1ECDn th\U+00E9p \U+0111ai "
						 (lambda (x)
							 (or (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))
									 (eq "POLYLINE" (cdr (assoc 0 (entget (car x)))))
									 (eq "LINE" (cdr (assoc 0 (entget (car x)))))
							 )
						 )
						 entsel
						 nil
					 )
				 )
	)
	(setq Daithep (length1 ObjThepdai))
	(setq	Kyhieuthep
				 (LM:GetXWithDefault_New
					 getstring "\nNh\U+1EADp k\U+00FD hi\U+1EC7u thanh th\U+00E9p "	'*Kyhieuthep*	"2"	nil	nil)
	)
	(setq	Duongkinh
				 (LM:GetXWithDefault_New
					 getdist "\nNh\U+1EADp \U+0111\U+01B0\U+1EDDng k\U+00EDnh "	'*Duongkinh* 10.0	nil	nil)
	)
	(setq	Kcrd
				 (LM:GetXWithDefault_New
					 getdist "\nNh\U+1EADp kho\U+1EA3ng c\U+00E1ch r\U+00E3nh \U+0111ai "	'*Kcrd*	150.0	nil	nil)
	)
	(setq	Caochu
				 (LM:GetXWithDefault_New
					 getdist "\nNh\U+1EADp kho\U+1EA3ng c\U+00E1ch r\U+00E3nh \U+0111ai "	'*Caochu*	100.0	nil	nil)
	)
	(setq	Ndung	(strcat	"-"
											(rtos (/ Daithep Kcrd) 2 0)
											"d"
											(rtos Duongkinh 2 0)
											"a"
											(rtos Kcrd 2 0)
											"-L="
											(rtos Daithep 2 0)
							)
	)
	(setq PntDat (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m ghi Text:\n"))
	(MakeText PntDat Ndung Caochu 0 "MC" nil nil nil)
	(setvar "OSMODE" Olmode)
	(princ)
)
(defun Length1 (e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(defun MakeText	(point string Height Ang justify Layer Style Color / Lst)
																														; Ang: Radial
	(setq	Lst			(list	'(0 . "TEXT")
											(cons 10 point)
											(cons 40 Height)
											(cons	8
														(if	Layer
															Layer
															(getvar "CLAYER")
														)
											)
											(cons 1 string)
											(if	Ang
												(cons 50 Ang)
											)
											(cons	7
														(if	Style
															Style
															(getvar "Textstyle")
														)
											)
											(cons	62
														(if	Color
															Color
															256
														)
											)
								)
				justify	(strcase justify)
	)
	(cond
		((= justify "C")
		 (setq Lst (append Lst (list (cons 72 1) (cons 11 point))))
		)
		((= justify "L")
		 (setq
			 Lst
				(append Lst (list (cons 72 0) (cons 73 0) (cons 10 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)
)
(defun LM:SelectIf (msg pred func keyw / sel)
	(setq pred (eval pred))
	(while
		(progn
			(setvar 'ERRNO 0)
			(if	keyw
				(apply 'initget keyw)
			)
			(setq sel (func msg))
			(cond
				((= 7 (getvar 'ERRNO))
				 (princ
					 "\nB\U+1EA1n ch\U+1ECDn sai r\U+1ED3i! H\U+00E3y ch\U+1ECDn l\U+1EA1i."
				 )
				)
				((eq 'STR (type sel))
				 nil
				)
				((vl-consp sel)
				 (if (and pred (not (pred sel)))
					 (princ "")
				 )
				)
			)
		)
	)
	sel
)

;; GetX with Default  -  Lee Mac
;; fun -  Quoted user input function
;; pmt -  Prompt string
;; sym -  Quoted function to hold default value (not 'sym)
;; def -  Initial default value
;; ini -   List of initget arguments
;; arg -   List of arguments for user input function
;; Returns:  User input or default value

;;;;;;  (LM:GetXWithDefault_New getkword "\nEnter an Option  " '*opt* "Alpha" '("Alpha Beta Gamma") nil)
;;;;;;  (LM:GetXWithDefault_New getstring "\nEnter a String " '*str* "Lee Mac" nil '(T))
(defun LM:GetXWithDefault_New	(_function _prompt _symbol _default _initget _args / _toString)
	(vl-load-com)
	;; © Lee Mac 2010

	(setq	_toString
				 (lambda (x)
					 (cond
						 ((eq getangle _function) (angtos x))
						 ((eq 'REAL (type x)) (rtos x))
						 ((eq 'INT (type x)) (itoa x))
						 ((vl-princ-to-string x))
					 )
				 )
	)

	(if	_initget
		(apply 'initget _initget)
	)

	(set _symbol
			 (
				(lambda	(input)
					(if	(or (not input) (eq "" input))
						(eval _symbol)
						input
					)
				)
				 (apply	'_function
								(append	_args
												(list
													(strcat	_prompt
																	"<"
																	(_toString
																		(set _symbol
																				 (cond
																					 ((eval _symbol))
																					 (_default)
																				 )
																		)
																	)
																	"> : "
													)
												)
								)
				 )
			 )
	)
)
 

Giúp bạn chút. Còn sửa như thế nào thì nhờ mng sửa. Mình tranh thủ tý thôi

Tạo text mới thì không nên, lý do : style, height , widthfactor có thể khác nhau ở mỗi bản vẽ sinh ra tạo text không như ý muốn.

(DEFUN c:tg  ( / LOAITEXT NOIDUNG OLD SS TEXT...
>>

Tạo text mới thì không nên, lý do : style, height , widthfactor có thể khác nhau ở mỗi bản vẽ sinh ra tạo text không như ý muốn.

(DEFUN c:tg  ( / LOAITEXT NOIDUNG OLD SS TEXT TONGDAI)
  (SETQ ss (ACET-SS-TO-LIST (SSGET '((0 . "*LINE")))))
  (SETQ ss (MAPCAR 'VLAX-ENAME->VLA-OBJECT ss))
  (SETQ tongdai 0)
  (FOREACH n ss (SETQ tongdai (+ tongdai (VLA-GET-LENGTH n))))

  (SETQ text (ENTGET (CAR (ENTSEL "Append to: "))))
  (SETQ loaitext (ACET-DXF 0 text))
  (IF (OR
        (= loaitext "TEXT")
        (= loaitext "MTEXT")
        )
    (PROGN
      (SETQ old (ASSOC 1 text))
      (SETQ noidung (STRCAT (CDR old) ", L= " (RTOS (/ tongdai 1000) 2 2) " m"))

      (SETQ text (SUBST (CONS 1 noidung) old text))
      (ENTMOD text)

      )
    (ALERT "Vui long chon vao Text or Mtext")
    )
  (PRINC)
  )

Mình sửa cho bạn rồi này. Bạn tự nghiên cứu xem mình sai chỗ nào nhé. Có gì thắc mắc thì tiếp tục reply

;; free lisp from...
>>

Mình sửa cho bạn rồi này. Bạn tự nghiên cứu xem mình sai chỗ nào nhé. Có gì thắc mắc thì tiếp tục reply

;; free lisp from cadviet.com
(defun C:dvc (/ GOC1 dx dy temp-1 temp-2 GOC2 TAM temp3 temp4)
  (setq dx     (getdist "\nChieu dai canh theo truc x: ")
    dy     (getdist "\nChieu dai canh theo theo truc y: ")
   GOC1 (getpoint "\nDiem dat.: ")
    GOC2     (list (+ (car GOC1) dx) (+ (cadr GOC1) dy) 0)
    TAM     (list (+ (car GOC1) (/ dx 2)) (+ (cadr GOC1) (/ dy 2)) 0)
    )
(taolayer "KCVN-CAT" "30" "0.3")
(setvar "clayer" "KCVN-CAT")
  (vl-cmdf "._RECTANGLE" "_non" GOC1 "D" dx dy "_non" GOC2);1
  (setq temp3 (entlast));2
  (vl-cmdf "hatch" "ansi31" "200" "" temp3 "");3
  (setq temp4 (entlast));4
  (vl-cmdf  "_.copy" temp3 temp4 "" "m" TAM pause);5
   )

Ôi,hóa ra mình thiếu 1 dấu "".Hức..Mình chưa bết cần bao nhiêu đối số cho lệnh h :(

Còn dòng 5,mình thấy vẫn nguyên,n lại giải quyết được lỗi Unknown M command.Phải chăng lỗi này là do hệ lụy của dòng 3 lúc trước chưa chuẩn?

Nhờ mọi người hướng dẫn mình cách move 1 đối tượng theo trục,và cách đặt chân dim cách đối tượng 1 khoảng cố định cho trước với

<<

Theo tôi thì Cad chắc chịu. Không biết ai có cao kiến gì không.

Đây là lisp thỏa mãn nhu cầu của bạn:

>>

Theo tôi thì Cad chắc chịu. Không biết ai có cao kiến gì không.

Đây là lisp thỏa mãn nhu cầu của bạn: Fillet rút gọn.

;Doan Van Ha - CADViet.com - Ngay 01/01/2013
;Chuc nang: Fillet rut gon.
(defun C:HA()
(or bk (setq bk 100))
(setq bk (cond ((getdist (strcat "\nNhap ban kinh <" (rtos bk 2) ">"))) (bk)))
(command "fillet" "R" bk "fillet" (entsel "\nChon object 1: ") (entsel "\nChon object 2: "))
(princ))

 

 

Lisp có vẻ không ổn lắm, em tải lisp về rồi nhưng khi sử dụng thì nó lại không bo. dòng lệnh nó hiện lên khi em sử dụng lệnh như sau

ha enter

Select first object or :

Chọn object 1 :

Chọn Object 2 :

cuối cùng em enter thì lại hiện ra command: ???

Nhờ Anh hướng dẫn.

<<

các bạn choi hỏi, lisp này bị sao mà không dùng được trong CAD2010, trong khi trong CAD2008 vẫn dung bình thường

(defun c:fr()
 (graphscr)
 (setvar "Cmdecho" 0)
...
>>

các bạn choi hỏi, lisp này bị sao mà không dùng được trong CAD2010, trong khi trong CAD2008 vẫn dung bình thường

(defun c:fr()
 (graphscr)
 (setvar "Cmdecho" 0)
 (Princ "FILLET\n")
 (command "_.Fillet" "_mUltiple" "_Radius")
 (setvar "Cmdecho" 1)
 (princ)
 )

 

CAD08 :

gõ lệnh fr --> nhập bán kính --> chọn 2 đối tượng là line giao nhau cần bo tròn góc

 

CAD10:

gõ lệnh fr--> nhập bán kính --> thoát lệnh.

 

vậy là sao hả mọi người. Xin được chỉ giáo.

Sau hàng (Princ "FILLET\n")

Bạn sửa lại như sau:

(setvar "filletrad" (getreal "\nRadius: "))

(command "_.Fillet" "_mUltiple" pause pause)

<<

Dim dưới và phải.

(defun c:test ( / CENT ENT P1 P1A P2 P
>>

Dim dưới và phải.

(defun c:test ( / CENT ENT P1 P1A P2 P2A RAD)
(setq ent (entget (car (entsel))))
(setq cent (acet-dxf 10 ent)
      rad (acet-dxf 40 ent)
      p1 (polar cent 0 rad)
      p1a (polar cent 0 ( * rad 1.2))
      p2 (polar cent (* pi 1.5) rad)
      p2a (polar cent (* pi 1.5) ( * rad 1.2))
      )
(command "dimordinate" p1 p1a)
(command "dimordinate" p2 p2a)
)

Lệnh po0: tạo điểm quy chiếu, (giống như dời điểm gốc hệ toạ độ (0 0 0) về điểm này)

Lệnh TDT: tạo DimOrdinate cho CIRCLE, ARC

;;;Lisp AdddimOrdinate cho tâm CIRCLE, ARC         by Trân Thiêp 10/2021, tel 0918841230
(defun c:po0 (/)
    (setq po0
             (getpoint '(0 0 0)
                 "\nPick 1 \U+0111i\U+1EC3m to\U+1EA1 \U+0111\U+1ED9 quy...
>>

Lệnh po0: tạo điểm quy chiếu, (giống như dời điểm gốc hệ toạ độ (0 0 0) về điểm này)

Lệnh TDT: tạo DimOrdinate cho CIRCLE, ARC

;;;Lisp AdddimOrdinate cho tâm CIRCLE, ARC         by Trân Thiêp 10/2021, tel 0918841230
(defun c:po0 (/)
    (setq po0
             (getpoint '(0 0 0)
                 "\nPick 1 \U+0111i\U+1EC3m to\U+1EA1 \U+0111\U+1ED9 quy chi\U+1EBFu"
             )
    )
)
(defun c:tdt (/ doc      *model   ucs_old  po13_1   po14_1   po13_2   po14_2
                90d      270d     360d     ent      centpo   eng      ang
                R        obdX     obdY     engX     engY     entodimX entodimY
                sel      popick
               )
    (setq doc    (vla-get-ActiveDocument (vlax-get-acad-object))
          *model (vla-get-modelspace doc)
    )
    (defun *error* (msg)
        (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
            (princ (strcat "\n** Error: " msg " **"))
        )
        (acet-sysvar-restore)
        (vla-EndUndoMark doc)
        (princ)
    )
    (vla-StartUndoMark doc)
    (acet-sysvar-set (list "cmdecho" 0 "osmode" 33))
    (setq ucs_old (acet-ucs-get nil))
    (acet-ucs-cmd '("w"))
    (setq 90d  (/ pi 2)
          360d (* pi 2)
          270d (* 90d 3)
    )
    (or po0 (setq po0 (getpoint "\nPick 1 \U+0111i\U+1EC3m to\U+1EA1 \U+0111\U+1ED9 quy chi\U+1EBFu")))
    (setvar "osmode" 0)
    (while
        (OR (NOT (setq sel (entsel "\nPick a CIRCLE, ARC")))
            (NOT (wcmatch (acet-dxf 0 (setq eng (entget (setq ent (car sel)))))
                          "CIRCLE,ARC"
                 )
            )
        )  (prompt "\nPick ch\U+01B0a Ðúng CIRCLE, ARC vui lòng pick l\U+1EA1i")
    )
    (setq popick (cadr sel))
    (setq centpo (trans (acet-dxf 10 eng) 0 1)
          R      (acet-dxf 40 eng)
    )
    (setq ang (angle centpo popick))
    (cond ((< 0 ang 90d)
           (setq po13_1 (polar centpo 0 R)
                 po14_1 (polar po13_1 0 10)
                 po13_2 (polar centpo 90d R)
                 po14_2 (polar po13_2 90d 10)
           )
          )
          ((< 90d ang pi)
           (setq po13_1 (polar centpo pi R)
                 po14_1 (polar po13_1 pi 10)
                 po13_2 (polar centpo 90d R)
                 po14_2 (polar po13_2 90d 10)
           )
          )
          ((< pi ang 270d)
           (setq po13_1 (polar centpo pi R)
                 po14_1 (polar po13_1 pi 10)
                 po13_2 (polar centpo 270d R)
                 po14_2 (polar po13_2 270d 10)
           )
          )
          ((< 270d ang 360d)
           (setq po13_1 (polar centpo 0 R)
                 po14_1 (polar po13_1 0 10)
                 po13_2 (polar centpo 270d R)
                 po14_2 (polar po13_2 270d 10)
           )
          )
    )
    (setq obdX (vla-AddDimOrdinate *model
                                   (vlax-3d-point (trans po13_1 1 0))
                                   (vlax-3d-point (trans po14_1 1 0))
                                   :vlax-false
               )
    )
    (setq obdY (vla-AddDimOrdinate *model
                                   (vlax-3d-point (trans po13_2 1 0))
                                   (vlax-3d-point (trans po14_2 1 0))
                                   :vlax-true
               )
    )
    (setq engX (entget (setq entodimX (vlax-vla-object->ename obdX))))
    (entmod (subst (cons 10 po0) (assoc 10 engX) engX))
    (entupd entodimX)
    (setq engY (entget (setq entodimY (vlax-vla-object->ename obdY))))
    (entmod (subst (cons 10 po0) (assoc 10 engY) engY))
    (entupd entodimY)
    (acet-sysvar-restore)
    (acet-ucs-set ucs_old)
    (vla-EndUndoMark doc)
    (princ "\nOk")
    (princ)
)

Chúc vui vẻ. Thiep

(defun c:mocranhgioi ( / ENT I LS MODELSPACE N P1 P2)
  (if
>>

(defun c:mocranhgioi ( / ENT I LS MODELSPACE N P1 P2)
  (if (not (tblsearch "block" "mocranhgioi"))
    (progn
      (entmake '((0 . "BLOCK")(2 . "mocranhgioi")(70 . 2)(10 0.0 0.0 0.0)))
      (entmake '((0 . "LINE")(8 . "0") (10 -0.7 0.0 0.0) (11 0.7 0.0 0.0)))
      (entmake '((0 . "LINE")(8 . "0") (10 0.0 0.7 0.0) (11 0.0 -0.7 0.0)))
      (entmake '((0 . "CIRCLE")(8 . "0") (10 0.0 0.0 0.0) (40 . 0.7)))
      
      (entmake '((0 . "ENDBLK")))
      ))
    
  
(setq ent (car (entsel)))
 
(setq modelSpace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq ls (car(acet-pline-segment-list (entget ent)))
      n (length ls)
      i 0)
(while (< i (- n 1))
  
    (progn
      (setq p1 (vlax-3d-point (nth i ls))
            p2 (vlax-3d-point (nth (+ i 1) ls))
            )
     (vla-AddDimAligned modelSpace p1 p2 p2)
     (vla-InsertBlock modelSpace p1 "mocranhgioi" 1 1 1 0)
     )
   
  (setq i (1+ i))
  )
  )
                  

6 giờ trước, alisp đã nói:

Cái block của tôi nó đẹp như thế mà bạn nỡ nào dời điểm chèn nó tít tận đâu đâu để làm gì vậy? Nó vẫn chèn đó chứ nhưng do điểm chèn không đúng nên zoom all mới thấy.

Hay là bạn muốn vẽ cái circle và hatch thay vì block? Nếu vậy chờ người khác viết cho bạn nhé.

Nên code thêm block vào, vì trong bản vẽ không phải lúc nào cũng có block đó.

file mới nhất đây, mời các ae ra tay giúp dùm

http://www.mediafire.com/?0h7ywyo99wi0w1w

Mọi ghi chú...

>>

file mới nhất đây, mời các ae ra tay giúp dùm

http://www.mediafire.com/?0h7ywyo99wi0w1w

Mọi ghi chú đều có trong file trên. Mọi người xem giúp cái . Thanks

Nếu đường không cong lắm thì cống đặt thẳng => kc hố ga không đổi là hợp lý

Bạn dùng lisp này (chưa align hố ga)

copy 1 block vào đầu đường cong bạn muốn rồi đấnh lệnh

Tham khảo lisp này (bài viết số #1518) để align hố ga theo đường cong

http://www.cadviet.com/forum/index.php?s=&...st&p=102888

	
(defun C:hoga ( / bl pl ci l lo li b pt p1 p2 ptl sn om)
(defun get_interpts (obj1 obj2 / iplist)
 (if (not (vl-catch-all-error-p
            (setq iplist (vl-catch-all-apply
                           'vlax-safearray->list
                           (list
                             (vlax-variant-value
                               (vla-intersectwith obj1 obj2 acextendnone)
                             ))))))
   iplist
 )
)
;; 
(while (not bl)
	(progn
	(princ "\nChon block :")
	(setq bl (ssget  ":S" '((0 . "Insert"))))
))
(while (not pl)
	(progn
	(princ "\nChon duong chuan :")
	(setq pl (ssget  ":S" '((0 . "LWPOLYLINE"))))
))
(setq om (getvar "OSMODE")) (setvar "OSMODE" 0)
(setq bl (ssname bl 0) pl (vlax-ename->vla-object (ssname pl 0)) pt (cdr (assoc 10 (entget bl))))
(setq l (getdist "\nKhoang cach:") p1 pt p2 (vlax-curve-getClosestPointTo pl pt))
(setq lo (vlax-curve-getDistAtPoint pl p2))
(setq sn
	(if (> 0.5 ( / (vlax-curve-getParamAtPoint pl p2)(vlax-curve-getEndParam pl))) 1 -1	))

(while (not B )
	(progn
		(command "_Circle" p1 l)
		(setq ci (vlax-ename->vla-object (entlast)))
		(setq ptl (get_interpts pl ci) b T)
		(command "_Erase" "l" "")
		(while ptl
			(setq p2 (list (car ptl) (cadr ptl) (caddr ptl)))
			(setq li (vlax-curve-getDistAtPoint pl p2))
			(setq ptl (cdddr ptl))
			(if (>(* sn (- li lo)) (/ l 2))
				(progn
					(command "copy" bl "" pt p2)
					(setq ptl nil b nil p1 p2 lo li)
				)
			)
		)
		;(setq)
)	)
(setvar "OSMODE" om)
)

<<

Quick code cho bạn

;lisp viet theo y/c: http://www.cadviet.com/forum/topic/170671-nh%E1%BB%9D-vi%E1%BA%BFt-lisp-t%E1%BA%A1o-dim-vu%C3%B4ng-g%C3%B3c-gi%E1%BB%AFa-hai-%C4%91%C6%B0%E1%BB%9Dng-polyline/
(defun c:DDD(/ lst_va old plDo plXanh lst_ver fn pw p2 LastObj)
	(setq lst_va '("osmode" "cmdecho"))
	(setq old (mapcar 'getvar lst_va))
	(mapcar 'setvar lst_va '(0 0))
	(setq plDo (car(entsel "\nChon duong mau...
>>

Quick code cho bạn

;lisp viet theo y/c: http://www.cadviet.com/forum/topic/170671-nh%E1%BB%9D-vi%E1%BA%BFt-lisp-t%E1%BA%A1o-dim-vu%C3%B4ng-g%C3%B3c-gi%E1%BB%AFa-hai-%C4%91%C6%B0%E1%BB%9Dng-polyline/
(defun c:DDD(/ lst_va old plDo plXanh lst_ver fn pw p2 LastObj)
	(setq lst_va '("osmode" "cmdecho"))
	(setq old (mapcar 'getvar lst_va))
	(mapcar 'setvar lst_va '(0 0))
	(setq plDo (car(entsel "\nChon duong mau do: ")))
	(setq plXanh (car(entsel "\nChon duong mau xanh: ")))
	(if (and plDo plXanh)
		(progn
			(setq lst_ver (acet-geom-vertex-list plDo)
				  )
			(if (< (car (last lst_ver)) (car (car lst_ver))) 
				(setq lst_ver (reverse lst_ver))
			)
			(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
 			(setq pw (open fn "w"))
			(write-line (strcat "STT, K/cach") pw)	
			(foreach p1 lst_ver
				(setq p2 (vlax-curve-getClosestPointTo plXanh p1))
				(command ".dimaligned" p1 p2 p2)
				(setq LastObj (vlax-ename->vla-object (entlast)))
				(write-line (strcat "," (rtos(vla-get-Measurement LastObj) 2 4)) pw)
			)
			(close pw)
		)
		(princ "*** Chon lung tung roi! Lam lai nhe! ***")
	)
	(mapcar 'setvar lst_va old)
	(princ)
)

Bước 3 chèn Block lp_hai có thể sử dụng cách này :

Sử dụng hàm (setq curve (nentselp (setq pt (getpoint "\nDiem / Duong thang Insert Block...

>>

Bước 3 chèn Block lp_hai có thể sử dụng cách này :

Sử dụng hàm (setq curve (nentselp (setq pt (getpoint "\nDiem / Duong thang Insert Block :"))))

- Nếu curve trả về Nil, tức là điểm user chọn không có đối tượng nào -> Yêu cầu chọn thêm 1 điểm nữa giống lp_hai đã làm

- Nếu curve trả về khác Nil, tức là có ename và điểm chọn

Lúc này ta có góc của vertex curve chọn + điểm chèn => làm tiếp như trường hợp 1

Lấy góc của vertex curve (*Line) tại điểm chọn, lp_hai tham khảo ở 1 lisp gần đây nhất :

Đầu tiên em xin cảm ơn bác!

Nói chung em chỉ biết những code đơn giản thôi. hhehhe, hơi gà! Vì thế em cũng rất mong dc học hỏi nhiều ở các bác.

Theo hướng dẫn của bác thì em sửa lại là thêm cái hàm con : curve-no-nil vì mổi lần xài đoạn code:

(setq p1 (vlax-safearray->list p1)

p2 (vlax-safearray->list p2))

đòi hỏi p1 và p2 phải được giải phóng, có đúng vậy ko bác?

và thấy lisp chạy như sau:

1)Lisp áp dụng tốt khi chọn 2 điểm(tức là curve = nil)

2)Lisp áp dụng tốt khi Curve là line (vì chỉ có 2 đầu nên xác định góc theo phương của đường thẳng)

3)Nếu chọn điểm thứ nhất nằm trên một curve nào đó thì mặc định góc quay theo trường hợp 2(cái này hơi ép User!!?)

4)khi curve là PL có nhiều đỉnh thì nó lại xác định góc theo 2 điểm đầu và cuối nên đôi khi không đúng góc yêu cầu

Rất mong bác chỉ giáo để em tiến bộ :)

(defun c:clo (/ bm bn tenlo tengoc stt st p1 p2 pt ang area po os curve)
 (setq bm 	(entsel "\nchon Block mau:")
bn 	(cdr (assoc 2 (entget (car bm))))
Tenlo  (cdr (assoc 1 (entget (entnext (entnext (car bm))))))
po 	(vl-string-position (ascii ":") tenlo)
tengoc (substr tenlo 1 (+ po 1))
stt	(getint "\nso lo dat bat dau:")
OS (getvar "osmode")
)
;;;;;;;;;;;
 (while (setq pt (getpoint "\npick diem:"))
(setvar "osmode" 512)
(setq curve (nentselp (setq p1 (getpoint "\nChon diem dat Block /Duong thang Insert Block:"))))
(setvar "osmode" OS)
(if (= curve nil)
 	(setq p2 (getpoint p1 "\nChon diem 2:")
	ang (/ (* (angle p1 p2) 180) pi)
	);curve = nil
 	(setq ang (/ (* (angle '(0 0 0) (vlax-curve-getFirstDeriv (car curve) (vlax-curve-getParamAtPoint (car curve) (vlax-curve-getClosestPointto (car curve) p1))))180)pi))
 	);kt if   
;;;;;;;;;;;
(command "-BOUNDARY" pt "")
(setq area (vlax-curve-getArea (entlast))	)
(setq st (if (< stt 10)
   	(strcat "0" (rtos stt))
   	(rtos stt)
 	)
)
(entdel (entlast))
(setq ang (+ ang 90))
(if (> ang 180) (setq ang (- ang 180)))
(command "insert"  bn  p1 "1" "" ang (rtos area 2 1)(strcat tengoc st))
(setq stt  (+ stt 1))
)
 (princ)
 )

<<

Mình thấy vẫn còn mà

(vl-load-com)

(defun C:co1 ( / ANG ANG1 ANG2 DIS ELST ELST_COPY ELST_INTERS ELST_PL ENT ENT1 ETYPE I LEN LST LST1 LST_ADD LST_DIS LST_PT MODE OBJ PT PT1 PT2 PT_BASE ROTP X)
  (princ "Select objects to copy: ")
  (if (and (setq elst_copy (vl-remove-if 'listp (mapcar 'cadr (if (ssget) (ssnamex (ssget "_P")))))) (setq pt_base (getpoint "\nSpecify base point: ")))
    (progn
      (setq elst...
>>

Mình thấy vẫn còn mà

(vl-load-com)

(defun C:co1 ( / ANG ANG1 ANG2 DIS ELST ELST_COPY ELST_INTERS ELST_PL ENT ENT1 ETYPE I LEN LST LST1 LST_ADD LST_DIS LST_PT MODE OBJ PT PT1 PT2 PT_BASE ROTP X)
  (princ "Select objects to copy: ")
  (if (and (setq elst_copy (vl-remove-if 'listp (mapcar 'cadr (if (ssget) (ssnamex (ssget "_P")))))) (setq pt_base (getpoint "\nSpecify base point: ")))
    (progn
      (setq elst (vl-remove-if 'listp (mapcar 'cadr (if (ssget) (ssnamex (ssget "_P"))))))
      (setq elst_pl (vl-remove-if-not '(lambda (ent) (wcmatch (cdr (assoc 0 (entget ent))) "*LINE,ARC")) elst))
      (setq elst_inters (vl-remove-if-not '(lambda (ent) (wcmatch (cdr (assoc 0 (entget ent))) "*LINE,ARC,CIRCLE")) elst))
      (setq rotp (get_key (list "Yes" "No") "No" "Xoay theo doi tuong"))
      (if elst_inters
	(setq mode (listbox (list "Dinh" "Dau" "Cuoi" "Trung diem" "Trong tam" "Giao cat") "Vi tri Paste cua Pline, Arc" 10 8 1))
	)
      (setq lst_pt nil)
      (foreach ent elst
	(setq lst (entget ent))
	(setq etype (cdr (assoc 0 lst)))
	(setq pt nil)
	(if (wcmatch etype "*TEXT")
	  (if (and (assoc 11 lst)
		   (not (equal (car (cdr (assoc 11 lst))) 0))
		   (not (equal (cadr (cdr (assoc 11 lst))) 0))
		   )
	    (setq pt (cdr (assoc 11 lst)))
	    (setq pt (cdr (assoc 10 lst)))
	    )
	  )
	(if (wcmatch etype "HATCH")
	  (setq pt (boundingbox_centroid ent))
	  )
	(if (not (wcmatch etype "*TEXT,*LINE,ARC,HATCH"))
	  (setq pt (cdr (assoc 10 lst)))
	  )
	(if (not (setq ang (cdr (assoc 50 lst)))) (setq ang 0.0))
	(if pt (setq lst_pt (cons (cons ang pt) lst_pt)))
	)
      (if (member "Dinh" mode)
	(foreach ent elst_pl
	  (if (wcmatch (cdr (assoc 0 (entget ent))) "LINE,ARC")
	    (progn
	      (setq pt1 (vlax-curve-getPointAtParam ent (vlax-curve-getStartParam ent)))
	      (setq ang1 (angle (list 0 0) (vlax-curve-getFirstDeriv ent (vlax-curve-getParamAtPoint ent pt1))))
	      (setq pt2 (vlax-curve-getPointAtParam ent (vlax-curve-getEndParam ent)))
	      (setq ang2 (angle (list 0 0) (vlax-curve-getFirstDeriv ent (vlax-curve-getParamAtPoint ent pt2))))
	      (setq lst_pt (cons (cons ang1 pt1) lst_pt))
	      (setq lst_pt (cons (cons ang2 pt2) lst_pt))
	      )
	    )
	  (if (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
	    (progn
	      (setq lst_add (mapcar '(lambda (pt) (cons (angle (list 0 0) (vlax-curve-getFirstDeriv ent (vlax-curve-getParamAtPoint ent pt))) pt)) (get_vertex ent)))
	      (setq lst_pt (append lst_add lst_pt))
	      )
	    )
	  )
	)
      (if (and (member "Dau" mode) (not (member "Dinh" mode)))
	(foreach ent elst_pl
	  (setq pt (vlax-curve-getPointAtParam ent (vlax-curve-getStartParam ent)))
	  (setq ang (angle (list 0 0) (vlax-curve-getFirstDeriv ent (vlax-curve-getParamAtPoint ent pt))))
	  (setq lst_pt (cons (cons ang pt) lst_pt))
	  )
	)
      (if (and (member "Cuoi" mode) (not (member "Dinh" mode)))
	(foreach ent elst_pl
	  (setq pt (vlax-curve-getPointAtParam ent (vlax-curve-getEndParam ent)))
	  (setq ang (angle (list 0 0) (vlax-curve-getFirstDeriv ent (vlax-curve-getParamAtPoint ent pt))))
	  (setq lst_pt (cons (cons ang pt) lst_pt))
	  )
	)
      (if (member "Trung diem" mode)
	(progn
	  (foreach ent elst_pl
	    (if (wcmatch (cdr (assoc 0 (entget ent))) "LINE,ARC")
	      (progn
		(setq pt (vlax-curve-getPointAtDist ent (* (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) 0.5)))
		(setq ang (angle (list 0 0) (vlax-curve-getFirstDeriv ent (vlax-curve-getParamAtPoint ent pt))))
		(setq lst_pt (cons (cons ang pt) lst_pt))
		)
	      )
	    (if (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
	      (progn
		(setq lst1 (get_vertex ent))
		(setq len (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
		(setq lst_dis (mapcar '(lambda (pt) (vlax-curve-getDistAtPoint ent pt)) lst1))
		(if (not (equal len (last lst_dis)))
		  (setq lst_dis (reverse (cons len (cdr (reverse lst_dis)))))
		  )
		(setq i 0)
		(repeat (1- (length lst_dis))
		  (setq dis (* (+ (nth i lst_dis) (nth (1+ i) lst_dis)) 0.5))
		  (setq pt (vlax-curve-getPointAtDist ent dis))
		  (setq ang (angle (list 0 0) (vlax-curve-getFirstDeriv ent (vlax-curve-getParamAtPoint ent pt))))
		  (setq lst_pt (cons (cons ang pt) lst_pt))
		  (setq i (1+ i))
		  )
		)
	      )
	    )
	  )
	)
      (if (member "Trong tam" mode)
	(setq lst_pt (append lst_pt (mapcar '(lambda (x) (cons 0.0 (poly_centroid x))) elst_pl)))
	)
      (if (member "Giao cat" mode)
	(while (> (length elst_inters) 1)
	  (setq ent1 (car elst_inters))
	  (setq lst (apply 'append (mapcar '(lambda (x) (vla-inters ent1 x acextendnone)) (cdr elst_inters))))
	  (foreach pt lst (setq lst_pt (cons (cons 0.0 pt) lst_pt)))
	  (setq elst_inters (cdr elst_inters))
	  )
	)

      (setq lst_pt (unique lst_pt))
      (foreach lst lst_pt
	(if (and (setq pt (cdr lst)) (setq ang (car lst)))
	  (foreach ent elst_copy
	    (vla-Copy (vlax-ename->vla-object ent))
	    (setq obj (vlax-ename->vla-object (entlast)))
	    (vla-Move obj (vlax-3d-point pt_base) (vlax-3d-point pt))
	    (if (= rotp "Yes") (vla-Rotate obj (vlax-3d-point pt) ang))
	    )
	  )
	)
      )
    )
  (princ)
  )

;NHAP KEYWORD
(defun get_key (key default promp / key_fix str1 str2 str3 str4)
  (setq key_fix key)
  (foreach str1 (list " " "_")
    (setq key_fix (mapcar '(lambda (str) (while (vl-string-search str1 str) (setq str (vl-string-subst "" str1 str))) str) key_fix))
    )
  (setq str1 (apply 'strcat (mapcar (function (lambda (x) (strcat x " "))) key_fix)))
  (setq str2 (apply 'strcat (mapcar (function (lambda (x) (strcat x "/"))) key_fix)))
  (setq str1 (substr str1 1 (1- (strlen str1))))
  (setq str2 (substr str2 1 (1- (strlen str2))))
  (if (not (assoc default (mapcar 'list key_fix))) (setq default (car key_fix)))
  (initget str1)
  (setq str3 (strcat "\n" promp "  <" default "> "))
  (if (not (setq str4 (getkword str3)))
    (nth (vl-position default key_fix) key)
    (nth (vl-position str4 key_fix) key)
    )
  )

;XOA PHAN TU TRUNG
(defun unique (lst)
  (if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst)))))
  )

;LIST BOX
(defun listbox (lst msg wid hei bit / dch des tmp rtn)
  (if (> (length lst) 1)
    (progn
      (cond
	((not
	   (and
	     (setq tmp (vl-filename-mktemp nil nil ".dcl"))
	     (setq des (open tmp "w"))
	     (write-line
	       (strcat
		 "listbox:dialog{label=\""
		 msg
		 "\";spacer;:list_box{key=\"list\";multiple_select="
		 (if (= 1 (logand 1 bit))
		   "true"
		   "false"
		 )
		 (strcat ";width="
			 (rtos wid 2 0)
			 ";height="
			 (rtos hei 2 0)
			 ";}spacer;ok_cancel;}"
		 )
	       )
	       des
	     )
	     (not (close des))
	     (< 0 (setq dch (load_dialog tmp)))
	     (new_dialog "listbox" dch)
	   )
	 )
	 (prompt "\nError Loading List Box Dialog.")
	)
	(t
	 (start_list "list")
	 (foreach itm lst (add_list itm))
	 (end_list)
	 (setq rtn (set_tile "list" "0"))
	 (action_tile "list" "(setq rtn $value)")
	 (setq rtn
		(if (= 1 (start_dialog))
		  (if (= 2 (logand 2 bit))
		    (read (strcat "(" rtn ")"))
		    (mapcar '(lambda (x) (nth x lst))
			    (read (strcat "(" rtn ")"))
		    )
		  )
		)
	 )
	)
      )
      (if (< 0 dch)
	(unload_dialog dch)
      )
      (if (and tmp (setq tmp (findfile tmp)))
	(vl-file-delete tmp)
      )
      rtn
    )
    lst
    )
  )

;GET VERTEX
(defun get_vertex (ent / i lst)
  (setq i 0)
  (repeat (fix (1+ (vlax-curve-getEndParam ent)))
    (setq lst (append lst (list (vlax-curve-getPointAtParam ent i))))
    (setq i (1+ i))
    )
  lst
  )

;GIAO CAT
(defun vla-inters (ent1 ent2 mode / lst1 lst2)
  (setq lst1 (vlax-invoke (vlax-ename->vla-object ent1) 'intersectwith (vlax-ename->vla-object ent2)
	       (cond
		 ((= mode 0) acextendnone)
		 ((= mode 1) acextendthisentity)
		 ((= mode 2) acextendotherentity)
		 ((= mode 3) acextendboth)
		 )))
  (repeat (/ (length lst1) 3)
    (setq lst2 (cons (list (car lst1) (cadr lst1) (caddr lst1)) lst2)
	  lst1 (cdddr lst1)
	  )
    )
  (reverse lst2)
  )

;CENTROID
(defun boundingbox_centroid (ent / minpt maxpt)
  (if
    (and
      (vlax-method-applicable-p (vlax-ename->vla-object ent) 'getboundingbox)
      (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list (vlax-ename->vla-object ent) 'minpt 'maxpt))))
      (setq minpt (vlax-safearray->list minpt))
      (setq maxpt (vlax-safearray->list maxpt))
      )
    (list (* 0.5 (+ (car minpt) (car maxpt))) (* 0.5 (+ (cadr minpt) (cadr maxpt))))
    )
  )

;POLY CENTROID - LEE MAC
(defun poly_centroid (e / l)
  (foreach x (setq e (entget e))
    (if	(= 10 (car x))
      (setq l (cons (cdr x) l))
    )
  )
  (
   (lambda (a)
     (if (not (equal 0.0 a 1e-8))
       (trans
	 (mapcar
	   '/
	   (apply
	     'mapcar
	     (cons '+
		   (mapcar
		     (function
		       (lambda (a b)
			 (
			  (lambda (m)
			    (mapcar
			      (function
				(lambda (c d) (* (+ c d) m))
			      )
			      a
			      b
			    )
			  )
			   (- (* (car a) (cadr b)) (* (car b) (cadr a)))
			 )
		       )
		     )
		     l
		     (cons (last l) l)
		   )
	     )
	   )
	   (list a a)
	 )
	 (cdr (assoc 210 e))
	 0
       )
     )
   )
    (* 3.0
       (apply '+
	      (mapcar
		(function
		  (lambda (a b)
		    (- (* (car a) (cadr b)) (* (car b) (cadr a)))
		  )
		)
		l
		(cons (last l) l)
	      )
       )
    )
  )
)

Rất vui khi nhận được lisp của bác

Cảm ơn bác

Mới đầu dùng thử thì có hiện tượng dimension hoặc text mà bao gồm chuỗi...

>>

Rất vui khi nhận được lisp của bác

Cảm ơn bác

Mới đầu dùng thử thì có hiện tượng dimension hoặc text mà bao gồm chuỗi kí tự cả chữ và số thì kết quả xuất ra bao gồm cả cụm chữ và thêm 1 con số trích ra từ chuỗi kí tự đó

ví dụ như dim hoặc text: "150x600" thì kết quả trên file csv sẽ là "150x600" và "150"

 

Nhưng sau khi test tiếp thì lại k0 thấy hiện tượng đó nữa

 

Với cả, bác có thể sửa lisp hộ em sao cho kết quả xuất ra có thêm 1 cột chú thích, nếu là đối tượng là text thì có ghi chú là text1, text2, ...nếu là dimension thì ghi chú là dim1, dim2,... như trong hình được không ạ?

 

 

Cảm ơn bác!

Đây bạn:

(defun C:HA( / lst fn fw index x y z txt)	;Doan Van Ha Cadviet.com
(princ "\nChon cac Text/Mtext/Dimension can xuat ra file...")
(setq lst (acet-ss-to-list (ssget '((0 . "*TEXT,DIMENSION"))))
      	fn (getfiled "Chon file de save" "" "csv" 1)
      	fw (open fn "w")
      	index 0 x 1 y 1 z 1)
(repeat (length lst)
 (cond
  ((= (cdr (assoc 0 (entget (nth index lst)))) "TEXT") (setq txt (strcat (cdr (assoc 1 (entget (nth index lst)))) "," "text" (itoa x)) x (1+ x)))
  ((= (cdr (assoc 0 (entget (nth index lst)))) "MTEXT") (setq txt (strcat (cdr (assoc 1 (entget (nth index lst)))) "," "mtext" (itoa y)) y (1+ y)))
  ((= (cdr (assoc 0 (entget (nth index lst)))) "DIMENSION")
(if (= (cdr (assoc 1 (entget (nth index lst)))) "")
	(setq txt (strcat (rtos (cdr (assoc 42 (entget (nth index lst))))) "," "dim" (itoa z)) z (1+ z))
	(setq txt (strcat (cdr (assoc 1 (entget (nth index lst)))) "," "dim" (itoa z)) z (1+ z)))))
 (princ (strcat txt "\n") fw)
 (setq index (1+ index)))
(close fw))

<<

@Ketxu 21-9-11

Lisp copy array (chính xác hơn là multi copy ^^) các đối tượng theo 1 đường thẳng, cho phép cộng có gia số với Text đánh số

Có phân biệt số INT hoặc REAL. Mặc định để 1 số thập phân và lựa chọn Không tăng khi tập chọn có TEXT :)

Update 1.2 : Cho phép xử lý với cả các Text có format số

@Ketxu 21-9-11

Lisp copy array (chính xác hơn là multi copy ^^) các đối tượng theo 1 đường thẳng, cho phép cộng có gia số với Text đánh số

Có phân biệt số INT hoặc REAL. Mặc định để 1 số thập phân và lựa chọn Không tăng khi tập chọn có TEXT :)

Update 1.2 : Cho phép xử lý với cả các Text có format số

Open source :

;Dynamic Array v1.2 Ketxu 21 - 9 -11
;Many thank to quichen's code
(vl-load-com)
(defun c:dar( / dir gr nx p0 px pxv ssFull ss1 vecx ans inc)
(grtext -1 "Dynamic LArray @Ketxu")
(setq m:err *error*	*error* err)
(command "undo" "be")
(if (setq ssFull (ST:SS->List-Vla (ssget))
 	  p0 (getpoint "\n\U+0110i\U+1EC3m g\U+1ED1c ::")
 px (getpoint p0 "\nH\U+01B0\U+1EDBng v\U+00E0 kho\U+1EA3ng c\U+00E1ch copy :")
 	  vecx (mapcar '- px p0)
)
(progn
 (cond ((ST:Check-Exist '("AcDbText" "AcDbMText") (mapcar 'vla-get-objectname ssFull))    
 (setq ans (strcase(getstring "Copy t\U+0103ng Text ? < K > :")))
  (cond ((not (or (= ans "K")(= ans "")))
(or #num (setq #num 1))
(setq #num (cond ((getint (strcat "\nGia s\U+1ED1 < " (rtos #num 2 0) " > :")))(#num)) inc T)
)
  )
 )
 )  
 (prompt "\nPick \U+0111i\U+1EC3m cu\U+1ED1i c\U+00F9ng :")
 (while (= (car (setq gr (grread nil 5 0))) 5)
(if ss1 (ST:Ss-Delete ss1))
(redraw)
(setq pxv (mapcar '- (inters (cadr gr) (polar (cadr gr) (+ (/ pi 2.0) (angle px p0)) 1.0) p0 px nil) p0))
(if (< (setq nx  (fix (/ (caddr (trans pxv 0 vecx)) (caddr (trans vecx 0 vecx))))) 0)
    	  (setq dir -1 nx (- nx)) (setq dir 1))

(setq ss1 (ST:Ss-Copy-Dynamic ssFull nx vecx dir inc #num))
(grdraw p0 (mapcar '+ p0 pxv) 3 1)
 )
)
)
(command "undo" "en")
 (princ)
)
(defun ST:Ss-Copy-Dynamic (sslst n v dir inc num / i number matlist obj1 ss transmat xobj isText lst isReal)
 (setq ss (ssadd))
 (foreach xobj sslst
(setq i 1)
(cond ((and (wcmatch (vla-get-objectname xobj) "AcDbText,AcDbMText") inc num)
(cond ((= 'REAL (type (setq number (cadr (setq lst (txt2num (vla-get-textstring xobj)))))))
 	  (setq  isReal T))
 	(T (setq  isReal nil))
)
(setq isText T)
  ) ;Text Object
(T setq isText nil)
)  
(repeat n
 	(setq obj1 (vla-copy xobj)
 		  matList (list (list 1 0 0 (* i (car v) dir)) (list 0 1 0 (* i (cadr v) dir)) '(0 0 1 0) '(0 0 0 1))
 		  transmat (vlax-tmatrix matlist))
 	(vla-transformby obj1 transMat)
  (if  (and isText (wcmatch (vla-get-objectname xobj) "AcDbText,AcDbMText") inc num)
  	 (vla-put-textstring obj1 (strcat (car lst) (rtos (setq number (+ num number)) 2  (if isReal 1 0))(last lst))))
 	(ssadd (vlax-vla-object->ename obj1) ss)
 	(setq i (1+ i))
)
 )
 ss
)
(defun ST:SS->List-Vla (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (vlax-ename->vla-object e) l))
 )
)
(defun ST:Ss-Delete (ss / i)
 (mapcar 'vla-delete (ST:SS->List-Vla ss))
)
(defun ST:Check-Exist(lst1 lst2)(and (vl-remove nil (mapcar '(lambda(x)(vl-position x lst2)) lst1)))) ;from topic Dovui ^^
(defun err (msg)    
   (if ss1 (ST:ss-delete ss1))
   (setq *error* m:err 		  m:err nil
   )
 )
(defun txt2num (str / num pos)
(setq pos (vl-string-search (setq num (vl-list->string (vl-remove-if-not '(lambda (x) (or (< 44 x 47)(< 47 x 58)))(vl-string->list str))))str))
(list
   (substr str 1  pos)
   (if (vl-string-search "." num)(atof num)(atoi num))
   (substr str (+ 1 pos (strlen num)))
))

Mình đã sửa thành nhiều đối tượng đây nhé:

(defun c:PTLs (/ ent elist wid p1 line elist2 start end r1 r2 r3 r4)
  (defun dtr (d)
    (* pi d (/ 1.0 180.0))
  )
  (command "_.undo" "_g")

  (foreach ent1    (vl-remove-if
          'listp
          (mapcar 'cadr (ssnamex (ssget '((0 . "*POLYLINE")))))
        )

    (setq elist (entget ent1))
    (setq wid (cdr (assoc 43 elist)))
 ...
>>

Mình đã sửa thành nhiều đối tượng đây nhé:

(defun c:PTLs (/ ent elist wid p1 line elist2 start end r1 r2 r3 r4)
  (defun dtr (d)
    (* pi d (/ 1.0 180.0))
  )
  (command "_.undo" "_g")

  (foreach ent1    (vl-remove-if
          'listp
          (mapcar 'cadr (ssnamex (ssget '((0 . "*POLYLINE")))))
        )

    (setq elist (entget ent1))
    (setq wid (cdr (assoc 43 elist)))
    (setq p1 ent1)
    (command "_.explode" p1)

    (setq line (entlast))
    (setq elist2 (entget line))
    (setq start (cdr (assoc 10 elist2)))
    (setq end (cdr (assoc 11 elist2)))
    (setq r1 (polar start (+ (angle start end) (dtr 270)) (/ wid 2)))
    (setq r2 (polar start (+ (angle start end) (dtr 90)) (/ wid 2)))
    (setq r3 (polar end (+ (angle start end) (dtr 90)) (/ wid 2)))
    (setq r4 (polar end (+ (angle start end) (dtr 270)) (/ wid 2)))
    (command "_.line" r1 r2 r3 r4 "c")
    (entdel line)
  )

  (command "_.undo" "_end")
  (princ)
)