(defun c:ttl ()
(or ssmin (setq ssmin 0))
(setq ssmin (cond ((getint (strcat "\nMuc so sanh min < " (rtos ssmin 2 0) " >:")))(ssmin)))

(or ssmax (setq ssmax 10))
(setq ssmax (cond ((getint (strcat "\nMuc so sanh max < " (rtos ssmax 2 0) " >:")))(ssmax)))

(or tlven (setq tlven 1))
(setq tlven (cond ((getreal (strcat "\nTi le <1/ " (rtos tlven 2 0) " >:")))(tlven)))
(setq tlve (/ 1000 tlven))
(setq...
>>

(defun c:ttl ()
(or ssmin (setq ssmin 0))
(setq ssmin (cond ((getint (strcat "\nMuc so sanh min < " (rtos ssmin 2 0) " >:")))(ssmin)))

(or ssmax (setq ssmax 10))
(setq ssmax (cond ((getint (strcat "\nMuc so sanh max < " (rtos ssmax 2 0) " >:")))(ssmax)))

(or tlven (setq tlven 1))
(setq tlven (cond ((getreal (strcat "\nTi le <1/ " (rtos tlven 2 0) " >:")))(tlven)))
(setq tlve (/ 1000 tlven))
(setq diemve (getpoint "\nChon diem ve thuoc :"))
(setq diemdau diemve)
(setq diemve (polar diemve (* pi 1.5) (* 0.1 tlve)))

(setq slc ssmin)

(repeat (fix (- ssmax ssmin))
(setq diemve (polar diemve (/ pi 2) (* 0.1 tlve)))
(entmake (list (cons 0 "LINE")(cons 10 diemve)(cons 11 (polar diemve pi (* 0.1 tlve)))(cons 8 "Clayer")(cons 62 256)(cons 6 "bylayer")(cons 48 1) )) 
(entmake (list (cons 0 "TEXT")(cons 10 (polar diemve pi (* 0.25 tlve)))(cons 11 (polar diemve pi (* 0.5 tlve)))(cons 40 (/ tlve 5))(cons 50 0)(cons 72 1)(cons 1 (rtos slc 2 0))(cons 7 (getvar "TEXTSTYLE"))(cons 8 "Clayer")(cons 62 256))) 


(repeat 9
(setq diemve (polar diemve (/ pi 2) (* 0.1 tlve)))
(entmake (list (cons 0 "LINE")(cons 10 diemve)(cons 11 (polar diemve pi (* 0.05 tlve)))(cons 8 "Clayer")(cons 62 256)(cons 6 "bylayer")(cons 48 1) )) 
)

(setq slc (+ slc 1))
)

(setq diemve (polar diemve (/ pi 2) (* 0.1 tlve)))
(entmake (list (cons 0 "LINE")(cons 10 diemve)(cons 11 (polar diemve pi (* 0.1 tlve)))(cons 8 "Clayer")(cons 62 256)(cons 6 "bylayer")(cons 48 1) )) 
(entmake (list (cons 0 "TEXT")(cons 10 (polar diemve pi (* 0.25 tlve)))(cons 11 (polar diemve pi (* 0.5 tlve)))(cons 40 (/ tlve 5))(cons 50 0)(cons 72 1)(cons 1 (rtos slc 2 0))(cons 7 (getvar "TEXTSTYLE"))(cons 8 "Clayer")(cons 62 256))) 
(entmake (list (cons 0 "LINE")(cons 10 diemdau)(cons 11 diemve)(cons 8 "Clayer")(cons 62 256)(cons 6 "bylayer")(cons 48 1) )) 
(Princ))

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

Sửa luôn cho hỏi tỉ lệ luôn đây. Lưu ý chỉ nhập phần sau dấu / ví dụ 1/500 thì nhập là 500.

(defun C:PTEST()
;;;--- Get the entity's name 
 (setq en(car(entsel "\n Select a PolyLine: ")))

;;;--- Get the DXF group codes of the entity 
 (setq enlist(entget en))

;;;---...
>>

(defun C:PTEST()
;;;--- Get the entity's name 
 (setq en(car(entsel "\n Select a PolyLine: ")))

;;;--- Get the DXF group codes of the entity 
 (setq enlist(entget en))

;;;--- Create an empty list to hold the points 
 (setq ptList(list))

;;;--- Get the sub-entities name 
 (setq en2(entnext en)) 

;;;--- Get the dxf group codes of the sub-entity 
 (setq enlist2(entget en2))

 (setq ptList(append ptList (list (cdr(assoc 10 enlist2)))))

;;;--- While the polyline has a next vertice 
 (while (not (equal (cdr(assoc 0 (entget(entnext en2))))"SEQEND"))

;;;--- Get the next sub-entity 
 (setq en2(entnext en2))

;;;--- Get its dxf group codes 
 (setq enlist2(entget en2))

;;;--- Check to make sure it is not a spline reference point 
 (if(/= 16 (cdr(assoc 70 enlist2)))

;;;--- It is a vertex, save the point in a list  
   (setq ptList(append ptList (list (cdr(assoc 10 enlist2)))))

 )
 )
 (setq olmode (getvar "pdmode"))
 (setvar "pdmode" 3)
 (setq n 0)
 (while (nth (1+ n) ptlist)
	 (setq p1 (nth n ptlist)
		  p2 (nth (1+ n) ptlist)
		  x1 (car p1)
		  y1 (cadr p1)
		  x2 (car p2)
		  y2 (cadr p2)
		  k 1			
		  goc (angle p1 p2)
		  a (getreal "\n Nhap khoang cach cho block thu nhat : ")
		  b (getreal "\n Nhap khoang cach cho block thu hai :")
	 )

	 (setq p3 (list (+ x1 (* a (cos goc))) (+ y1 (* a (sin goc)))))
	 (command "point" p3)
	 (command "insert" "b" "s" 1 p3 0 "")
	 (setq p4 (list (+ x1 (* (+ a b) (cos goc))) (+ y1 (* (+ a b) (sin goc)))))
	 (command "point" p4)
	 (command "insert" "b" "s" 1 p4 0 "")


	 (setq n (1+ n))
 )
 (setvar "pdmode" olmode)	 
 (princ)
)

Chào bạn phamthanhbinh.

Mình muốy nhờ bạn chỉnh giúp mình của Lisp trên,

Để đo khoảng cách và thể hiện điểm đo trên cạnh. Ví như ta có một hình tứ giác chử nhật có chiều dài và rộng, ta chọn hình đó để chia, chọn điểm bắt đầu chia và hướng chia, nhập chiều dài. Thì lisp thực hiện công ciệc xác định điểm đó và vẻ kí hiệu chấm tròn nhỏ, yêu cầu nhập số điểm đó, thể hiện lên số điểm chia đó và khoảng cách,

Lisp thực hiện chia khoảng cách, ghi kí hiệu điểm và chiều dài trên cạnh chia đó.

Rất mong được Bạn giúp

<<

Chào Kamezoko,

Trước hết Thiep đề nghị định dạng lại bản vẽ của bạn như sau:

Các điểm đo là đối tượng POINT được đặt trong lớp "DIEM"

Các ký hiệu...

>>

Chào Kamezoko,

Trước hết Thiep đề nghị định dạng lại bản vẽ của bạn như sau:

Các điểm đo là đối tượng POINT được đặt trong lớp "DIEM"

Các ký hiệu điểm đo là đối tượng TEXT được đặt trong lớp "TENDIEM"

Các cao độ điểm đo là đối tượng TEXT được đặt trong lớp "CAODO"

Các ký hiệu điểm đo phải là một ký tự chữ kèm với 1 số tự nhiên tăng dần. ví dụ: đường chuyền đa giác 1: I.1, I.2, I.3... I.100, đường chuyền đa giác 2: H-1, H-2, H-3 ... H-100, không được là II.1, II.2, II.3 ...Nếu bạn lỡ ký hiệu như vậy thì dùng chức năng find and replace của CAD để chỉnh sửa lại.

Lisp sẽ tự động dò các điểm có ký hiệu cùng 1 kiểu đường chuyền sẽ nối với nhau thành một 3dpolyline

Thiep dùng lisp JD của bác Hoanh chỉnh sửa lại cho phù hợp với bạn hơn.

Các bạn trắc địa dùng và cho ý kiến nhé:

;;;===============================================
;;; Lisp tao duong chuyen 3DPOLYLINE
;;; Update: 09/09/2009
;;; Free from CADVIET.COM
(defun 3DPoly (Lp *ModelSpace* / PntArr)
 (setq	PntArr (vlax-make-safearray
	 vlax-vbDouble
	 (cons 0 (1- (length Lp)))
       )
 )
 (vlax-safearray-fill PntArr Lp)
 (vla-Add3Dpoly *ModelSpace* PntArr)
)
;;;---------------------
(defun SAVE_MODE ()
 (command "UCS" "W" "")
 (setq	OLD_OSMODE    (getvar "OSMODE")
OLD_CECOLOR   (getvar "CECOLOR")
OLD_AUTOSNAP  (getvar "AUTOSNAP")
OLD_ORTHOMODE (getvar "ORTHOMODE")
 )
 (setvar "osmode" 0)
 (setvar "cmdecho" 0)
 (setvar "plinegen" 1)

)
(defun RESTORE ()
 (setvar "osmode" OLD_OSMODE)
 (setvar "AUTOSNAP" OLD_AUTOSNAP)
 (setvar "ORTHOMODE" OLD_ORTHOMODE)
 (setvar "CECOLOR" OLD_CECOLOR)
 (setvar "cmdecho" 1)
 )
;;;------------------------------------
 (defun timgan	(p lst / dmin ppluu)
   (foreach pp	lst
     (setq d (distance p (car pp)))
     (if (or (not dmin) (> dmin d))
(setq dmin d
      ppluu pp
)
     )
   )
   (cdr ppluu)
 )

(defun filter (lstent otype olayer / kq)
 (foreach pp lstent
    (setq tt (entget pp))
    (if (and
   (member (cons 0 otype) tt)
   (member (cons 8 olayer) tt)
 )
      (setq kq (append kq (list pp)))
    )
 )
 kq
)
(defun ss2ent(ss / sodt index lstent)
 (setq
   sodt (if ss (sslength ss) 0)	   
   index 0
 )
 (repeat sodt
   (setq ent (ssname ss index)
  index (1+ index)
  lstent (cons ent lstent)
   )
 )
 (reverse lstent)
)
;;;===============================================
(vl-load-com)
(defun c:jd (/ ss	lstent	 lstcode  lstpoint lstponew lstassoc
       lstass	pc	 code	  p	   lstPLY   p0
       lstponew	co n
      )
 (setq	ActDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
*Model*	(vla-get-ModelSpace ActDoc)
*layer*	(vla-get-Layers ActDoc)
 )
 (vla-StartUndoMark ActDoc)
 (if (not (setq enlay (tblobjname "layer" "DUONGCHUYEN")))
   (setq lay (vla-add *layer* "DUONGCHUYEN"))
   (progn
     (setq lay (vlax-ename->vla-object enlay))
     (setq lay (vla-add *layer* "DUONGCHUYEN"))
   )
 )
 (vla-put-color lay acRed)
 (vla-put-Linetype lay "continuous")
 (setvar "clayer" "DUONGCHUYEN")
 (SAVE_MODE)
 (setq
   ss	     (ssget
       '((-4 . "		 (-4 . "		 (0 . "POINT")
	 (8 . "DIEM")
	 (-4 . "AND>")
	 (-4 . "		 (0 . "TEXT")
	 (8 . "TENDIEM")
	 (-4 . "AND>")
	 (-4 . "OR>")
	)
     )
   lstent   (ss2ent ss)
   lstcode  (mapcar '(lambda (e)
		(cons (cdr (assoc 10 (entget e)))
		      (cdr (assoc 1 (entget e)))
		)
	      )
	     (filter lstent "TEXT" "TENDIEM")
     )
   lstpoint (mapcar '(lambda (e) (cdr (assoc 10 (entget e))))
	     (filter lstent "POINT" "DIEM")
     )
   lstpoint (mapcar '(lambda (p)
		(cons (timgan p lstcode) p)
	      )
	     lstpoint
     )
 )
 (setq	lstpoint
 (vl-sort
   lstpoint
   '(lambda (e1 e2)
      (< (car e1)
	 (car e2)
      )
    )
 )
 )
 (foreach pn lstpoint
   (setq lstponew
   (cons (cons (read (substr (car pn) 1 1)) (list (cdr pn)))
	 lstponew
   )
   )
   (setq lstassoc (cons (substr (car pn) 1 1) lstassoc))
 )
 (setq lstponew (reverse lstponew))
 (while lstassoc
   (setq lstass (cons (car lstassoc) lstass)) ;flag
   (setq lstassoc (vl-remove (car lstassoc) lstassoc))
 )
 (setq n 1)
 (foreach flag	lstass
   (setq lstPLY nil)
   (while (setq co (assoc (read flag) lstponew))
     (setq lstPLY (append (cadr co) lstPLY))
     (setq lstponew (vl-remove co lstponew))
   )
   (vla-put-color (3DPoly lstPLY *Model*) n)
   (setq n (1+ n))
 )
 (RESTORE)
 (princ)
)

Còn đây là bản vẽ Thiep đã test:

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

cám ơn bạn nhiều, nhưng mình muốn nối điểm tự do,ko muốn nối tư động,nếu có thế thực hiện trên 1 lớp thì tốt hơn..mong bạn giúp đở... :s_big:

<<

Viết giùm cho bạn đây luôn! Lần sau y/c thì phải ghi rõ ràng trên CADViet, chứ đừng gói nó vào 1 file như thế là không...

>>

Viết giùm cho bạn đây luôn! Lần sau y/c thì phải ghi rõ ràng trên CADViet, chứ đừng gói nó vào 1 file như thế là không nên.

Thân thương!

;Doan Van Ha - CADViet.com. 01/12/2011
;Noi cac block diem 3D thanh Polyline theo thu tu ten diem.
(defun c:HA (/ lst)
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq lst (acet-ss-to-list (ssget (list (cons 0 "insert")))))
(setq lst (vl-sort lst '(lambda (x y) (<
(atoi (cdr (assoc 1 (entget (entnext x)))))
(atoi (cdr (assoc 1 (entget (entnext y)))))))))
(command "3dpoly")
(foreach x lst
 (command (cdr (assoc 10 (entget x)))))
(command "")
(setvar "osmode" oldos)
(command "undo" "e")
(princ))

Chào Hà, rất may là bạn lấy giá trị của thuộc tính đầu trong block để sắp xếp thứ tự các ename của block. Nếu trường hợp giá trị cần so sánh để sắp xếp không rơi vào thuộc tính đầu "(assoc 1)" thì người dùng phải viết lại lisp thì cực lắm!

Hãy để người dùng thêm tuỳ chọn là thuộc tính nào cần lấy giá trị so sánh để sắp xếp thì nó mới trọn vẹn lisp này.

Ngoài ra khi đã sắp xếp được các ename trong lst rồi thì lọc tiếp để lấy tọa độ insert của block (assoc 10) cho vào 1 list (lst2), sau đó dùng hàm (ACET-PLINE-MAKE (list lst2)) thì lisp sẽ chạy nhanh hơn vì bỏ đươc các "command"!

Thân ái!

<<

Vào lúc 7/9/2018 tại 11:06, gia_bach đã nói:

Có thể bắt đầu với...

>>

Vào lúc 7/9/2018 tại 11:06, gia_bach đã nói:

Có thể bắt đầu với hàm GRREAD.

Cảm ơn bạn,

Ví dụ mình có lisp xóa đối tượng (không cần enter để chấp nhận):

Mình kết hợp giữa grread-grdraw và ssget, tuy nhiên thì việc chọn đối tượng vẫn không được xịn như lệnh MA: không có cửa sổ vùng chọn, không highlight đối tượng. Đại ý mong muốn của mình là chọn đối tượng như ssget (kiểu chọn window) mà không thông qua bước ấn Enter.

Các bạn giúp mình nhé !

(defun C:e1 ( / LST PT1 PT2 PT3 PT4 SS)
  (while (setq pt1 (getpoint))
    (while (/= (car (setq lst (grread t))) 3)
      (redraw)
      (if (listp (setq pt2 (car (cdr lst))))
	(progn
	  (setq pt3 (list (car pt2) (cadr pt1)))
	  (setq pt4 (list (car pt1) (cadr pt2)))
	  (grdraw pt1 pt3 255)
	  (grdraw pt3 pt2 255)
	  (grdraw pt2 pt4 255)
	  (grdraw pt4 pt1 255)
	  )
	)
      )
    (redraw)
    (if (> (car pt1) (car pt2))
      (setq ss (ssget "_C" pt1 pt2))
      (setq ss (ssget "_W" pt1 pt2))
      )
    (if ss (mapcar 'entdel (acet-ss-to-list ss)))
    (setq pt1 nil)
    )
  (print)
  )

 

Xoa doi tuong.LSP

<<

Lisp trên là theo yêu cầu của hoacomay70 cho nên nó vẽ (chứ không phải copy) đường vuông góc, do đó chỉ chọn 1 line để lấy điểm đầu, và...

>>

Lisp trên là theo yêu cầu của hoacomay70 cho nên nó vẽ (chứ không phải copy) đường vuông góc, do đó chỉ chọn 1 line để lấy điểm đầu, và nhập số cọc rải để hạn chế số lần rải, nếu không sẽ rải tới cuối đường pline.

Còn nếu bạn chọn nhiều đt tức là bạn muốn copy, rải và xoay theo hướng vuông góc với pline thì dùng cái lisp dưới đây.

 

(defun c:test(/ cd pl obj dd dait cl sl n os ki )  
  (defun thgoc (ent pt / param)
    (if (setq param (vlax-curve-getParamAtPoint ent pt))
      (- (angle '(0 0 0) (vlax-curve-getFirstDeriv ent param)) (/ pi 2))
      nil)
  )
  
  (setq pl (car (entsel "\nChon Polyline:")))
  (prompt "\nChon doi tuong can rai:")
  (setq ss (ssget)
        dd (getpoint "\nDiem bat dau rai (nam tren Polyline) :")
        dc (getpoint "\nDiem cuoi cung rai (nam tren Polyline) :")
        cd (getreal "\nNhap buoc rai:")
sl (fix (/ (- (vlax-curve-getDistAtPoint pl dc) (vlax-curve-getDistAtPoint pl dd)) cd))
        os (getvar "OSMODE"))  
 
 (setvar "OSMODE" 0)
 (repeat sl
   (setq el (entlast)
ang (thgoc pl dd))
   (command "copy" ss "" dd (setq dd1 (vlax-curve-getPointAtDist pl (+ cd (vlax-curve-getDistAtPoint pl dd)))))
   (setq ss (ssadd)
dd dd1
ang1 (thgoc pl dd))
   (while (setq en (entnext el))
      (ssadd en ss)
      (setq el en))
   (command "rotate" ss "" dd "r" dd (polar dd ang 1) (polar dd ang1 1))
 )  
 (setvar "OSMODE" os)
 (princ)
)

Lips gốc thì em dùng được, lips này em dùng ko thấy hiện kết quả, bác xem lại giúp em với ạ.

<<

bạn thử dùng cái này có được không:

(DEFUN C:DT1(/ A)
  (SETQ A (GETPOINT "CHON DIEM : "))
  (COMMAND "BOUNDARY" A "")
...
>>

bạn thử dùng cái này có được không:

(DEFUN C:DT1(/ A)
  (SETQ A (GETPOINT "CHON DIEM : "))
  (COMMAND "BOUNDARY" A "")
  (COMMAND "AREA" "O" (SSGET "L"))
  (COMMAND "ERASE" (SSGET "L") "")
 (command "-style" "text" "Times New Roman" 2.5 "1" "0" "n" "n") ;;;;Muon sua Text to hay nho 2.5 ...
  (command "-layer" "m" "Text""c" "White" "" "")
(setq e_lst (entget (tblobjname "style" (getvar 'textstyle))))
(entmod (subst (cons 50 0.261799) (setq old (assoc 50 e_lst)) e_lst))
  (command "text" "j" "tl" A "" (strcat "DT: " (rtos (/ (* (GETVAR "AREA") 10) 10) 2 2) " m²"))
(entmod (subst old (assoc 50 e_lst) e_lst))
  (PRINC "\nDIEN TICH LA : ")(PRINC  (/ (* (GETVAR "AREA") 10) 10))(PRINC" m²")(prompt "\nDA TINH XONG DIEN TICH!")(princ))

Lisp của bác hay quá, cảm ơn bác đã share cho em

<<

 

bạn thử dùng cái này có được không:

(DEFUN C:DT1(/ A)
  (SETQ A (GETPOINT "CHON DIEM : "))
  (COMMAND...
>>

 

bạn thử dùng cái này có được không:

(DEFUN C:DT1(/ A)
  (SETQ A (GETPOINT "CHON DIEM : "))
  (COMMAND "BOUNDARY" A "")
  (COMMAND "AREA" "O" (SSGET "L"))
  (COMMAND "ERASE" (SSGET "L") "")
 (command "-style" "text" "Times New Roman" 2.5 "1" "0" "n" "n") ;;;;Muon sua Text to hay nho 2.5 ...
  (command "-layer" "m" "Text""c" "White" "" "")
(setq e_lst (entget (tblobjname "style" (getvar 'textstyle))))
(entmod (subst (cons 50 0.261799) (setq old (assoc 50 e_lst)) e_lst))
  (command "text" "j" "tl" A "" (strcat "DT: " (rtos (/ (* (GETVAR "AREA") 10) 10) 2 2) " m²"))
(entmod (subst old (assoc 50 e_lst) e_lst))
  (PRINC "\nDIEN TICH LA : ")(PRINC  (/ (* (GETVAR "AREA") 10) 10))(PRINC" m²")(prompt "\nDA TINH XONG DIEN TICH!")(princ))

Nhờ các bác coi giúp em lỗi em sửa dòng (COMMAND "BOUNDARY" A "") thành (COMMAND "BOUNDARY"  "A" "I" "N" "" "" PAUSE ""  )  để nó bỏ qua không boundary đối tượng là Mtext và Dim, nhưng nó lại phải pick 2 lần mới ra diện tích, em muốn pick chuột 1 cái vào ô cần tính diện tích là hiện diện tích luôn mà không biết lỗi chỗ nào, cảm ơn các bác

<<

Download lisp

Filename: 404456_dt1.lsp

 

OK ! :D

Đã update lisp theo ý bạn và sự chỉ điểm của bác ndtnv

 

p/s:

Dẫu biết bạn chỉ có tối đa...

>>

 

OK ! :D

Đã update lisp theo ý bạn và sự chỉ điểm của bác ndtnv

 

p/s:

Dẫu biết bạn chỉ có tối đa điện 3 pha A B C.

Nhưng mình đang luyện bài nên nếu bạn muốn thì code trên có thể nâng lên thành n pha :D

 

>>> Cảm ơn bác ndtnv đã chỉ điểm, mình học được khá nhiều từ bác !

;;;lisp danh so cot den
(defun c:SCD( / st str lst_pha i p vi_tri chu str1)
(vl-load-com)
(setq	#tu (NGT #tu "1" getstring "Tu chieu sang so")
		#lo (NGT #lo "1" getstring "Lo so")
		#st (NGT #st 1 getint "STT cot dau tien")
		st (1- #st)
		str (strcat "TCS" #tu "/L" #lo "/")
		)
;;;========+++++++++++
;Thay doi, them bot lst_pha o day:
(setq lst_pha '("A" "B" "C"))
;;;=======++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;;
(defun add_space (str) (strcat str " "))
(defun add_solidus (str) (strcat str "/"))
(initget 1 (strcat (apply 'strcat (mapcar 'add_space (reverse (cdr (reverse lst_pha))))) (last lst_pha)))
(setq #pha (NGT #pha "A" getkword (strcat "Pha dau tien ")))
;;;========
(setq #text_h (NGT #text_h 2.5 getint "Chieu cao chu"))
(setq i -1)
(while (setq p (getpoint "\nPick: "))
	(setq i (1+ i)
		  st (1+ st)
		  vi_tri (vl-position (strcase #pha) lst_pha)
		  chu (nth (rem (+ i vi_tri) (length lst_pha)) lst_pha)
		  str1 (strcat str (itoa st) chu)
		  )
	(MakeText p str1 #text_h 0 "L" nil nil 2 nil)
)	;while
)
;;;==================================================
(defun NGT(a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
	((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
	(modul)
	(a)
	)
	)
)
;;;=================================================
(defun MakeText (point string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial	
(setq Lst (list '(0 . "TEXT")
				(cons 8 (if Layer Layer (getvar "Clayer")))									
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 Height)									
				(cons 1 string)									
				(if Ang (cons 50 Ang))									
				(cons 7 (if Style Style (getvar "Textstyle")))									
				(cons -3 (if xdata (list xdata) nil)))				
				justify (strcase justify))	
				(cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))				
					  ((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))				
					  ((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))				
					  ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))					
					  ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))				
					  ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
					  )	
					  (entmakex Lst)
);end
;=================================

Mình đã giùng thử Lisp của bạn nhưng mình thấy có 1 chỗ chưa được tốt cho lắm là chữ không nằm sát với đối tượng được đánh thư tự hy vọng bạn chỉ lỗi này cho đẹp hơn

<<

Download lisp

Filename: 394546_scd.lsp

Lisp xuất toàn bộ Text/Mtext trên bản vẽ ra file txt cùng tên với bản vẽ.

;Doan Van Ha - CADViet.com - Ngay...
>>

Lisp xuất toàn bộ Text/Mtext trên bản vẽ ra file txt cùng tên với bản vẽ.

;Doan Van Ha - CADViet.com - Ngay 13/6/2012
;Muc dich: Xuat tat ca *Text tren ban ve ra file txt cung ten voi ban ve.
(defun C:HA( / lst fn pw)
(princ "\Chon cac Text/Mtext can xuat ra file...")
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT")))))))
(setq fn (strcat (getvar "dwgprefix") (vl-string-subst "txt" "dwg" (getvar "dwgname"))))
(setq pw (open fn "w"))
(foreach ent lst
 (write-line (cdr (assoc 1 (entget ent))) pw))
(close pw)
(princ))

Bác có thể viết thêm được lips xuất các điểm cao độ từ bản vẽ khảo sát sang file text theo dạng "STT_ X_Y_0 cao do" để có thể chạy được trên HS không ạ?

<<

 

Cảm ơn bạn đã phát hiện ra lỗi này. Tue_NV đã nhầm trong quá trình tính toán.

Xin gửi lại bạn Lisp offset liên tục về 1 bên,...

>>

 

Cảm ơn bạn đã phát hiện ra lỗi này. Tue_NV đã nhầm trong quá trình tính toán.

Xin gửi lại bạn Lisp offset liên tục về 1 bên, offset liên tục về 2 bên hoàn chỉnh

(defun c:olt(/ ss po p1 p2 m n kc oldos)(vl-load-com)(setvar "cmdecho" 0)(setq oldos (getvar "osmode"))(setvar "osmode" 0)(while (null (setq ss (car(entsel "\n Chon doi tuong offset :")))) (Prompt "\n Hay chon lai doi tuong :"))(setq po(getpoint "\n phia offset:")) (if (not kco) (setq kco 100))(setq kc (getdist(strcat "\n khoang cach offset: < " (rtos kco) " > :")))(if (not kc) (setq kc kco) (setq kco kc)) (setq n (getint "\n so lan offset:"))(setq m 0 )(setq p1 (vlax-curve-getClosestPointTo ss po))(setq p2 (list (- (* 2 (car p1)) (car po)) (- (* 2 (cadr p1)) (cadr po)) 0.0))(repeat n(setq m(+ m 1))(command "offset" (* m kc) ss po "")) (initget "Y N") ;;;Init keywords(setq ans (getkword "\n Ban co muon offset sang 2 ben khong?  :")) ;;;Get answer from user(if (= ans "Y") (Progn(setq m 0 )(repeat n(setq m(+ m 1))(command "offset" (* m kc) ss p2 "")) ))(setvar "osmode" oldos)(setvar "modemacro" "\nCHUC BAN LAM VIEC HIEU QUA - tue_nvcc@yahoo.com")(princ))

 

Của Tue_LV thì khi Upload nó báo thế này: 

 

Command: ap

APPLOAD olt.lsp successfully loaded

Command: ; error: malformed list on input

 

 

 

Command: ap

APPLOAD olt (1).lsp successfully loaded.

 

 

Command: ; error: malformed list on input

Command: ap

APPLOAD olt (1).lsp successfully loaded.

 

 

Command: ; error: malformed list on input

APPLOAD olt (1).lsp successfully loaded.

Command: ; error: malformed list on input

;;ketxu KCVN jsc(defun ssnames (selection_set / num lst) (repeat (setq num (sslength selection_set)) (setq num (1- num) lst (cons (ssname selection_set num) lst) ) ) lst)(defun c:oo (/ ss objlst dist)(setq dist (getdist "\nKhoang cach offset: ")) (princ "\nChon doi tuong offset ") (setq ss (ssget '((0 . "*LINE")))) (if ss (progn (setq objlst (mapcar 'vlax-ename->vla-object (ssnames ss))) (foreach obj objlst (vla-offset obj dist) (vla-offset obj (* dist -1)) ) ) ) (princ))

 Còn của Ketxtu khi Upload ko báo lỗi nhưng oánh lệnh OO thì nó ko nhận. 

Các bạn xem giúp mình với.

<<

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os msg1 p1 msg2)
        (setq   os (getvar "Osmode")
	 lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc...
>>

 

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.

;/Day la lenh OFFSET dac biet, sau khi OFFSET xong tu dong doi sang lop hien hanh.
;***********
(defun C:OO (/ lay lt os msg1 p1 msg2)
        (setq   os (getvar "Osmode")
	 lt (getvar "celtype")
                lay (getvar "Clayer")
                msg1 "\nVao khoang cach offset: "
                kc (if msg1 (getreal msg1) kc)
                msg2 (strcat "Chon vat the muon offset:*" (rtos kc) "*")
        );het setq
        (setvar "OSMODE" 512)
        (setq   p1 (getpoint msg2))
(while p1
(command "offset" kc p1 pause "" "chprop" "l" "" "la" lay "lt" lt "")
        (setq   p1 (getpoint msg2))
);het while
        (setvar "OSMODE" os)
)

Mình đã chỉnh sửa như trên nhưng khi dùng lệnh nó vẫn bắt nhập khoảng cách mới.

;***********

 

 

Hề hề hề,

 

Hề hề hề,

Rất xin lỗi bác. Đúng là không được thật vì mình không đọc kỹ code 

Cái cấu trúc (setq msg1 "\n Vao khoang cach offset: ") này mình chưa gặp nên hiểu sai về nó.

Bác hãy thay đổi lại một chút cấu trúc này nhé.

Thay vì :

msg1 "\nVao khoang cach offset: "

kc (if msg1 (getreal msg1) kc)

bác hãy đổi thành:

msg1 (getreal  "\nVao khoang cach offset: ")

kc (if msg1 msg1 kc)

 

Hy vọng nó đáp ứng đúng yêu cầu của bác Một lần nữa mong bác tha lỗi.

<<

Hiện nay em đang sử dụng Autocad 2018.

Không hiểu tại sao khi em load lisp

;; free...
>>

Hiện nay em đang sử dụng Autocad 2018.

Không hiểu tại sao khi em load lisp

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=1160
(defun c:QB (/ blk_id blk_len blk_name blks cur_var ent h header_lsp height i
		 ins j len0 lst_blk msp pt row ss str tblobj width width1 width2 x y)
;;  By : Gia Bach, gia_bach @  www.CadViet.com             ;;
(defun TxtWidth (val h msp / txt minp maxp)
  (setq	txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) h))
  (vla-getBoundingBox txt 'minp 'maxp )
  (vla-Erase txt)
  (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))  )

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

</yes>

thì báo lỗi 

Select objects:  ; error: no function definition: VLAX-ENAME->VLA-OBJECT 

một số lisp em được nhờ viết dùm thì báo lỗi

error: no function definition: vlax-curve-getEndParam

Nhờ mọi người sửa chữa dùm.

Thêm thử dòng (Vl-load-com) trước chữ ( defun TxtWidth...) Xem thế nào. Mấy dòng đầu tiên ấy.

<<

Download lisp

Filename: 415057_qb.lsp

Vừa rồi phải làm một công việc nhàm chán trong AutoCAD, đó là công việc đếm xem trên mặt đứng của một ngôi nhà, có bao nhiêu loại tấm ốp, mỗi tấm ốp có...

>>

Vừa rồi phải làm một công việc nhàm chán trong AutoCAD, đó là công việc đếm xem trên mặt đứng của một ngôi nhà, có bao nhiêu loại tấm ốp, mỗi tấm ốp có kích thước bao nhiêu, và bao nhiêu tấm mỗi loại. Trên mặt đứng, mỗi tấm là một Polyline được tạo bằng lệnh rectangle (có 4 cạnh).

 

Tranh thủ viết được một chương trình AutoLisp để làm công việc này. Khi sử dụng lệnh tkt (thống kê tấm), chương trình sẽ cho kết quả:

 

Command: tkt

Hay chon tam:

Select objects: Specify opposite corner: 264 found

89 were filtered out.

Select objects:

 

So luong cac tam:

461x900: 22 tam

1700x900: 6 tam

2500x900: 108 tam

800x1800: 7 tam

1520x900: 16 tam

2680x900: 16 tam

-------------------------

Mã lệnh AutoLisp:

 

(defun c:tkt( / lstTam ss pp)  
 (defun prone(ent / tt p1 p2 p3 x1 x2 y1 y2 cothem H W)
(defun them(dt)
  (if (equal W (car dt) 1.0)
(if (equal H (cadr dt) 1.0)
  (progn
	(setq cothem t)
	(list W H (1+ (caddr dt)))
  )
  dt
)
dt
  )
)
(setq
  tt (entget ent)
  p1 (assoc 10 tt)
  tt (cdr (member p1 tt))	  
  p2 (assoc 10 tt)
  tt (cdr (member p2 tt))
  p3 (assoc 10 tt)	  
  p1 (cdr p1)	  
  p3 (cdr p3)	  
  x1 (car p1)
  x2 (car p3)
  y1 (cadr p1)
  y2 (cadr p3)	  
  W (abs (- x1 x2))
  H (abs (- y1 y2))	  
  cothem nil
  lstTam (mapcar 'them lstTam)
)
(if (not cothem)
  (setq lsttam
	 (append lsttam (list (list W H 1))
	 )
  )
)	
 )
;;-------- Main ------------------
 (princ "\nHay chon tam: ")
 (setq
ss (ssget '((0 . "LWPOLYLINE")
	(90 . 4))		  
   )
lstTam nil
 )
 (sudung prone ss)  
 (princ "\nSo luong cac tam:")
 (foreach pp lsttam
(princ (strcat "\n" (rtos (car pp)) "x" (rtos (cadr pp)) ": " (itoa (caddr pp)) " tam"))		
 )
 (princ)  
)

Với nguyên tắc của lệnh tkt này, chúng ta có thể phát triển thành chương trình thống kê thanh dàn của kết cấu, chương trình đếm số lượng xe ôtô trong gara, liệt kê các block có trong bản vẽ, block nào xuất hiện mấy lần, ... Là cơ sở của các chương trình thống kê.

 

Rất mong nhận được sự phản hồi khi sử dụng lệnh tkt.

Cảm ơn.

 

Nhờ anh Hoành hướng dẫn dùm tôi khi sử dụng chương trình thống kê như trên thì báo lỗi

error: no function definition: SUDUNG

cảm ơn

<<

Bác Bình nhiệt tình quá. Trong code bác còn cho phép tính cả với từng đoạn 1 của 1 Pline (dù việc này chính chủ topic cũng chưa nghĩ tới)...

>>

Bác Bình nhiệt tình quá. Trong code bác còn cho phép tính cả với từng đoạn 1 của 1 Pline (dù việc này chính chủ topic cũng chưa nghĩ tới) Tks bác.

E cũng đóng góp thêm cách add table. Rộng - cao trong bảng do người dùng tự quyết định

(defun c:btk ( / cao rong iText vla_table 2t e i length1  lstCol lst lstAll fw fn)
(defun Length1(e) (* (getvar "dimlfac")(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))))
(vl-load-com)
(command "undo" "be")
(setq  cao 1.2 rong 5.5 iText (lambda(x y)(vla-settext vla_table i x y)) hText (/ cao 6)
 vla_table (vla-addtable (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) (vlax-3d-point (getpoint "\nChon diem dat BTK :")) 2 4 cao rong)
 2t (lambda(x)(rtos x 2 4))
 i 1 lstAll ""
 lstCol '(0 1 2 3))
(vla-SetTextHeight vla_table acDataRow hText)
(vla-SetTextHeight vla_table acTitleRow (* 1.2 hText))
(vla-settext vla_table 0 0 "BANG THONG KE")
(mapcar 'iText lstCol '("TT" "FROM" "TO" "LENGTH"))
(prompt "\nChon doan can thong ke")
(while (setq e (ssget "_+.:E:S" (list (cons 0 "LINE,*PLINE,ARC,*POLYLINE"))))
(setq  
 e (vlax-ename->vla-object (ssname e 0))
 lst
 (append
  (list (itoa i))
  (list (strcat "X = "  (2t (car (setq st (vlax-curve-getStartPoint e)))) "  Y = " (2t (cadr st))))
  (list (strcat "X = "  (2t (car (setq st (vlax-curve-getEndPoint e)))) "  Y = " (2t (cadr st))))
  (list (2t (length1 e)))
 )
 lstAll (strcat lstAll (vl-string-right-trim  "," (apply 'strcat (mapcar '(lambda(x)(strcat x ",")) lst))) "\n")
)
(vla-InsertRows vla_table (setq i (1+ i)) cao 1)
(mapcar '(lambda(x)(vla-SetCellAlignment vla_table i x acMiddleCenter ))lstCol)
(mapcar 'iText lstCol lst)
)
(if (= (strcase (getstring "\n Ban muon luu sang file cvs khong?? <Y or N>: ")) "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 lstAll fw)
           (close fw)
  )
)
(command "undo" "end")
(princ)
)

Cám ơn bạn ketxu nữa, Hôm trước bạn nói bận mà vẫn để tâm giúp mình! Lisp của bạn xuất ra kết quả rất nhanh chóng, nhưng khi bắt điểm theo thứ tự đoạn D1->D2->D3->D4->D5->D6->D7->D8->D9->D10->D11->D12->D13 thì cũng bị lỗi đoạn thứ 11 (tức là D11 theo hình vẽ) như của bác Pham Thanh Binh ( không biết bác ấy có phải tên chính xác là Phạm Thanh Bình không?). còn khi bắt điểm theo thứ tự không lần lượt theo cách chọn đoạn D1->D2->D3->D9->D10->D11->D12->D13 thì cũng bị lỗi đoạn thứ 7 (cũng tức là D11 theo hình vẽ) Bạn có thể xem lại một chút không?

<<

Không đơn giản vậy, không riêng gì lệnh line, còn các lệnh khác thì sao? Nhất là các lệnh trong nhóm modify, như stretch chẳng hạn, rất khó xử lý. Đã làm thì phải triệt để,...

>>

Không đơn giản vậy, không riêng gì lệnh line, còn các lệnh khác thì sao? Nhất là các lệnh trong nhóm modify, như stretch chẳng hạn, rất khó xử lý. Đã làm thì phải triệt để, không thể nửa vời được.

Chiều ý các bạn, mình đã làm thử 1 đoạn sau, chỉ riêng cho lệnh line. Khi bạn dùng chuột định hướng và nhập số thì không có vấn đề gì, nhưng khi sử dụng object snap bạn sẽ thấy nó thế nào ấy. Mình muốn bắt dính vào một điểm, nó không vẽ đến đó mà chạy đi đâu mất tăm! Nói thật tình, mình không mê lập các chương trình loại này, và vẫn khuyến khích các bạn luôn luôn vẽ đúng kích thước thật và dùng layout để trình bày.

 

(defun C:LK( / k p1 p2 a L oldos);;;Line command with scale factor k
(if (not scf) (setq scf 1.0))
(setq k (getreal (strcat "\nScale factor <" (rtos scf) ">:" )))
(if (not k) (setq k scf) (setq scf k))
(setq p1 (getpoint "\nFrom point:"))
(setq oldos (getvar "osmode"))
(while (setq p2 (getpoint p1 "\nNext point:"))
(setq
	a (angle p1 p2)
	L (* k (distance p1 p2))
	p2 (polar p1 a L)
)
(setvar "osmode" 0)
(command "line" p1 p2 "")
(setvar "osmode" oldos)
(setq p1 p2)
)
)

thanks bác Ssg về đoạn lisp này

đúng như bác nói thì khi sdụng lisp này thì phải lăn tăn mình đang ở tỉ lệ nào thật vì đoạn lisp này bắt ta nhập scale factor khi vẽ. vấn đề mình muốn hỏi là:bác có thể chỉnh lại lisp trên để khi mình đang ở tỷ lệ hiện hành thì lisp sẽ tự động scale mà không phai nhập scale factor khong?

yêu cầu có lẽ hơi khó. mong bác cho mấy đàn em được nở mày nở mặt. hi` hì.

chúc bác thành công!

Mình đồng ý với quan điểm của bác pooh_21. nếu có lện này thì người dùng khỏi phải tính toán khi vẽ và không quan trọng mình đang ở tỷ lệ nào. Ví dụ Dim hiện hành là 25 thì tự động nhân 4, dim 20 thì nhân 5, dim 50 thì nhân 2.... vì khi mình khai dimension style mình đã nhập hệ số scale factor rùi.

<<

em chịu thôi hàm này khó em nhờ quá bác ráp zô lisp này giùm em với sort chỗ các polyline được chọn  biến (dt) ấy

(defun c:yeah ( / dt dt1 dt2 rec1 rec2 pt ss)

(if (not sc3) (setq sc3 2))
(setq sc1 (getreal (strcat "\nChi\U+1EC1u cao Text <")))
(if (not sc1) (setq sc1 sc3) (setq sc3 sc1))
(setq sc9 (cdr (assoc 1 (entget (car (entsel "\nChon Text Ly Trinh  : "))))))
(setq dt (ssget '((0 ....
>>

em chịu thôi hàm này khó em nhờ quá bác ráp zô lisp này giùm em với sort chỗ các polyline được chọn  biến (dt) ấy

(defun c:yeah ( / dt dt1 dt2 rec1 rec2 pt ss)

(if (not sc3) (setq sc3 2))
(setq sc1 (getreal (strcat "\nChi\U+1EC1u cao Text <")))
(if (not sc1) (setq sc1 sc3) (setq sc3 sc1))
(setq sc9 (cdr (assoc 1 (entget (car (entsel "\nChon Text Ly Trinh  : "))))))
(setq dt (ssget '((0 . "LWPOLYLINE"))))

(setq sdt (sslength dt)
K SDT
i 0)
(while
(setq dt1 (ssname dt i)


dt2 (ssname dt (1+ i))
i (1+ i)
K (- K 1)

rec1 (acet-geom-vertex-list dt1)




rec2 (acet-geom-vertex-list dt2)

pt (nth 0 rec1)

)

(if (and (< (car (nth 0 rec1)) (car (nth 2 rec1))) (< (car (nth 0 rec2)) (car (nth 2 rec2))))
(setq ss (append rec1 (reverse rec2) (list pt))))
(if (and (> (car (nth 0 rec1)) (car (nth 2 rec1))) (> (car (nth 0 rec2)) (car (nth 2 rec2))))
(setq ss (append rec1 (reverse rec2) (list pt))))
(if (and (< (car (nth 0 rec1)) (car (nth 2 rec1))) (> (car (nth 0 rec2)) (car (nth 2 rec2))))
(setq ss (append rec1 rec2 (list pt))))
(if (and (> (car (nth 0 rec1)) (car (nth 2 rec1))) (< (car (nth 0 rec2)) (car (nth 2 rec2))))
(setq ss (append rec1 rec2 (list pt))))



(acet-pline-make (list ss))
(command "area" "o" (entlast))
(setq dientich (getvar "area"))

(setq s (strcat (rtos dientich 2 2)))
(command "INSERT" "DIENTICHL" (nth 1 rec2) SC1 SC1 0 sc9 K S)
)

(princ "\nThanks for Using - Ho\U+00E0ng Long Auto Lisp
Phone:0933118500
Mail:longnguyen4563@gmail.com")
(PRINC))

 

Lisp của bác đây:

;========LISP OFFSET==========
;====KANGKUNG 28/03/2013======
(defun C:LG12()
  (command...
>>

 

Lisp của bác đây:

;========LISP OFFSET==========
;====KANGKUNG 28/03/2013======
(defun C:LG12()
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq dt (car(entsel)) i (/ pi 2))
  (repeat 2
    (setq pt (polar (vlax-curve-getPointAtDist dt 0) (+ (angle (vlax-curve-getPointAtDist dt 0) (vlax-curve-getPointAtDist dt (+ 0 0.1))) i) 1))
    (of "3" pt "00_Mep duong")
    (of "6" pt "00_Mep he")
    (setq i (/ pi -2))
    )
  (setvar "OSMODE" os)
  (command "UNDO" "END")
  )
(defun C:LG13()
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq dt (car(entsel)) i (/ pi 2))
  (repeat 2
    (setq pt (polar (vlax-curve-getPointAtDist dt 0) (+ (angle (vlax-curve-getPointAtDist dt 0) (vlax-curve-getPointAtDist dt (+ 0 0.1))) i) 1))
    (of "3.5" pt "00_Mep duong")
    (of "6.5" pt "00_Mep he")
    (setq i (/ pi -2))
    )
  (setvar "OSMODE" os)
  (command "UNDO" "END")
  )
(defun of(di pt la)
  (command "offset" di dt pt "")
  (if (= (tblsearch "Layer" la) nil)
    (progn
      (command "LAYER" "N" la "")
      (vla-put-layer (vlax-ename->vla-object (entlast)) la))
    (vla-put-layer (vlax-ename->vla-object (entlast)) la)))
(princ "\n                Written By KangKung - 28/03/2013\n")

Nhờ các anh giúp em sửa cái lisp trên để khi ta chon tim đường thì nó sẽ offset sang 2 bên, với khoảng cách là 6m từ tim và đổi màu 2 đối tượng vừa offset sẽ thuộc layer màu xanh và và có nét chấm chấm như đoạn code này với ạ: 

(COMMAND "-LAYER" "M" "Lo gioi" "COLOR" 3 "" "")

...........................................

(COMMAND "CHPROP" A PAUSE "C" "GREEN" "LA" "LO GIOI" "lT" "DOT" "S" "2.5" "LW" "0.5" "")

<<

Hề hề hề,

Bạn chịu khó down lại từ đây vậy

 

(defun c:vnc (/ oldos p1 p2 p3 p4 p5...
>>

Hề hề hề,

Bạn chịu khó down lại từ đây vậy

 

(defun c:vnc (/ oldos p1 p2 p3 p4 p5 p6)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq p1 (getpoint "\n Chon diem dau cua net cat: ")
          p2 (getpoint p1 "\n Chon diem cuoi cua net cat: ")
          d (distance p1 p2)
          a (angle p1 p2)
) 
(command "line" p1 (setq p3 (polar p1 a (- (/ d 2) (/ d 25))))
                                   (setq p4 (polar p3 (- a (/ pi 2)) (/ d 10)))
                                   (setq p5 (polar (setq p6 (polar p2 (+ a pi) (- (/ d 2) (/ d 25)))) (+ a (/ pi 2)) (/ d 10)))
                                   p6 p2 "")
(setvar "osmde" oldos)
(princ)
)

 

Hy vọng không còn bị lỗi bởi trang download của diễn đàn cũng chưa được hoàn toàn ngon.

Chúc thành công.

Cảm ơn bác lisp của bác đúng với ý em, nhưng có vấn đề là: sau khi dùng lệnh: VNC  enter => đến bước "chọn điểm đầu của nét cắt" là không hiện truy bắt điểm và sau khi vẽ xong nét cắt là mất hết truy bắt điểm.

Bác khắc phục lỗi này giúp em được không ah 

<<

Chương trình dành cho bạn đây, kèm theo comment cho từng dòng lệnh.

Lưu ý: block của bạn chứa các attrib: CD_TN, CD_TK và CH_CAO phải được xếp đúng theo thứ tự đã nêu (nếu...

>>

Chương trình dành cho bạn đây, kèm theo comment cho từng dòng lệnh.

Lưu ý: block của bạn chứa các attrib: CD_TN, CD_TK và CH_CAO phải được xếp đúng theo thứ tự đã nêu (nếu không sẽ xảy ra tình trạng "râu ông nọ cắm cằm bà kia"). Không đúng thứ tự cũng được nhưng phải viết lại code.

Bạn hiểu được toàn bộ code dưới đây sẽ tự bổ sung, phát triển chương trình theo ý thích. Mình vẫn khuyến khích các bạn tự làm, vướng mắc chỗ nào mình sẵn sàng giải đáp hoặc gợi ý thêm.

 

;;;--------------------------------------------------------------------
(defun ss2ent (ss / i Le e) ;;;Convert ss to list of ename
(setq i 0 Le nil)
(repeat (sslength ss) 
   (setq
       e (ssname ss i)
       Le (append Le (list e))
       i (1+ i)
   )
)
Le
)
;;;--------------------------------------------------------------------
(defun getntv(sst p / Lt) ;;;Get Nearest Text Value in sst from p
(setq
   Lt (ss2ent sst)
   neap (lambda (x y)
                (<
                (distance p (cdr (assoc 10 (entget x))))
                (distance p (cdr (assoc 10 (entget y))))
                )
            )
   Lt (vl-sort Lt 'neap)
)
(cdr (assoc 1 (entget (car Lt))))
)
;;;--------------------------------------------------------------------
(defun C:UPH(/ e p t1 t2 t3 e1 e2 e3 d1 d2 d3) ;;;UPdate Height
(setq
   e (car (entsel "\nSelect height block:")) ;;;Select block
   p (cdr (assoc 10 (entget e))) ;;;Insert point of block
   t1 (getntv (ssget "X" '((0 . "TEXT") (62 . 3))) p) ;;;Green text value nearest from p
   t2 (getntv (ssget "X" '((0 . "TEXT") (62 . 1))) p) ;;;Red text value nearest from p
   t3 (rtos (- (atof t2) (atof t1))) ;;;Subtract
   e1 (entnext e) ;;;Attrib CD_TN entity
   e2 (entnext e1) ;;;Attrib CD_TK entity
   e3 (entnext e2) ;;;Attrib CH_CAO entity
   d1 (entget e1) ;;;Get data1
   d1 (subst (cons 1 t1) (assoc 1 d1) d1) ;;;Change data1
   d2 (entget e2) ;;;Get data2
   d2 (subst (cons 1 t2) (assoc 1 d2) d2) ;;;Change data2
   d3 (entget e3) ;;;Get data3
   d3 (subst (cons 1 t3) (assoc 1 d3) d3) ;;;Change data3
)
(entmod d1) ;;;Modify e1
(entmod d2) ;;;Modify e2
(entmod d3)  ;;;Modify e3
(command "regen") ;;;Regenerating
(princ) ;;;Silent quit
)
;;;--------------------------------------------------------------------

Trước mắt mình cảm ơn ssg

Thực ra mình ý thức việc tự thực hiện các ý tưởng của của mình nhưng mà bí rồi mới nhờ anh em

Mình thấy có nhiều ông cứ tưởng diễn đàn này là nơi "làm từ thiện" nên có nhiều đòi hỏi thái quá

Thực ra đoạn yêu cầu trên là một phần trong việc lập cách giải quyết một vấn đề dài ngoằn nhưng mà mình không nêu ra vì những đoạn khác mình làm được . mình đang muốn học lisp mà

<<