Bác PhamThanhBinh thật là con người chịu khó, cần mẫn, nhiệt tình và đặc biệt là rất thích mót. Hề hề hề. Biết bao giờ mót được nhiều như bác ấy nhở. Mình lại mót lại của bác ây đấy mà. Hii. Cũng dựa vào của bác Bình em thêm cho bạn ấy cái xuất tọa độ vừa đánh dấu cọc cho bạn đấy này. Hiii

(defun c:XTDA(/  ent i obj pos ss str Stt tmp z zero) ;;;;Xuat toa do...
>>

Bác PhamThanhBinh thật là con người chịu khó, cần mẫn, nhiệt tình và đặc biệt là rất thích mót. Hề hề hề. Biết bao giờ mót được nhiều như bác ấy nhở. Mình lại mót lại của bác ây đấy mà. Hii. Cũng dựa vào của bác Bình em thêm cho bạn ấy cái xuất tọa độ vừa đánh dấu cọc cho bạn đấy này. Hiii

(defun c:XTDA(/  ent i obj pos ss str Stt tmp z zero) ;;;;Xuat toa do Attribute voi ten BANGTOADO
 (vl-load-com)
 (princ "\nChon doi tuong can xuat thuoc tinh :" )
 (if (and
(setq ss (ssget (list (cons 0 "INSERT")(cons 2 "BANGTOADO"))))
(setq tmp (getfiled "Ten file xuat toa do" (getvar "dwgprefix") "CSV" 1))  )
   (progn
     (setq tmp (open tmp "a") i -1)
     (while (setq ent (ssname ss (setq i (1+ i))))
(setq obj (vlax-ename->vla-object ent))
(foreach att (vlax-invoke obj 'GetAttributes)
  (cond
    ( (= (vla-get-TagString att) "YYYYYY.YYYY")
      (setq Y (vla-get-TextString att)) )
    ( (= (vla-get-TagString att) "XXXXXX.XXXX")
      (setq X (vla-get-TextString att)) ))  )
(write-line (strcat Y "," X) tmp))
     (close tmp)) )
 (princ)
)

P/s: Bác Bình xem lại lúc chọn cọc thì ta nên để chế độ bắt điểm chứ. Vị trí đặt bảng tọa độ mới tắt đi mà. hii

hềhề. Cái này để các anh cao siêu nghĩ kế, e chỉ đưa được yêu cầu thế, còn lời giải thì thuộc về lisp manager rùi, hí hí. đúng...

>>

hềhề. Cái này để các anh cao siêu nghĩ kế, e chỉ đưa được yêu cầu thế, còn lời giải thì thuộc về lisp manager rùi, hí hí. đúng là có nhiều trường hợp các đường bóng sẽ ko song song với nhau. nhưng mà lập trình để làm cho lisp hiểu đúng và tự động vẽ ra sao cho đúng thì quả thật là khó. nên ngu kế của em là dùng trong trường hợp nó song song với nhau, khi nó ko song song thì ta kết hợp thủ công ( nói thật là đã đi nhờ mượn thì chỉ muốn nhờ mượn ít ít thui, chứ nhờ mượn mà còn bắt bẻ này nọ thì e ko dám, thấy nó ko thỏa mái trong lòng ) hí hí. Yêu cầu của e là vậy rùi, chắc bi h cả nhà đã hiểu vấn đề. thanks các bác đã quan tâm. Tại e làm ở cty này họ bắt bẻ form của họ quá, nên mình pải làm theo, pải thể hiện theo họ nên pải kẻ bóng nhìu. hí hí. hôm trước bác KETXU viết cho cái lisp kẻ taluy hướng về 1 điểm. Sướng hết cả người. hí hí ! thanks diễn đàn nhìu nhìu. có j e sẽ vote cho diễn đàn.

Hề hề hề,

Đây là cái lisp mình thử làm theo cái cách mình hiểu ý của bạn. Hãy test thử xem nó trúng trật ở đâu nhé. Lưu ý khi chọn hai đường biên phải phù hợp với trật tự vẽ của đường chuẩn. Nghĩa là biên thứ nhất phải nằm ở phía điểm bắt đầu của line chuẩn, và biên thứ hai phải nằm về phía điểm cuối của line chuẩn,

Nếu chọn sai bạn sẽ phải chạy lại lisp vì nó sẽ cho cái kết quả không như bạn muốn.

(defun c:kbg ()
(vl-load-com)
(command "undo" "be")
(command "ucs" "w")
(setq e1 (car(entsel "\n Chon duong bien thu nhat"))
       e2 (car(entsel "\n Chon duong bien thu hai"))
       e (car (entsel "\n Chon duong ke chuan"))
       a (getreal "\n Nhap khoang cach chuan: ")
       k (Getreal "\n Nhap he so khoang cach: ")
       p (getpoint "\n Chon huong rai duong ke bong")
       dis (distance p (vlax-curve-getClosestPointTo (vlax-ename->vla-object e) p T)) 
       b 0
)
(while (and (< b dis) (> a 0.01))
    (command "offset" a e p "")
    (setq e (entlast)
            a (* k a)
            b (+ b a)
            ;;;;; pd (vlax-curve-getstartpoint e)
            ;;;;;;pc (vlax-curve-getendpoint e)
    )
    (if (setq p1 (acet-geom-intersectwith e e1 0))
        (progn
              (command "break"  e  (car p1) (vlax-curve-getstartpoint e))
              (setq e (entlast))
        )
        (command "extend" e1 "" (vlax-curve-getstartpoint e) "")
    )

    (if (setq p2 (acet-geom-intersectwith e e2 0))
        (command "break" e  (car p2) (vlax-curve-getendpoint e))
        (command "extend" e2 "" (vlax-curve-getendpoint e) "")
    )
)
(command "undo" "e")
(princ)
)

Hy vọng thỏa mãn được yêu cầu của bạn.

<<

Bạn thử cái dưới đây, nếu không muốn nhập khoảng cách rải thì enter để nhập số khoảng rải.

Bạn có thể chọn bất cứ đối...

>>

Bạn thử cái dưới đây, nếu không muốn nhập khoảng cách rải thì enter để nhập số khoảng rải.

Bạn có thể chọn bất cứ đối tượng nào kể cả text, block... Nhưng chú ý đến góc ban đầu của nó với điểm đầu, các bản sao kế tiếp cũng có góc tương tự so với điểm copy.

 

(defun c:test(/ pl ss dd dc cd tm sl el en ang dd1 ang1 os)
  (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 <Enter neu nhap so khoang rai>:")
tm (- (vlax-curve-getDistAtPoint pl dc) (vlax-curve-getDistAtPoint pl dd)))
  (if (not cd)
    (setq sl (getint "\nNhap so khoang rai:")
 cd (/ tm sl))
    (setq sl (fix (/ tm cd))))
 
 (setq 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)
)

Bác ơi. em chỉ có thể nói một câu nữa. Là quá tuyệt vời bác ạ. Em nghĩ không thể làm tốt hơn được nữa. Em chân thành cảm ơn bác.

 

Bác ơi. em chỉ có thể nói một câu nữa. Là quá tuyệt vời bác ạ. Em nghĩ không thể làm tốt hơn được nữa. Em chân thành cảm ơn bác.

 

PS: bác ơi bác giúp em thêm lựa chọn cho phép rải cả block vào lips ##66 của bác Pham quoc Duy được không ạ? em chờ đợi

mà ko thấy mọi người trả lời.

http://www.cadviet.com/forum/topic/42771-da-xong-lisp-rai-doi-tuong-theo-doong-dan/page-4

<<

Lỗi là do lisp bạn copy sai (thiếu con số 0). Sửa giùm bạn

(defun C:fd( / ss L e #h)
(vl-load-com)
(defun Length1(e) (/ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 1000))
(or ans (setq ans 1))
(setq
   #h 200
   L (strcat "L : "
   (vl-princ-to-string (* (getvar "dimlfac") (apply '+
       (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0...
>>

Lỗi là do lisp bạn copy sai (thiếu con số 0). Sửa giùm bạn

(defun C:fd( / ss L e #h)
(vl-load-com)
(defun Length1(e) (/ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 1000))
(or ans (setq ans 1))
(setq
   #h 200
   L (strcat "L : "
   (vl-princ-to-string (* (getvar "dimlfac") (apply '+
       (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))))) "m"))
   (setq
   ans (cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
   txtObj (cond     ((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
                   (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) L (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))))
(vla-put-TextString txtObj L)
(vla-put-Height txtObj #h)
(princ))

Cảm ơn các bác, cảm ơn bác Tue_NV, đoạn lisp của bác rất hay, nhưng em thấy có 1 vấn đề là lisp chỉ thực hiện được với layer "Hatch",...

>>

Cảm ơn các bác, cảm ơn bác Tue_NV, đoạn lisp của bác rất hay, nhưng em thấy có 1 vấn đề là lisp chỉ thực hiện được với layer "Hatch", khi đổi layer thì không thực hiện được nữa. Ý em là em muốn đổi các đường line mẫu thành riêng 1 layer rồi layiso layer đó lên để chọn được nhiều đường line mẫu 1 lúc thì lisp lại không thực hiện được. Bác Tuệ và các bác cùng xem xét tiếp giúp em nhé

Cảm ơn cả nhà

Mỗi lần quay được với 1 Line mẫu thôi bạn. Các đối tượng chọn với Line mẫu sẽ được quay.

Bạn chú ý rằng vì các Text có cùng Layer với Line mẫu trong bản vẽ bạn upload

nên mình sử dụng Layer của Text cùng với Layer của Line mẫu.

Lisp chỉnh theo ý bạn đây :

(defun c:xolt(/ goc ngon s angmau ang leng d1 d2 d3 d4)
(setq s (car (entsel "Pick vao doi tuong chan Line mau :")))
(setq angmau (angle (acet-dxf 10 (entget s)) (acet-dxf 11 (entget s))))
(setq ang (acet-rtod (getangle "\n Nhap goc quay :")))

(setq leng (vlax-curve-getendparam s) )


(ACET-ERROR-INIT (LIST (LIST "OSMODE" 0) T))
(foreach x (acet-ss-to-list (ssget (list (cons 0 "LINE") (assoc 8 (entget s)))) )
(setq y (entget x))
(setq goc (acet-dxf 10 y))
(setq ngon (acet-dxf 11 y))
  (if (equal (angle goc ngon) angmau 0.001)
    (Progn
(setq d1 (polar (vlax-curve-getpointatdist x (/ leng 10.0)) (+ angmau (/ pi 2.0)) (/ leng 7.0)  ) 
    d2 (polar (vlax-curve-getpointatdist x (/ leng 10.0)) (+ angmau (/ pi -2.0)) (/ leng 7.0) )
    d3 (polar (vlax-curve-getpointatdist x (/ leng 1.20)) (+ angmau (/ pi -2.0)) (/ leng 7.0) )
    d4 (polar (vlax-curve-getpointatdist x (/ leng 1.20)) (+ angmau (/ pi 2.0)) (/ leng 7.0) ) 
)
(command "rotate" (ssget "cp" (list d1 d2 d3 d4) 
(list (cons 0 "LINE,TEXT") (assoc 8 (entget s)))
) ""
goc ang)
    )
  )
)

(ACET-ERROR-RESTORE)
)

<<

Sửa lại đây:

(defun c:test  (/ Make-Line ang bv cdi hbv hcd len msp pd3 po1 po2 po3 po4 pt1 pt2 pt3 pt4 tlv...
>>

Sửa lại đây:

(defun c:test  (/ Make-Line ang bv cdi hbv hcd len msp pd3 po1 po2 po3 po4 pt1 pt2 pt3 pt4 tlv p11 p33)
 (defun Make-Line  (p1 p2 lay)
  (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 8 lay))))
 (vl-load-com)
 (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
       cdi (* (getvar "DIMTXT") (getvar "DIMSCALE")))
 (if (and (setq pt1 (getpoint "\nDiem p1: "))
          (setq pt2 (getpoint "\nDiem p2: "))
          (setq pt3 (getpoint "\nDiem p3: "))
          (setq pt4 (getpoint "\nDiem p4: "))
          (setq hcd (getdist "\nChieu cao dam: "))
          (setq hbv (getdist "\nChieu day bt bao ve: "))
          (setq tlv (getreal "\nTi le ve <Nhap 20 de co ty le 1/20>:")))
  (progn (setq po1 (polar pt3 (* pi 1.0) hcd)
               po2 (polar po1 (* pi (/ 30 180.0)) (* 70 (/ 100 tlv)))
               po3 (polar pt4 (* pi 0.0) hcd)
               po4 (polar po3 (* pi (/ 150 180.0)) (* 70 (/ 100 tlv)))
               ang (angle pt1 pt2)
               pd3 (polar pt1 (+ ang (* pi 1.5)) (* cdi 4)))
         (Make-Line po1 po2 "CAT-THEP")
         (Make-Line po3 po4 "CAT-THEP")
         (setq p11 (inters pt1 pt2 po1 (polar po1 (* pi 1.5) hcd))
               p33 (inters pt1 pt2 po3 (polar po3 (* pi 1.5) hcd)))
         (mapcar (function (lambda (x y z) (vla-adddimaligned msp x y z)))
                 (mapcar 'vlax-3d-point (list pt1 pt2 p11))
                 (mapcar 'vlax-3d-point (list p11 p33 p33))
                 (mapcar 'vlax-3d-point (list pd3 pd3 pd3)))))
 (princ))

P/s: Làm kiểu này thì khai báo chiều dày bt bảo vệ không quan trọng, bạn có thể xóa dòng đó đi.

Nhập 20 mà nó vẫn vẽ tỉ lệ 1:1, bác xem lại giúp, nếu nhập 20 thì x5, 25 thì x4, 10 thì 10, không nhập gì thì tỉ lệ 1:1. Vậy thôi bác. Cảm ơn bác lần nữa.

<<

Download lisp

Filename: 400086_test%C2%A0.lsp

Lisp này dùng cho line, arc, pline, spline. Vì khi lengthen thì phải có 1 đầu cố định và 1 đầu di động nên...

>>

Lisp này dùng cho line, arc, pline, spline. Vì khi lengthen thì phải có 1 đầu cố định và 1 đầu di động nên phải định ra phía cần đổi.

(defun C:ll()
  (vl-load-com)
  (if (not lu) (setq lu 1))
  (setq lu1 (getreal (strcat "\nChieu dai moi  :"))
 ss (ssget '((0 . "LINE,ARC,*POLYLINE,SPLINE")))
 ph (getpoint "Phia cua duong can thay doi:")
 os (getvar "osmode"))
  (if lu1 (setq lu lu1))
  (setvar "osmode" 0)
  (foreach v (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (setq obj (vlax-ename->vla-object v)
   tt10 (vlax-curve-getStartPoint obj)
   tt11 (vlax-curve-getEndPoint obj))
    (if (	 (setq dc tt10)
 (setq dc tt11))
    (command "lengthen" "Total" lu (list v dc) ""))
 (setvar "osmode" os)
)

Chào bạn q288. Cảm ơn bạn vì Code trên. Rất hay

Tuy nhiên, Lisp chạy đúng với line, arc, pline, nhưng không còn đúng với Spline

<<

Còn vấn đề này "các hình chữ nhật có thể bị nổ ra thành line và có thể bị hở nhỏ nữa" thì pótay !

Bạn thử LISP này :

>>

Còn vấn đề này "các hình chữ nhật có thể bị nổ ra thành line và có thể bị hở nhỏ nữa" thì pótay !

Bạn thử LISP này :

(defun c:addLay (/ ent i j layname objci objpl pt_lst ss ssc)
 ;| By : Gia Bach, gia_bach @  www.CadViet.com             |;  
 (vl-load-com)

(defun GetPtLst (obj / anginc arcparam blg delta eparam inc pt ptlst sparam)
 (setq sparam (vlax-curve-getStartParam obj)
eparam (vlax-curve-getEndParam obj)
anginc (* pi (/ 6 180.0)))
 (while (<= sparam eparam)
   (setq pt (vlax-curve-getPointAtParam obj sparam))
   (if (not (equal pt (car ptlst) 1e-12))
     (setq ptlst (cons pt ptlst)))
   (if (and (/= sparam eparam)
      (setq blg (abs (vlax-invoke obj 'GetBulge sparam)))
      (/= 0 blg))
     (progn
(setq delta (* 4 (atan blg)) ;included angle
      inc (/ 1.0 (1+ (fix (/ delta anginc))))
      arcparam (+ sparam inc))
(while (< arcparam (1+ sparam))
  (setq pt (vlax-curve-getPointAtParam obj arcparam)
	ptlst (cons pt ptlst)
	arcparam (+ inc arcparam))))      )
   (setq sparam (1+ sparam))    )
 ptlst)
;main 
 (princ "\nChon Pline : ")
 (if (setq ss (ssget  '((0 . "LWPOLYLINE"))))
   (progn
     (setq i -1)
     (while (setq ent (ssname ss (setq i (1+ i))))
(setq objPL (vlax-ename->vla-object ent)
      pt_lst (GetPtLst objPL)
      ssC (ssget "_WP" pt_lst (list (cons 0 "CIRCLE"))) )
(if ssC
  (progn
    (setq num (sslength ssC))
    (if (> num 255) (setq num (rem num 255)))
    (setq layname (strcat "Layer_" (itoa num) "_Circle") j -1)
    (or (tblsearch "Layer" layname) (vl-cmdf "-layer" "N" layname "c" num layname ""))
    (vla-put-Layer objPL layname)
    (while (setq ent (ssname ssC (setq j (1+ j))))
      (setq objCi (vlax-ename->vla-object ent) )
      (vla-put-Layer objCi layname) ) ) ))))
 (princ))

líp rất hay bác gia_bach ah, bác có thể thêm vào 1 tí nữa ko, trong các đường polyline khép kín có thể ko có vòng tròn mà có text thì nó đưa text và đường polyline về layer có tên text đó luôn, mong tin bác

<<

3 giờ trước, nguyenvinh5779 đã nói:

Xin cám ơn...

>>

3 giờ trước, nguyenvinh5779 đã nói:

Xin cám ơn bạn

nhưng sao không dược bạn oi !

nho bạn chỉnh giúp  !

có thể chỉnh chiều cao chữ bằng cách chọn 02 điểm trên màn hình khong ?

xin cám on ban !

(defun C:fd( / ss L e #h)
(vl-load-com)
(setq ent (car (entsel "\nChon text lay chieu cao text")))
(setq #h (cdr (assoc 40 (entget ent))))
(defun Length1(e) (/ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 1000))
(or ans (setq ans 1))
(setq
   #h 200
   L (strcat "L : "
   (vl-princ-to-string (* (getvar "dimlfac") (apply '+
       (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))))) "m"))
   (setq
   ans (cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
   txtObj (cond     ((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
                   (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) L (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))))
(vla-put-TextString txtObj L)
(vla-put-Height txtObj #h)
(princ))

mình thấy bạn sửa ở trên là xoa #h rồi nên mình chỉ nói thay phần trên, bạn lại thêm #h phía dưới

Sửa lại cho bạn lấy chiểu cao chữ theo chữ mẫu

(defun C:fd( / ss L e #h)
(vl-load-com)
(setq ent (car (entsel "\nChon text lay chieu cao text")))
(setq #h (cdr (assoc 40 (entget ent))))
(defun Length1(e) (/ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 1000))
(or ans (setq ans 1))
(setq
   L (strcat "L : "
   (vl-princ-to-string (* (getvar "dimlfac") (apply '+
       (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))))) "m"))
   (setq
   ans (cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
   txtObj (cond     ((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
                   (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) L (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))))
(vla-put-TextString txtObj L)
(vla-put-Height txtObj #h)
(princ))

<<

23 giờ trước, nguyenvinh5779 đã nói:

Xin cám on bạn...

>>

23 giờ trước, nguyenvinh5779 đã nói:

Xin cám on bạn @huunhantvxdts:

Bạn cho chỉ thêm cho mình : Mình  muốn lấy 2 số thập phân  thì phải chỉnh như thế nào !

Xin cám on ban nhieu .

Gửi bạn

(defun C:fd( / ss L e #h tongcd ent txtObj)
(vl-load-com)
(setq ent (car (entsel "\nChon text lay chieu cao")))
(setq #h (cdr (assoc 40 (entget ent))))
(defun Length1(e) (/ (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)) 1000))
(or ans (setq ans 1))
(prompt "\nChon cac duong tính chieu dai")
(setq tongcd (apply '+ (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))))
;(getvar "dimlfac")
(setq L (strcat "L : " (vl-princ-to-string (rtos (* (getvar "dimlfac") tongcd) 2 2)) "m"))
   (setq
   ans (cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
   txtObj (cond     ((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
                   (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) L (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))))
(vla-put-TextString txtObj L)
(vla-put-Height txtObj #h)
(princ))

 

<<

Thứ này có nhiều.

(defun c:SCT(/ ci tl n i)
 (prompt "\n Moi ban chon CIRCLE/DONUT/BLOCK")
 (setq ci (ssget '((0 . "CIRCLE,LWPOLYLINE,INSERT"))))
 (setq tl (getreal "\n Nhap ti le scale :") n (sslength ci) i 0)
 (while (< i n)
  (setq ent (ssname ci i))
  (if (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
   (command "scale" ent "" (centre ent) tl)
   (command "scale" ent "" (cdr (assoc 10 (entget ent))) tl))
  (setq i (1+...
>>

Thứ này có nhiều.

(defun c:SCT(/ ci tl n i)
 (prompt "\n Moi ban chon CIRCLE/DONUT/BLOCK")
 (setq ci (ssget '((0 . "CIRCLE,LWPOLYLINE,INSERT"))))
 (setq tl (getreal "\n Nhap ti le scale :") n (sslength ci) i 0)
 (while (< i n)
  (setq ent (ssname ci i))
  (if (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
   (command "scale" ent "" (centre ent) tl)
   (command "scale" ent "" (cdr (assoc 10 (entget ent))) tl))
  (setq i (1+ i)))
 (princ))

Vào lúc 31/3/2022 tại 10:36, MrCGIS đã nói:

Em xin chào các anh, hiện...

>>

Vào lúc 31/3/2022 tại 10:36, MrCGIS đã nói:

Em xin chào các anh, hiện tại em có file địa chính có block thông tin thửa bao gồm: số thửa, quy hoạch, diện tích, line .... giờ em muốn scale block này làm sao để nó có thể nằm lọt trong thửa với tâm của nó đặt tại đầu line màu xanh ngay điểm block màu vàng, mong muốn của em là có được lisp scale hoàn loạt đối tượng để block thông tin lọt vào trong thửa để lấy dữ liệu. Mong các anh giúp

Em có để file cad mẫu và hình minh họa ạ em xin cảm ơn.

File mẫu: 

Ban đầu: 

Kết quả: 

 

Drawing4.dwg

Gửi bạn nhé

(defun C:SCBL (/ tl obj blkname pt p1 p2 ssbl doc blkname lay mau)
(setq tl (getreal "\nNhap ti le scale:"))
(princ "\nChon cac Blocks...")
(if (ssget '((0 . "INSERT")));(2 . "CENTRD_1")
(progn
(vlax-for obj (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq blkname (vla-get-Name obj))
	;chuyen doi tuong trong BL thanh mau layer
(if (= blkname "CENTRD_1")
(progn
(setq pt (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint obj))))
(setq p1 (polar pt (/ (* 3 pi) 4) 5))
(setq p2 (polar pt (/ pi -4) 5))
(setq ssbl (ssget "C" p1 p2 '((0 . "INSERT") (-4 . "<NOT") (2 . "CENTRD_1") (-4 . "NOT>"))))
(command "scale" ssbl "" pt tl)
)
)
)
)
)
)

 

<<

22 phút trước, MrCGIS đã nói:

Cảm ơn anh giúp đỡ, nhưng cho em hỏi...

>>

22 phút trước, MrCGIS đã nói:

Cảm ơn anh giúp đỡ, nhưng cho em hỏi với trường hợp gần nhau thì kết quả lisp lại bị sai vị trí có cách nào cho chính xác hơn đc k anh. Với cho em hỏi sao em quét chọn block thì chỉ cho phép chọn số lượng ít thôi còn số lượng nhiều thì không thấy chạy ạ?

Sửa lại cho bạn nhé

(defun C:SCBL (/ tl obj blkname pt p1 p2 ssbl doc blkname lay mau)
(setq tl (getreal "\nNhap ti le scale:"))
(princ "\nChon cac Blocks...")
(if (ssget '((0 . "INSERT")));(2 . "CENTRD_1")
(progn
(vlax-for obj (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq blkname (vla-get-Name obj))
	;chuyen doi tuong trong BL thanh mau layer
(if (= blkname "CENTRD_1")
(progn
(setq pt (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint obj))))
(setq p1 (polar pt (/ (* 3 pi) 4) 1))
(setq p2 (polar pt (/ pi -4) 1))
(vla-ZoomCenter (vlax-get-acad-object) (vlax-3D-point pt) 500)
(setq ssbl (ssget "C" p1 p2 '((0 . "INSERT") (-4 . "<NOT") (2 . "CENTRD_1") (-4 . "NOT>"))))
(command "scale" ssbl "" pt tl)
)
)
)
)
)
)

 

<<

Thực ra cái này làm theo kiểu chọn text rồi xuất ra thì cũng đơn giản, nhưng như chủ thớt nói có mặt cắt lên tới cả 1000 cọc thì việc chọn text sẽ vô cùng khó khăn.

Có cách này nếu chủ thớt đồng ý thì test thử đọan code dưới đây xem sao.

- Chọn đường tự nhiên ( phải là 1 polyline , không để từng line rời rạc)

- Cho tỷ lệ ngang (có thể mặc định)

-...

Thực ra cái này làm theo kiểu chọn text rồi xuất ra thì cũng đơn giản, nhưng như chủ thớt nói có mặt cắt lên tới cả 1000 cọc thì việc chọn text sẽ vô cùng khó khăn.

Có cách này nếu chủ thớt đồng ý thì test thử đọan code dưới đây xem sao.

- Chọn đường tự nhiên ( phải là 1 polyline , không để từng line rời rạc)

- Cho tỷ lệ ngang (có thể mặc định)

- Cho tỷ lệ đứng (có thể mặc định)

- Chọn cái text chứa cao độ cọc đầu

=> Xuất ra file

Đoạn code dưới đây là đoạn thô, nếu sử dụng được thì hoàn thiện thêm

(defun c:c2t (/ caodo datapoint ent g kcach nextpoint)
(if
(and
 	(setq ent (entsel "\nChon POLYLINE, LWPOLYLINE hoac LINE <Exit>:"))
 	(setq datapoint (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget (car ent)))))
 	(if (not (setq tylen  (getint "\nTy le ngang <1000>:"))) (setq tylen 1000) tylen)
 	(if (not (setq tyled  (getint "\nTy le dung <100>:"))) (setq tyled 100) tyled)
 	(setq ent (entsel "\nChon cao do coc dau tien <Exit>:"))
 	(setq caodo (distof (cdr (assoc 1 (entget (Car ent))))))

 )

(progn      

(setq g (open "c:/c2t.csv" "w"))
   	(write-line (strcat "0," (rtos caodo 2 2)) g)
(foreach point datapoint

(setq nextpoint (cadr (member point datapoint)))
   	(if nextpoint
(progn
 (setq kcach (* (- (car nextpoint) (car point)) tylen 0.001))
 (setq caodo (- caodo (* (- (cadr point) (cadr nextpoint)) tyled 0.001)))      
 (write-line (strcat (rtos kcach 2 2) "," (rtos caodo 2 2)) g)
   	))
  	)
(close g)
 ))
 (princ)
 )

Mình biết lệnh select với lựa chọn "f" kg tìm thấy đối tg khi đi qua khoảng trống. Nhưng mình kg hiểu cơ chế chọn của cad là cáí kiểu gì mà kg tìm đc các đg...

>>

Mình biết lệnh select với lựa chọn "f" kg tìm thấy đối tg khi đi qua khoảng trống. Nhưng mình kg hiểu cơ chế chọn của cad là cáí kiểu gì mà kg tìm đc các đg thẳng cắt ngang qua đg "fence". Đôi lúc cad cũng rất "ngớ ngẩn" với một số bài toán khá đơn giản. Với trường hợp trên chỉ cần chọn các đối tg với lựa chọn "c" hoặc "cp", sau đó kiểm tra sự giao nhau của các đối tg với đg "fence" có xét đến bên trong hay ngoài rồi cắt đi là đc. Nếu các bạn làm việc nhiều với các lệnh chọn đối tượng của cad, các bạn sẽ thấy cad còn nhiều "sơ hở", ví dụ việc chọn đối tượng với lựa chọn "cp" đi qua giữa hai đa giác lồng nhau, hay các đối tượng nằm gần đg "fence", cad vẫn chọn nhầm. Hay lệnh tìm đg boundary kg phải lúc nào cũng thành công. Theo mình, lệnh extrim và một số lệnh khác (như boundary...) cần phải đc viết lại. Bác nào đủ bản lĩnh thì ra tay cho anh em mở rộng tầm nhìn (mình kg làm đc)

Theo em thì không nên viết lại. Mình chỉ thay đổi, thêm thắt một chút trong lisp express là có thể khắc phục được lỗi gây ra

Ví dụ:

(defun C:EXX ()
(setq ss (ssget "X"))
(vl-cmdf "CHPROP" ss "" "LT" "Continuous" "")
(C:EXTRIM)
(vl-cmdf "CHPROP" ss "" "LT" "bylayer" "")
)

Đảm bảo là lệnh EXX luôn cắt được. Việc Bylayer chỉ là một ví dụ. Mình có thể lưu lại kiểu đường nét rồi gán lại sau. Đây là một cách để chữa cháy

<<

Mình đang viết Lisp sắp xếp tập hợp các dòng text theo thứ tự tăng dần theo tọa độ Y của dòng Text (Dòng text này nằm ngang). Vì khi mình chọn tập hợp bằng chuột thì...

>>

Mình đang viết Lisp sắp xếp tập hợp các dòng text theo thứ tự tăng dần theo tọa độ Y của dòng Text (Dòng text này nằm ngang). Vì khi mình chọn tập hợp bằng chuột thì nó sẽ xắp xếp tập hợp theo thứ tự chọn trước chọn sau. Mình đau đầu mà vẫn chưa tìm ra được thuật toán giải quyết được vấn đề này. Mọi người giúp mình đoạn code giải quyết vấn đề trên được không

Ví dụ đây bạn:

(defun c:test ()
 (setq	ss  (ssget '((0 . "TEXT")))
lst (ss2ent ss)
lst (vl-sort lst
	     '(lambda (e1 e2)
		(			  (caddr (assoc 10 (entget e1)))
		  (caddr (assoc 10 (entget e2)))
		)
	      )
    )
 )
 (foreach e lst    
   (command ".erase" e "")
   (getstring "\nNhan enter de tiep tuc!")
 )
)

(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)
)

<<

Bạn cũng có thể xem qua các link sau :

http://debian.fmi.uni-sofia.bg/~sergei/cgsr/docs/clockwise.htm

http://forums.autodesk.com/t5/NET/Check-the-drawing-direction-of-a-polyline/m-p/2562006/highlight/true

Bạn cũng có thể xem qua các link sau :

http://debian.fmi.uni-sofia.bg/~sergei/cgsr/docs/clockwise.htm

http://forums.autodesk.com/t5/NET/Check-the-drawing-direction-of-a-polyline/m-p/2562006/highlight/true

http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General/polyline-clockwise-or-counter-clockwise/m-p/2653719

Và tất cả các link GG liên quan đến counterclockwise ^^

Dù ở nhiều ngôn ngữ nhưng mình tin từ thuật toán bạn sẽ chuyển sang VBA được. GL

(defun C:Test( / @delta @cv_parse_list @polydir 2pi e ans)
  ;;-----------------------------------------------------------------------
  ;; This function returns the deflection angle (in radians) of two angles:
  ;;
  (defun @delta (a1 a2)
     (cond
        ((> a1 (+ a2 pi))
           (setq a2 (+ a2 2pi))
        )
        ((> a2 (+ a1 pi))
           (setq a1 (+ a1 2pi))
        )
     )
     (- a2 a1)
  )
  ;;-------------------------------------------------------------
  ;; Function returns a list of 3D points from a continuous list
  ;; as returned by (vlax-safearray->list (vlax-variant-value X))
  ;;
  (defun @cv_parse_list (data n / item new)
     (foreach element (reverse data)
        (setq item (cons element item))
        (if (= (length item) n)
           (setq new (cons item new) item nil)
        )
     )
     new
  )
  (defun @polydir (e / ent etype object coords flag i p1 p2 p3 sum)
     (cond
        ((/= (type e) 'ENAME) nil)
        ((not (vl-position (setq etype (cdr (assoc 0 (setq ent (entget e))))) '("AECC_CONTOUR" "LWPOLYLINE" "POLYLINE")))
           (prompt (strcat " Object selected is a(n) " etype))
        )
        ((and (setq flag (cdr (assoc 70 ent)))(> (boole 1 16 flag) 0))
           (prompt " Object selected is a 3DMESH")
        )
        (1 (setq object (vlax-ename->vla-object e)
                 coords (vlax-get object "Coordinates")
                 coords (@cv_parse_list coords (if (= etype "LWPOLYLINE") 2 3))
                 i 1
                 sum 0.0
           )
           (and
              flag
              (= (logand 1 flag) 1) ; closed
              (setq coords (reverse (cons (car coords)(reverse coords))))
           )
           (repeat (- (length coords) 2)
              (setq p1  (nth (1- i) coords)
                    p2  (nth i coords)
                    i   (1+ i)
                    p3  (nth i coords)
                    sum (+ sum (@delta (angle p1 p2)(angle p2 p3)))
              )
           )
           (if (minusp sum) (princ "\nTheo chieu Kim dong Ho") (princ "\nNguoc chieu Kim dong ho"))
        )
     )
  )
  (setvar "errno" 0)
  (setq 2pi (* pi 2))
  (while (/= (getvar "errno") 52)
     (if (setq ans (@polydir (setq e (car (entsel "\nSelect a polyline: ")))))
        (princ ans)
     )
  )
  (princ)
)

P/S : đó là nói về thuật toán. Còn về thủ thuật, bạn có thể mượn method offset của cad để kiểm tra.

Với offset khoảng cách dương, nếu diện tích đối tượng offset nhỏ hơn Pline gốc : thuận, ngược lại thì là ngược. Như vậy, hàm kiểm tra thuận hay nghịch chiều kim đồng hồ của bạn sẽ là :

Public Function isThuan(oLWP As AcadLWPolyline) As Boolean
Dim oLWPOff As AcadLWPolyline
On Error Resume Next
oLWP.Offset 1
Set oLWPOff = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
isThuan = (oLWP.Area > oLWPOff.Area)
oLWPOff.Delete
Set oLWPOff = Nothing
End Function

Em có chỉnh sửa lisp VK 1 chút cho đúng nhu cầu của em nhưng còn 1 số thứ không biết sửa thế nào. Nhờ các anh sửa giúp em ạ.

Em cảm ơn các anh nhiều!

Các thứ em muốn sửa là: Bóp Width factor của text lại thành 0.8 và bật tất cả chế độ Osnap sau khi chạy xong.

(defun c:VKK( / olmode P1 P2 Tleebd)

    (setvar "PLINEWID"...
>>

Em có chỉnh sửa lisp VK 1 chút cho đúng nhu cầu của em nhưng còn 1 số thứ không biết sửa thế nào. Nhờ các anh sửa giúp em ạ.

Em cảm ơn các anh nhiều!

Các thứ em muốn sửa là: Bóp Width factor của text lại thành 0.8 và bật tất cả chế độ Osnap sau khi chạy xong.

(defun c:VKK( / olmode P1 P2 Tleebd)

    (setvar "PLINEWID" 0)
    (command "Layer" "M" "--KHUNG" "C" "7" "" "")
    (command "_Style" "--KHUNG" "txt.shx" "0" "0.8" "0" "" "" "")

(vl-load-com)
(setq olmode (getvar "OSMODE"))
(setvar "OSMODE" 1)
(setq P1 (getpoint "\n Top Left >>> "))
(setq P2 (getpoint P1 "\n Right Bottom >>> "))
(or *Tleebd* (setq *Tleebd* 1000))
(setq Tleebd (getreal (strcat "\n \n Scale 1/...   <"
          (rtos *Tleebd* 2 0)
         "> :"
      )
 )
)
(if (not Tleebd) (setq Tleebd *Tleebd*) (setq *Tleebd* Tleebd))
(TML1 P1 P2 Tleebd)
(setvar "OSMODE" olmode)
(princ)
)

(defun TML1 (P1 P22 tile_tmp /  Ent Height rau tHeight len_per ob ) ;;;; Tao mat luoi
(vl-load-com)

(setq olmode (getvar "OSMODE"))
(setvar "Osmode" 1)
(setq Height (abs (- (cadr P1) (cadr P22))))
(or #tile (setq #tile 500))
(if tile_tmp (setq #tile tile_tmp))
(setq dis (/ #tile 10.0)
        rau (/ #tile 200.0)
        tHeight  (/ (* 1.7 rau) 5) 		; Chieu cao text
        len_per (/ #tile 125.0) 		; Chieu dai rau
)
(setq WithLine (* 0.6 (/ rau 5))) 		; Chieu rong Pline
(setq olmode (getvar "OSMODE"))
(setvar "Osmode" 0)
(setq P11 (list (car P1) (cadr P22)))
(setq
      Gocxoay (angle P11 P22)
      Kc (distance P11 P22)
      P3 (polar P11 (+ (/ pi 2) Gocxoay) Height)
      P4 (polar P3  Gocxoay  Kc)
)
(command "Pline" P11 P3 P4 P22 P11 "")
(setq e (entlast))
(setq Elast (entlast))
(vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p2)
(mapcar  '(lambda (a b ) (* 0.5 (+ a b )))
(setq p1 (vlax-safearray->list p1)) (setq p2(vlax-safearray->list p2)))
(setq x1 (car p1) x2 (car p2) y1 (cadr p1) y2 (cadr p2) y1_tmp (round+ y1 dis) x1_tmp (round+ x1 dis))
;;; DoX
(while (< y1_tmp y2)
    (setq objLine (ST:Entmake-Line (list x1 y1_tmp) (list x2 y1_tmp)))
    (setq y1_tmp (+ y1_tmp dis)
        lstInter (ST:Ent-IntersObj (entlast) e)
        lstInter (vl-sort lstInter '(lambda (x y) (< (car x)(car y))))
        1st  (car lstInter)
            2nd  (cadr lstInter)
    )
    ;Trai
    (ST:Entmake-Line 1st (mapcar '- 1st (list (* 2 rau) 0 0)))
      (wtxt (substr (rtos (cadr 1st) 2 0) 1 4) (list (- (+ (car 1st) (* 1.5 WithLine)) (* 2 rau)) (+ (cadr 1st) (/ rau 10))) tHeight 0 "L")
      (wtxt  (substr (rtos (cadr 1st) 2 0) 5) (list (- (car 1st) (/ rau 10)) (- (cadr 1st) (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TR")
    ;Phai
    (ST:Entmake-Line 2nd (mapcar '+ 2nd (list (* 2 rau) 0 0)))
      (wtxt (substr (rtos (cadr 2nd) 2 0) 1 4) (list (+ (car 2nd) (/ rau 10)) (+ (cadr 2nd) (/ rau 10))) tHeight 0 "L")
      (wtxt  (substr (rtos (cadr 2nd) 2 0) 5) (list (+ (- (car 2nd) (* 1.5 WithLine)) (* 2 rau)) (-  (cadr 2nd)  (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TR")
 
    (ST:GGBP (car lstInter) (cadr lstInter) dis len_per)                
    (entdel objLine)
)
(ST:Entmake-Line P11 (list (- (car P11) (* 2 rau)) (cadr P11)))
(ST:Entmake-Line P11 (list (car P11) (- (cadr P11) (* 2 rau)) ))

(ST:Entmake-Line P22 (list (+ (car P22) (* 2 rau)) (cadr P22)))
(ST:Entmake-Line P22 (list (car P22) (- (cadr P22) (* 2 rau)) ))

(ST:Entmake-Line P4 (list (+ (car P4) (* 2 rau)) (cadr P4)))
(ST:Entmake-Line P4 (list (car P4) (+ (cadr P4) (* 2 rau))))

(ST:Entmake-Line P3 (list (- (car P3) (* 2 rau)) (cadr P3)))
(ST:Entmake-Line P3 (list (car P3) (+ (cadr P3) (* 2 rau)) ))


(setvar "CECOLOR" "bylayer")
(command "rectangle" "w" WithLine (list (- (car P11) (* 2 rau)) (- (cadr P11) (* 2 rau))) (list (+ (car P4) (* 2 rau)) (+ (cadr P4) (* 2 rau))))
(setvar "CECOLOR" "256")
    ;;DoY
(while (< x1_tmp x2)
    (setq objLine (ST:Entmake-Line (list x1_tmp y1)(list x1_tmp y2)))
    (setq x1_tmp (+ x1_tmp dis)
        lstInter (ST:Ent-IntersObj (entlast) e)
        lstInter (vl-sort lstInter '(lambda (x y) (< (cadr x)(cadr y))))
        1st (car lstInter) 2nd (cadr lstInter)
        )
    ;Duoi
    (ST:Entmake-Line 1st (mapcar '- 1st (list 0 (* 2 rau) 0)))
    (wtxt  (substr (rtos (car 1st) 2 0) 1 3) (list (- (car 1st) (/ rau 10)) (+  (- (cadr 1st) rau) (/ rau 10))) tHeight 0 "TR")
    (wtxt  (substr (rtos (car 1st) 2 0) 4) (list (+ (car 1st) (/ rau 10)) (+  (- (cadr 1st) rau) (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TL")
 
    ;Tren
    (ST:Entmake-Line 2nd (mapcar '+ 2nd (list 0 (* 2 rau) 0 )))
    (wtxt  (substr (rtos (car 2nd) 2 0) 1 3) (list (- (car 2nd) (/ rau 10)) (+  (+ (cadr 2nd) rau) (* 2 (/ rau 10)))) tHeight 0 "TR")
    (wtxt  (substr (rtos (car 2nd) 2 0) 4) (list (+ (car 2nd) (/ rau 10)) (+  (+ (cadr 2nd) rau) (* 2 (/ rau 10))))  (/ (* 2.1 tHeight) 1.7) 0 "TL")
 
    (entdel objLine)
)
(princ)

   (command "-LAYER" "S" "0" "")
   (command "RECTANG" "W" "0" ^C)

)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dinhhcn (P Cdai CCao / ) ;Dinh hinh chu nhat
(setq P2 (Polar P 0 Cdai))
(setq P4 (Polar P (/ pi 2) CCao))
(setq P3 (Polar P4 0 Cdai))
(setq DHV (list P P2 P3 P4 P))
DHV
)

(Defun RTD(x) (/ (* x 180) pi) )
(defun round+ (num prec)
    (if (< 0 prec)
        (* prec
             (if (minusp (setq num (/ num prec)))
                 (fix num)
                 (if (= num (fix num))
                     num
                     (fix (1+ num))
                 )
             )
        )
    num
    )
)

(defun ST:Entmake-Point (pt Len / lstEn)
    (append (list (ST:Entmake-Line (mapcar '- pt (list (/ len 2) 0 0))(mapcar '+ pt (list (/ len 2) 0 0))))
    (list (ST:Entmake-Line (mapcar '- pt (list 0 (/ len 2)  0))(mapcar '+ pt  (list 0 (/ len 2)  0)))))
)
(defun ST:Entmake-Line (p1 p2)(entmakex (list (cons 0 "LINE")(cons 10 p1)(cons 11 p2))))
(defun ST:Ent-IntersObj (e1 e2  / ob1 ob2 g L i kq)
(setq
    ob1 (vlax-ename->vla-object e1)
    ob2 (vlax-ename->vla-object e2)
)    
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
    (setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
    (setq i (+ i 3))
)
kq
)
(defun ST:GGBP (p1 p2 dis len_perLine / x1) ;trai -> phai
        (setq x1 (round+ (car p1) dis))
        (while (< x1 (car p2))
            (ST:Entmake-Point  (list  x1 (cadr p1))    len_perLine)
            (setq x1 (+ x1 dis)))
)

(defun wtxt (string Point Height Ang justify / Lst)
 (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"))))
  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))))))
 (entmake Lst)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 giờ} trướ}c, AutoTay.com đã nói:

Em có chỉnh sửa lisp VK 1 chút...

>>

1 giờ} trướ}c, AutoTay.com đã nói:

Em có chỉnh sửa lisp VK 1 chút cho đúng nhu cầu của em nhưng còn 1 số thứ không biết sửa thế nào. Nhờ các anh sửa giúp em ạ.

Em cảm ơn các anh nhiều!

Các thứ em muốn sửa là: Bóp Width factor của text lại thành 0.8 và bật tất cả chế độ Osnap sau khi chạy xong.

• vkk.lsp
  
•  

(defun c:VKK( / olmode P1 P2 Tleebd)

    (setvar "PLINEWID" 0)
    (command "Layer" "M" "--KHUNG" "C" "7" "" "")
    (command "_Style" "--KHUNG" "txt.shx" "0" "0.8" "0" "" "" "")

(vl-load-com)
(setq olmode (getvar "OSMODE"))
(setvar "OSMODE" 1)
(setq P1 (getpoint "\n Top Left >>> "))
(setq P2 (getpoint P1 "\n Right Bottom >>> "))
(or *Tleebd* (setq *Tleebd* 1000))
(setq Tleebd (getreal (strcat "\n \n Scale 1/...   <"
          (rtos *Tleebd* 2 0)
         "> :"
      )
 )
)
(if (not Tleebd) (setq Tleebd *Tleebd*) (setq *Tleebd* Tleebd))
(TML1 P1 P2 Tleebd)
(setvar "OSMODE" olmode)
(princ)
)

(defun TML1 (P1 P22 tile_tmp /  Ent Height rau tHeight len_per ob ) ;;;; Tao mat luoi
(vl-load-com)

(setq olmode (getvar "OSMODE"))
(setvar "Osmode" 1)
(setq Height (abs (- (cadr P1) (cadr P22))))
(or #tile (setq #tile 500))
(if tile_tmp (setq #tile tile_tmp))
(setq dis (/ #tile 10.0)
        rau (/ #tile 200.0)
        tHeight  (/ (* 1.7 rau) 5) ; Chieu cao text
        len_per (/ #tile 125.0) ; Chieu dai rau
)
(setq WithLine (* 0.6 (/ rau 5))) ; Chieu rong Pline
(setq olmode (getvar "OSMODE"))
(setvar "Osmode" 0)
(setq P11 (list (car P1) (cadr P22)))
(setq
      Gocxoay (angle P11 P22)
      Kc (distance P11 P22)
      P3 (polar P11 (+ (/ pi 2) Gocxoay) Height)
      P4 (polar P3  Gocxoay  Kc)
)
(command "Pline" P11 P3 P4 P22 P11 "")
(setq e (entlast))
(setq Elast (entlast))
(vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p2)
(mapcar  '(lambda (a b ) (* 0.5 (+ a b )))
(setq p1 (vlax-safearray->list p1)) (setq p2(vlax-safearray->list p2)))
(setq x1 (car p1) x2 (car p2) y1 (cadr p1) y2 (cadr p2) y1_tmp (round+ y1 dis) x1_tmp (round+ x1 dis))
;;; DoX
(while (< y1_tmp y2)
    (setq objLine (ST:Entmake-Line (list x1 y1_tmp) (list x2 y1_tmp)))
    (setq y1_tmp (+ y1_tmp dis)
        lstInter (ST:Ent-IntersObj (entlast) e)
        lstInter (vl-sort lstInter '(lambda (x y) (< (car x)(car y))))
        1st  (car lstInter)
            2nd  (cadr lstInter)
    )
    ;Trai
    (ST:Entmake-Line 1st (mapcar '- 1st (list (* 2 rau) 0 0)))
      (wtxt (substr (rtos (cadr 1st) 2 0) 1 4) (list (- (+ (car 1st) (* 1.5 WithLine)) (* 2 rau)) (+ (cadr 1st) (/ rau 10))) tHeight 0 "L")
      (wtxt  (substr (rtos (cadr 1st) 2 0) 5) (list (- (car 1st) (/ rau 10)) (- (cadr 1st) (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TR")
    ;Phai
    (ST:Entmake-Line 2nd (mapcar '+ 2nd (list (* 2 rau) 0 0)))
      (wtxt (substr (rtos (cadr 2nd) 2 0) 1 4) (list (+ (car 2nd) (/ rau 10)) (+ (cadr 2nd) (/ rau 10))) tHeight 0 "L")
      (wtxt  (substr (rtos (cadr 2nd) 2 0) 5) (list (+ (- (car 2nd) (* 1.5 WithLine)) (* 2 rau)) (-  (cadr 2nd)  (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TR")
 
    (ST:GGBP (car lstInter) (cadr lstInter) dis len_per)                
    (entdel objLine)
)
(ST:Entmake-Line P11 (list (- (car P11) (* 2 rau)) (cadr P11)))
(ST:Entmake-Line P11 (list (car P11) (- (cadr P11) (* 2 rau)) ))

(ST:Entmake-Line P22 (list (+ (car P22) (* 2 rau)) (cadr P22)))
(ST:Entmake-Line P22 (list (car P22) (- (cadr P22) (* 2 rau)) ))

(ST:Entmake-Line P4 (list (+ (car P4) (* 2 rau)) (cadr P4)))
(ST:Entmake-Line P4 (list (car P4) (+ (cadr P4) (* 2 rau))))

(ST:Entmake-Line P3 (list (- (car P3) (* 2 rau)) (cadr P3)))
(ST:Entmake-Line P3 (list (car P3) (+ (cadr P3) (* 2 rau)) ))


(setvar "CECOLOR" "bylayer")
(command "rectangle" "w" WithLine (list (- (car P11) (* 2 rau)) (- (cadr P11) (* 2 rau))) (list (+ (car P4) (* 2 rau)) (+ (cadr P4) (* 2 rau))))
(setvar "CECOLOR" "256")
    ;;DoY
(while (< x1_tmp x2)
    (setq objLine (ST:Entmake-Line (list x1_tmp y1)(list x1_tmp y2)))
    (setq x1_tmp (+ x1_tmp dis)
        lstInter (ST:Ent-IntersObj (entlast) e)
        lstInter (vl-sort lstInter '(lambda (x y) (< (cadr x)(cadr y))))
        1st (car lstInter) 2nd (cadr lstInter)
        )
    ;Duoi
    (ST:Entmake-Line 1st (mapcar '- 1st (list 0 (* 2 rau) 0)))
    (wtxt  (substr (rtos (car 1st) 2 0) 1 3) (list (- (car 1st) (/ rau 10)) (+  (- (cadr 1st) rau) (/ rau 10))) tHeight 0 "TR")
    (wtxt  (substr (rtos (car 1st) 2 0) 4) (list (+ (car 1st) (/ rau 10)) (+  (- (cadr 1st) rau) (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TL")
 
    ;Tren
    (ST:Entmake-Line 2nd (mapcar '+ 2nd (list 0 (* 2 rau) 0 )))
    (wtxt  (substr (rtos (car 2nd) 2 0) 1 3) (list (- (car 2nd) (/ rau 10)) (+  (+ (cadr 2nd) rau) (* 2 (/ rau 10)))) tHeight 0 "TR")
    (wtxt  (substr (rtos (car 2nd) 2 0) 4) (list (+ (car 2nd) (/ rau 10)) (+  (+ (cadr 2nd) rau) (* 2 (/ rau 10))))  (/ (* 2.1 tHeight) 1.7) 0 "TL")
 
    (entdel objLine)
)
(princ)

   (command "-LAYER" "S" "0" "")
   (command "RECTANG" "W" "0" ^C)

)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dinhhcn (P Cdai CCao / ) ;Dinh hinh chu nhat
(setq P2 (Polar P 0 Cdai))
(setq P4 (Polar P (/ pi 2) CCao))
(setq P3 (Polar P4 0 Cdai))
(setq DHV (list P P2 P3 P4 P))
DHV
)

(Defun RTD(x) (/ (* x 180) pi) )
(defun round+ (num prec)
    (if (< 0 prec)
        (* prec
             (if (minusp (setq num (/ num prec)))
                 (fix num)
                 (if (= num (fix num))
                     num
                     (fix (1+ num))
                 )
             )
        )
    num
    )
)

(defun ST:Entmake-Point (pt Len / lstEn)
    (append (list (ST:Entmake-Line (mapcar '- pt (list (/ len 2) 0 0))(mapcar '+ pt (list (/ len 2) 0 0))))
    (list (ST:Entmake-Line (mapcar '- pt (list 0 (/ len 2)  0))(mapcar '+ pt  (list 0 (/ len 2)  0)))))
)
(defun ST:Entmake-Line (p1 p2)(entmakex (list (cons 0 "LINE")(cons 10 p1)(cons 11 p2))))
(defun ST:Ent-IntersObj (e1 e2  / ob1 ob2 g L i kq)
(setq
    ob1 (vlax-ename->vla-object e1)
    ob2 (vlax-ename->vla-object e2)
)    
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
    (setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
    (setq i (+ i 3))
)
kq
)
(defun ST:GGBP (p1 p2 dis len_perLine / x1) ;trai -> phai
        (setq x1 (round+ (car p1) dis))
        (while (< x1 (car p2))
            (ST:Entmake-Point  (list  x1 (cadr p1))    len_perLine)
            (setq x1 (+ x1 dis)))
)

(defun wtxt (string Point Height Ang justify / Lst)
 (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"))))
  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))))))
 (entmake Lst)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

Gửi bạn nhé

(defun c:VKK( / olmode P1 P2 Tleebd)

    (setvar "PLINEWID" 0)
    (command "Layer" "M" "--KHUNG" "C" "7" "" "")
    (command "_Style" "--KHUNG" "txt.shx" "0" "0.8" "0" "" "" "")

(vl-load-com)
(setq olmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq P1 (getpoint "\n Top Left >>> "))
(setq P2 (getpoint P1 "\n Right Bottom >>> "))
(or *Tleebd* (setq *Tleebd* 1000))
(setq Tleebd (getreal (strcat "\n \n Scale 1/...   <"
          (rtos *Tleebd* 2 0)
         "> :"
      )
 )
)
(if (not Tleebd) (setq Tleebd *Tleebd*) (setq *Tleebd* Tleebd))
(TML1 P1 P2 Tleebd)
(setvar "OSMODE" olmode)
(princ)
)

(defun TML1 (P1 P22 tile_tmp /  Ent Height rau tHeight len_per ob ) ;;;; Tao mat luoi
(vl-load-com)

;(setq olmode (getvar "OSMODE"))
;(setvar "Osmode" 1)
(setq Height (abs (- (cadr P1) (cadr P22))))
(or #tile (setq #tile 500))
(if tile_tmp (setq #tile tile_tmp))
(setq dis (/ #tile 10.0)
        rau (/ #tile 200.0)
        tHeight  (/ (* 1.7 rau) 5) 		; Chieu cao text
        len_per (/ #tile 125.0) 		; Chieu dai rau
)
(setq WithLine (* 0.6 (/ rau 5))) 		; Chieu rong Pline
;(setq olmode (getvar "OSMODE"))
(setvar "Osmode" 0)
(setq P11 (list (car P1) (cadr P22)))
(setq
      Gocxoay (angle P11 P22)
      Kc (distance P11 P22)
      P3 (polar P11 (+ (/ pi 2) Gocxoay) Height)
      P4 (polar P3  Gocxoay  Kc)
)
(command "Pline" P11 P3 P4 P22 P11 "")
(setq e (entlast))
(setq Elast (entlast))
(vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p2)
(mapcar  '(lambda (a b ) (* 0.5 (+ a b )))
(setq p1 (vlax-safearray->list p1)) (setq p2(vlax-safearray->list p2)))
(setq x1 (car p1) x2 (car p2) y1 (cadr p1) y2 (cadr p2) y1_tmp (round+ y1 dis) x1_tmp (round+ x1 dis))
;;; DoX
(while (< y1_tmp y2)
    (setq objLine (ST:Entmake-Line (list x1 y1_tmp) (list x2 y1_tmp)))
    (setq y1_tmp (+ y1_tmp dis)
        lstInter (ST:Ent-IntersObj (entlast) e)
        lstInter (vl-sort lstInter '(lambda (x y) (< (car x)(car y))))
        1st  (car lstInter)
            2nd  (cadr lstInter)
    )
    ;Trai
    (ST:Entmake-Line 1st (mapcar '- 1st (list (* 2 rau) 0 0)))
      (wtxt (substr (rtos (cadr 1st) 2 0) 1 4) (list (- (+ (car 1st) (* 1.5 WithLine)) (* 2 rau)) (+ (cadr 1st) (/ rau 10))) tHeight 0 "L")
      (wtxt  (substr (rtos (cadr 1st) 2 0) 5) (list (- (car 1st) (/ rau 10)) (- (cadr 1st) (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TR")
    ;Phai
    (ST:Entmake-Line 2nd (mapcar '+ 2nd (list (* 2 rau) 0 0)))
      (wtxt (substr (rtos (cadr 2nd) 2 0) 1 4) (list (+ (car 2nd) (/ rau 10)) (+ (cadr 2nd) (/ rau 10))) tHeight 0 "L")
      (wtxt  (substr (rtos (cadr 2nd) 2 0) 5) (list (+ (- (car 2nd) (* 1.5 WithLine)) (* 2 rau)) (-  (cadr 2nd)  (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TR")
 
    (ST:GGBP (car lstInter) (cadr lstInter) dis len_per)                
    (entdel objLine)
)
(ST:Entmake-Line P11 (list (- (car P11) (* 2 rau)) (cadr P11)))
(ST:Entmake-Line P11 (list (car P11) (- (cadr P11) (* 2 rau)) ))

(ST:Entmake-Line P22 (list (+ (car P22) (* 2 rau)) (cadr P22)))
(ST:Entmake-Line P22 (list (car P22) (- (cadr P22) (* 2 rau)) ))

(ST:Entmake-Line P4 (list (+ (car P4) (* 2 rau)) (cadr P4)))
(ST:Entmake-Line P4 (list (car P4) (+ (cadr P4) (* 2 rau))))

(ST:Entmake-Line P3 (list (- (car P3) (* 2 rau)) (cadr P3)))
(ST:Entmake-Line P3 (list (car P3) (+ (cadr P3) (* 2 rau)) ))


(setvar "CECOLOR" "bylayer")
(command "rectangle" "w" WithLine (list (- (car P11) (* 2 rau)) (- (cadr P11) (* 2 rau))) (list (+ (car P4) (* 2 rau)) (+ (cadr P4) (* 2 rau))))
(setvar "CECOLOR" "256")
    ;;DoY
(while (< x1_tmp x2)
    (setq objLine (ST:Entmake-Line (list x1_tmp y1)(list x1_tmp y2)))
    (setq x1_tmp (+ x1_tmp dis)
        lstInter (ST:Ent-IntersObj (entlast) e)
        lstInter (vl-sort lstInter '(lambda (x y) (< (cadr x)(cadr y))))
        1st (car lstInter) 2nd (cadr lstInter)
        )
    ;Duoi
    (ST:Entmake-Line 1st (mapcar '- 1st (list 0 (* 2 rau) 0)))
    (wtxt  (substr (rtos (car 1st) 2 0) 1 3) (list (- (car 1st) (/ rau 10)) (+  (- (cadr 1st) rau) (/ rau 10))) tHeight 0 "TR")
    (wtxt  (substr (rtos (car 1st) 2 0) 4) (list (+ (car 1st) (/ rau 10)) (+  (- (cadr 1st) rau) (/ rau 10)))  (/ (* 2.1 tHeight) 1.7) 0 "TL")
 
    ;Tren
    (ST:Entmake-Line 2nd (mapcar '+ 2nd (list 0 (* 2 rau) 0 )))
    (wtxt  (substr (rtos (car 2nd) 2 0) 1 3) (list (- (car 2nd) (/ rau 10)) (+  (+ (cadr 2nd) rau) (* 2 (/ rau 10)))) tHeight 0 "TR")
    (wtxt  (substr (rtos (car 2nd) 2 0) 4) (list (+ (car 2nd) (/ rau 10)) (+  (+ (cadr 2nd) rau) (* 2 (/ rau 10))))  (/ (* 2.1 tHeight) 1.7) 0 "TL")
 
    (entdel objLine)
)
(princ)

   (command "-LAYER" "S" "0" "")
   (command "RECTANG" "W" "0" ^C)

)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dinhhcn (P Cdai CCao / ) ;Dinh hinh chu nhat
(setq P2 (Polar P 0 Cdai))
(setq P4 (Polar P (/ pi 2) CCao))
(setq P3 (Polar P4 0 Cdai))
(setq DHV (list P P2 P3 P4 P))
DHV
)

(Defun RTD(x) (/ (* x 180) pi) )
(defun round+ (num prec)
    (if (< 0 prec)
        (* prec
             (if (minusp (setq num (/ num prec)))
                 (fix num)
                 (if (= num (fix num))
                     num
                     (fix (1+ num))
                 )
             )
        )
    num
    )
)

(defun ST:Entmake-Point (pt Len / lstEn)
    (append (list (ST:Entmake-Line (mapcar '- pt (list (/ len 2) 0 0))(mapcar '+ pt (list (/ len 2) 0 0))))
    (list (ST:Entmake-Line (mapcar '- pt (list 0 (/ len 2)  0))(mapcar '+ pt  (list 0 (/ len 2)  0)))))
)
(defun ST:Entmake-Line (p1 p2)(entmakex (list (cons 0 "LINE")(cons 10 p1)(cons 11 p2))))
(defun ST:Ent-IntersObj (e1 e2  / ob1 ob2 g L i kq)
(setq
    ob1 (vlax-ename->vla-object e1)
    ob2 (vlax-ename->vla-object e2)
)    
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
    (setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
    (setq i (+ i 3))
)
kq
)
(defun ST:GGBP (p1 p2 dis len_perLine / x1) ;trai -> phai
        (setq x1 (round+ (car p1) dis))
        (while (< x1 (car p2))
            (ST:Entmake-Point  (list  x1 (cadr p1))    len_perLine)
            (setq x1 (+ x1 dis)))
)

(defun wtxt (string Point Height Ang justify / Lst)
 (setq Lst (list '(0 . "TEXT")
   (cons 8 (if Layer Layer (getvar "Clayer")))
   (cons 62 (if Color Color 256))
   (cons 10 point)
   (cons 41 0.8)
   (cons 40 Height)
   (cons 1 string)
   (if Ang (cons 50 Ang))
   (cons 7 (if Style Style (getvar "Textstyle"))))
  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))))))
 (entmake Lst)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

<<

Mình đi theo hướng như đã nói ở trên.

(defun c:tt  (/ blc cen ent llp mid obj ss1 ss2 urp)
  (if (setq ss1 (ssget '((0 . "INSERT") (2 . "N_THUA_*"))))
    (while (and (setq ent (ssname ss1 0)) (ssdel ent ss1))
      (vla-getboundingbox (setq obj (vlax-ename->vla-object ent)) 'llp 'urp)
      (setq llp (vlax-safearray->list llp)
            urp (vlax-safearray->list urp)
            mid...
>>

Mình đi theo hướng như đã nói ở trên.

(defun c:tt  (/ blc cen ent llp mid obj ss1 ss2 urp)
  (if (setq ss1 (ssget '((0 . "INSERT") (2 . "N_THUA_*"))))
    (while (and (setq ent (ssname ss1 0)) (ssdel ent ss1))
      (vla-getboundingbox (setq obj (vlax-ename->vla-object ent)) 'llp 'urp)
      (setq llp (vlax-safearray->list llp)
            urp (vlax-safearray->list urp)
            mid (mapcar '(lambda (m n) (* (+ m n) 0.5)) llp urp)
            cen nil)
      (cond ((setq ss2 (ssget "C" llp urp '((0 . "INSERT") (2 . "CENTRD_1"))))
             (while (and (setq blc (ssname ss2 0)) (ssdel blc ss2))
               (setq cen (cons (cdr (assoc 10 (entget blc))) cen)))
             (setq cen (vl-sort cen '(lambda (x y) (< (distance mid x) (distance mid y)))))
             (vlax-invoke obj 'scaleentity (car cen) 0.01)))))
  (princ))