23 phút trước, Vũ quang Hiếu đã nói:

Đầu tiên, em xin...

>>

23 phút trước, Vũ quang Hiếu đã nói:

Đầu tiên, em xin gửi lời chào đến các anh, chị trong diễn đàn và chúc diễn đàn ngày càng lớn mạnh

Như tiêu đề, do công việc thường phải làm việc với bản đồ rộng, nhiều khu vực,  vì vậy, mỗi khi Paste Original Coordiantes em phải mất rất nhiều thời gian để tìm được đối tượng vừa Paste. Mong các cao thủ có thể viết giùm em 1 Lisp có chức năng zoom đến đối tượng vừa paste. Em xin cảm ơn và hậu tạ

Nếu kết quả của việc Paste là 1 đối tượng, bạn có thể sử dụng lisp này.

(defun c:zoomLast(/ ll ur)
  (vla-GetBoundingBox (vlax-ename->vla-object (entlast)) 'LL 'UR)
  (vla-zoomwindow (vlax-get-acad-object) ll ur)
  (princ)  )

 

<<

48 phút trước, saycaphe đã nói:

trả lời chất quá bác...

>>

48 phút trước, saycaphe đã nói:

trả lời chất quá bác :).

Bác cho em xin mấy cái lisp như vậy với ạ ;)

 

Em cảm ơn!

(defun C:thich69 (/ a b)
(setq a (getstring T "nhap ten layer:"))
(if (tblsearch "layer" a)
(progn
(setq b (cons 8 a))
(sssetfirst nil (ssget "x" (list b)))
);progn
(alert "khong co layer")
);if
)

layer có dấu cách thì nhập cả dấu cách vào bạn ạ. mà mìn có 1 cái này thôi chứ viết nhiều cái để phục vụ cùng 1 mục đích thì thấy ngu ngu sao ấy.

<<

1 giờ} trướ}c, hoangtienphuchung2014 đã nói:

Ý mình là...

>>

1 giờ} trướ}c, hoangtienphuchung2014 đã nói:

Ý mình là LSP GPMB hôm đầu bạn gửi là Ok rồi! nhưng giờ mình muốn xuất toạ độ tâm block và khoảng cách một loại block bất kỳ  

file_mau_block.dwg

Cái này không biết đúng ý bạn chưa?? tính khoảng cách từ điểm đặt block đến tim tuyến nhé (tâm block trùng điểm đặt bock nếu tâm ở vị trí khác thì bạn phải chuyển điểm đặt block đến đấy nhé)

Lưu ý. Tim tuyến chuyển về đối tượng Polyline nhé

(defun C:XBL (/ cur_lay oldos lsttk timpl pointbl lst tenbl pointvg lytrinh chieudai xlApp xlCells row col sott tieude i)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
;;;;;;;;;;;;;;;;;;;;;;;
(prompt "\nChon doi tuong Block:")
(setq lsttk (ST:acet-ss-to-list (ssget '((0 . "INSERT")))))
(setq lsttk (vl-remove-if-not '(lambda(x) (/= (cdr (assoc 2 (entget x))) "STATIONX"))  lsttk))
;(setq tiento (getstring "\nNhap tien to dien tich:"))
(setq timpl (car (LM:SelectIf "\Chon tim tuyen" (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))) nentsel nil)))

(setq lst nil)
(foreach ent lsttk
(setq pointbl (cdr (assoc 10 (entget ent))))
(setq tenbl (cdr (assoc 2 (entget ent))))
(setq pointvg (vlax-curve-getClosestPointTo timpl pointbl))
(setq chieudai (distance pointbl pointvg))
(setq lytrinh (vlax-curve-getDistAtPoint timpl pointvg))
(setq lst (append (list (list (rtos lytrinh 2 2) (car pointbl) (cadr pointbl) (rtos chieudai 2 2) tenbl)) lst))
)
(setq lst (vl-sort lst '(lambda (x1 x2) (< (atof (car x1)) (atof (car x2))))))
(setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 2 col 1)
(vla-put-visible xlApp :vlax-true)
(setq tieude (list "STT" "Ly trinh" "toa do X" "toa do y" "Khoang cach" "Ten Block"))
(setq i -1)
(repeat (length tieude)
(vlax-put-property xlCells "Item" row (+ col (setq i (1+ i))) (nth i tieude))
)
(setq sott 0)
(foreach in lst
(setq sott (+ sott 1))
(setq i 0 row (1+ row))
(vlax-put-property xlCells "Item" row 1 sott)
(foreach ent in
(vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) ent)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
)
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)
(defun ST:acet-ss-to-list (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons  e l))
)
)

 

<<

19 giờ trước, phongvivu đã nói:

Em có ý tưởng về 1 lisp như...

>>

19 giờ trước, phongvivu đã nói:

Em có ý tưởng về 1 lisp như thế này mong các cao thủ giúp với:

- Layer1 màu mặc định là 1
- Layer2 màu mặc định là 2
- Có 6 đối tượng:
- ĐT 1 thuộc Layer1 màu by layer
- ĐT 2 thuộc Layer1 màu tuỳ ý
- ĐT 3 thuộc Layer1 màu 2
- ĐT 4 thuộc Layer2 màu by layer
- ĐT 5 thuộc Layer2 màu tuỳ ý
- ĐT 6 thuộc Layer2 màu 1

* Việc muốn làm là chọn toàn bộ 6 đối tượng và dùng lệnh để cho đối tượng thuộc layer nào thì về đúng màu mặc định đã chọn của layer đấy nhưng không phải là by layer
Ví dụ: 
- ĐT 2, ĐT 3 thuộc Layer1 màu khác màu 1 thì đổi màu về 1
- ĐT 1 thuộc Layer1 màu by layer thì đổi màu về màu 1 chứ không đổi về màu by layer
- ĐT thuộc Layer2 cũng tương tự

Lưu ý: chọn tất cả các đối tượng cùng 1 lúc chứ không chọn riêng từng đối tượng thuộc từng layer

Rãnh rỗi viết tổng quát cho các layer tùy ý và màu tùy ý:

(defun C:cbc (/ ent layermau lstdt)
(or (and mau (= (type mau) 'int)) (setq mau 3))
(setq mau (cond ((getint (strcat "\nNhap mau can chuyen (0...256) <" (itoa mau) ">:"))) (mau)))
(setq ent (car (LM:SelectIf "\nChon doi tuong lay layer mau." (lambda (x) (/= " " (cdr (assoc 0 (entget (car x)))))) entsel nil)))
(setq layermau (vla-get-layer (vlax-ename->vla-object ent)))
(prompt "\nChon vung:")
(setq lstdt (acet-ss-to-list (ssget (list (cons 8 layermau)))))
(foreach dt lstdt
(vla-put-color (vlax-ename->vla-object dt) mau)
)
(princ)
);
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)

 

<<

4 giờ trước, nhimret đã nói:

cám ơn bác đã bỏ thời gian. Mục...

>>

4 giờ trước, nhimret đã nói:

cám ơn bác đã bỏ thời gian. Mục đích của lisp là để bo viền khung tên (hoặc 1 block chữ nhật), sau đó dùng các lisp xuất các rectang đó mỗi một rectang là một layout (hiện giờ các lisp free trên cadviet hay là lisp bán đều chỉ áp dụng được với khung chữ nhật

Do đó bác sửa lisp tuy quét hàng loạt được rồi nhưng lại không chọn được block :(

Nếu được bác sửa lại hộ chọn được cả block thì tốt quá. 

Cám ơn bác trước.

Sửa lại cho bạn thêm block

(defun c:ii (/ lstdt mn mx cur_lay oldos Box)
 (vl-load-com)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
 (if (not (tblsearch "layer" "Khung Viewport"))
 (COMMAND "LAYER" "M" "Khung Viewport" "C" "1" "" "L" "CONTINUOUS" "" "LW" "0.13" "" "P" "N" "" "")
 )
(setvar "clayer" "Khung Viewport")
(prompt "\nChon doi tuong:")
(setq lstdt (acet-ss-to-list (ssget '((0 . "LWPOLYLINE,insert")))))
(foreach ent lstdt
(vla-getboundingbox (vlax-ename->vla-object ent) 'mn 'mx)
(vl-cmdf "._rectang" (vlax-safearray->list mn) (vlax-safearray->list mx))
(setq Box (vlax-ename->vla-object (entlast)))
(vl-catch-all-apply 'vla-put-ConstantWidth (list Box 0.5))
)
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
 (princ)
)

 

<<

1 giờ} trướ}c, hoangtienphuchung2014 đã nói:

Bạn có...

>>

1 giờ} trướ}c, hoangtienphuchung2014 đã nói:

Bạn có thể giúp mình thêm một cột tên cọc theo mẫu này được không? Cảm ơn bạn trước

FILE_NEW.rar

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

(defun C:XBL (/ cur_lay oldos lsttk timpl pointbl lst tenbl pointvg lytrinh chieudai xlApp xlCells row col sott tieude i tentag)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
;;;;;;;;;;;;;;;;;;;;;;;
(prompt "\nChon doi tuong Block:")
(setq lsttk (ST:acet-ss-to-list (ssget '((0 . "INSERT")))))
(setq lsttk (vl-remove-if-not '(lambda(x) (/= (cdr (assoc 2 (entget x))) "STATIONX"))  lsttk))
;(setq tiento (getstring "\nNhap tien to dien tich:"))
(setq timpl (car (LM:SelectIf "\Chon tim tuyen" (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))) nentsel nil)))
(setq lst nil)
(foreach ent lsttk
(setq pointbl (cdr (assoc 10 (entget ent))))
(setq tenbl (cdr (assoc 2 (entget ent))))
(setq pointvg (vlax-curve-getClosestPointTo timpl pointbl))
(setq chieudai (distance pointbl pointvg))
(setq lytrinh (vlax-curve-getDistAtPoint timpl pointvg))
(setq tentag (LM:vl-getattributevalue (vlax-ename->vla-object ent) "TEN-DC"))
(setq lst (append (list (list (rtos lytrinh 2 2) (car pointbl) (cadr pointbl) (rtos chieudai 2 2) tenbl tentag))  lst))
)
(setq lst (vl-sort lst '(lambda (x1 x2) (< (atof (car x1)) (atof (car x2))))))
(setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 2 col 1)
(vla-put-visible xlApp :vlax-true)
(setq tieude (list "STT" "Ly trinh" "toa do X" "toa do y" "Khoang cach" "Ten Block" "Ten coc"))
(setq i -1)
(repeat (length tieude)
(vlax-put-property xlCells "Item" row (+ col (setq i (1+ i))) (nth i tieude))
)
(setq sott 0)
(foreach in lst
(setq sott (+ sott 1))
(setq i 0 row (1+ row))
(vlax-put-property xlCells "Item" row 1 sott)
(foreach ent in
(vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) ent)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
)
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)
(defun ST:acet-ss-to-list (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons  e l))
)
)
(defun LM:vl-getattributevalue ( blk tag )
    (setq tag (strcase tag))
    (vl-some '(lambda ( att ) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))
)

 

<<

13 giờ trước, NTHAHT đã nói:

Theo mình thấy thì hình như không...

>>

13 giờ trước, NTHAHT đã nói:

Theo mình thấy thì hình như không đúng ý chủ thớt.

Mình hiểu ý chủ thớt như sau (Không biết có đúng không?):

Chỉ là lấy màu của layer gán cho các đối tượng nằm trong layer đó, sau khi gán màu cho các đối tượng thì các đối tượng được gán màu không  phụ thuộc vào layer nữa.

Sửa lại theo như bạn hiểu luôn

DDC: chuyển tất cả các đối tượng về màu của lớp (không phải by layer)

DDL: chuyển tất cả các đối tượng về màu của lớp By layer

(defun C:DDC (/ ent layermau lstdt)
(setq lstlayer (ax:layer-list))
(foreach layer lstlayer
(setq lstdt (acet-ss-to-list (ssget "X" (list (cons 8 (car layer))))))
(foreach dt lstdt

(vla-put-color (vlax-ename->vla-object dt) (cadr layer))
)
)
(princ)
);
(defun C:DDL (/ ent layermau lstdt)
(setq lstlayer (ax:layer-list))
(foreach layer lstlayer
(setq lstdt (acet-ss-to-list (ssget "X" (list (cons 8 (car layer))))))
(foreach dt lstdt

(vla-put-color (vlax-ename->vla-object dt) 256)
)
)
(princ)
)
(vl-load-com)
;;; Layer list
;;;
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2006 JTB World, All Rights Reserved
;;; Website: www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;; 2000-03-15
;;;
(defun ax:layer-list (/ lst layer colors color lw)
  (setq colors '("Red" "Yellow" "Green" "Cyan" "Blue" "Magenta" "White"))
  (vlax-for layer (vla-get-Layers
                    (vla-get-ActiveDocument
                      (vlax-get-acad-object)
                    )
                  )
    (setq color (vla-get-color layer))
    (setq lst (cons
                (list
                  (vla-get-name layer)
                  color
                ) lst))
  )
  (vl-sort lst
           (function (lambda (e1 e2)
                       (< (strcase (car e1)) (strcase (car e2)))
                     )
           )
  ) 
)

 

<<

Đây là đoạn Code Scale 1 chiều, Tue_NV đã cải tiến lại với lựa chọn thêm tham số R giống như Scale 2 chiều. Các bạn sử dụng và cho...

>>

Đây là đoạn Code Scale 1 chiều, Tue_NV đã cải tiến lại với lựa chọn thêm tham số R giống như Scale 2 chiều. Các bạn sử dụng và cho biết ý kiến thêm để Tue_NV hoàn thiện nhé.

Cảm ơn các bạn

 

;XSCALE Scale the mot chieu lenhtat :XSC
(DEFUN EXCUTE()
(setq oldvalue (getvar "CMDECHO"))
(setvar "CMDECHO" 0)

(princ "Chon doi tuong can scale: ")
(setq ss (ssget))
(setq P0 (getpoint "\n Base point: "))
(initget 1 "X Y X S")
(setq C (getkword "\nScale theo ? :"))
(setq hstr (getstring "\n Cho biet he so scale or Reference < R >"))

(if (/= hstr "R") (setq hs (distof hstr 2)))
(if (or (= hstr "R") (= hstr ""))
(progn
(setq po1 (getdist p0 "\n Nhap chieu dai cua doan 1 hay Pick diem thu 2 cua canh thu 1:"))
(setq po2 (getdist p0 "\n Nhap chieu dai cua doan 2 hay Pick diem thu 2 cua canh thu 2:"))
(setq hs (/ po2 po1))
))

(DELBLOCK "VKC_TEMP")
(CREATEBLOCK ss P0)
(Command "-Insert" "VKC_TEMP" C hs P0 "")
(setq dt (entlast))
(Command "Explode" dt)

(setvar "CMDECHO" oldvalue)
(princ)
)
(DEFUN CREATEBLOCK(ss P)
(command "-Block" "VKC_TEMP" P ss "")
)

(DEFUN DELBLOCK (bname)
(if (IsExistBlock bname)
(Command "-Purge" "B" bname "Y" "Y")
)
)
(DEFUN IsExistBlock(bname / kq)
(setq kq Nil)
(setq n (length LiBlk))
(setq i 0)
(while (< i n)
(if (= bname (nth i LiBlk))
(progn
(setq i n)
(setq kq T)
)
)
(setq i (1+ i))
)
kq
)
(DEFUN CREALIBLK (/ NL)
(setq LiBlk (List))
(setq NL (tblnext "BLOCK" T))
(while NL
(setq LiBlk (append LiBlk (list (cdr (assoc 2 NL)))))
(setq NL (tblnext "BLOCK"))
)
(setq LiBlk (Acad_strlsort LiBlk))
)
(DEFUN C:XSCALE()
(CREALIBLK)
(EXCUTE)
)
(DEFUN C:XSC()
(CREALIBLK)
(EXCUTE)
)

sử dụng lênh gì để scal đây bác

<<

Download lisp

Filename: 349270_xscale_xsc.lsp

Bạn dùng thử lisp đổi tên hàng loạt Block này xem sao.

Nó sẽ thêm tiền tố vào tên block mà mình chọn hoặc tất cả block trong bản vẽ.

(defun c:DTB (/ Blocks *error* cm r ss int sn sfx kw bks nam)
  (vl-load-com)
;;; 		Tharwat 31. Oct. 2012 			;;;
;;;   Rename selected or All Blocks as User's inputs    ;;;
  (or acdoc (setq acdoc (vla-get-activedocument...
>>

Bạn dùng thử lisp đổi tên hàng loạt Block này xem sao.

Nó sẽ thêm tiền tố vào tên block mà mình chọn hoặc tất cả block trong bản vẽ.

(defun c:DTB (/ Blocks *error* cm r ss int sn sfx kw bks nam)
  (vl-load-com)
;;; 		Tharwat 31. Oct. 2012 			;;;
;;;   Rename selected or All Blocks as User's inputs    ;;;
  (or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
  (setq Blocks (vla-get-blocks acdoc))
  (setq cm (getvar 'cmdecho))
  (defun *error* (x)
    (if cm
      (setvar 'cmdecho cm)
    )
    (vla-EndUndoMark acdoc)
    (princ "\n")
    (princ "\n *Cancel*:")
  )
  (if (and (not (eq (setq sfx (getstring t "\n Specify Suffix :")) ""))
           (setq r (snvalid sfx))
           (progn (initget "Selected All")
                  (setq kw (cond ((getkword "\n Rename  Blocks < Selected > :"))
                                 ("Selected")
                           )
                  )
           )
      )
    (if (eq kw "All")
      (progn (vla-StartUndoMark acdoc)
             (vlax-for x Blocks (vl-catch-all-apply 'vla-put-name (list x (strcat sfx (vla-get-name x)))))
             (vla-EndUndoMark acdoc)
      )
      (if (setq ss (ssget "_:L" '((0 . "INSERT"))))
        (progn (vla-StartUndoMark acdoc)
               (setvar 'cmdecho 0)
               (repeat (setq int (sslength ss))
                 (setq sn (ssname ss (setq int (1- int))))
                 (setq nam (cdr (assoc 2 (entget sn))))
                 (if (not (member nam bks))
                   (progn (vl-cmdf "_.-rename" "B" nam (setq nam (strcat sfx nam))) (setq bks (cons nam bks)))
                 )
               )
               (vla-EndUndoMark acdoc)
               (setvar 'cmdecho cm)
        )
      )
    )
    (cond ((not sfx) (princ "\n Cancelled by user "))
          ((not r) (princ "\n Not Valid Block name "))
          (t (princ "\n Cancelled by user "))
    )
  )
  (princ "\n Written by Tharwat Al Shoufi")
  (princ)
)

RENB_dtb.LSP

Chào ace,

Em có 1 vấn đề nhờ ace giúp với. Trên file cad e có nhiều các hình polyline khép kín. Nhờ ace giúp sắp xếp lại tập hợp Entity names theo thứ tự tổng chiều dài giảm dần.

Dưới đây là đoạn trích code.E muốn list ssl sau khi sort có thứ tự giảm dần chiều dài. Cảm ơn ace nhiều.
 

>>

Lâu ko viết lách nên mình viết ví dụ ntn, bạn tự hoàn chỉnh nhé:

(defun C:zz ()
  (setq obj (vlax-ename->vla-object (car (entsel))))
  (vlax-for each_obj (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (vla-get-Effectivename obj))
    (if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (setq len (vla-get-Length each_obj))))))
      (setq len...
>>

Lâu ko viết lách nên mình viết ví dụ ntn, bạn tự hoàn chỉnh nhé:

(defun C:zz ()
  (setq obj (vlax-ename->vla-object (car (entsel))))
  (vlax-for each_obj (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (vla-get-Effectivename obj))
    (if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (setq len (vla-get-Length each_obj))))))
      (setq len 0.00)
      )
    (print len)
    )
  (print)
  )

Nhân tiện cho mình hỏi vài câu:

1. Đoạn trong vlax-for có thể viết ngắn gọn và khoa học hơn chút ko ? lâu ko đụng cái này h quên hết r :((

2. Ai có thể viết lisp trên dựa theo hàm (entnext) để mình tham khảo chút đc ko ?

Mình xin cảm ơn !

PS: hề hề, cái trên bị sai vì block có visibility, bạn nào sửa dùm mình nhé, học hỏi chút !

Chào các bác,

Mình hiện đang sử dụng một lisp trên diễn đàn, do công việc nên nhờ các bác sửa lại giúp như sau:

Gõ lệnh sau đó: 

+ Chọn điểm bắt đầu

+ Nhập độ lớn mũi tên: 

+ Nhập độ dày đoạn thẳng:

+ Nhập độ vòng tròn:

Sau đó sẽ thực hiện các bước tiếp theo của lisp. Chân thành cảm ơn.

>>

 

Tặng bạn, mình mới viết hôm trước, lệnh CPT nhé:

(defun c:cpt ( / doithuoctinh...
>>

 

Tặng bạn, mình mới viết hôm trước, lệnh CPT nhé:

(defun c:cpt ( / doithuoctinh cptext1 a b)

(defun doithuoctinh( ename dxfcode listvalue )
(entmod (subst (cons dxfcode listvalue) (assoc dxfcode (entget ename)) (entget ename)))
)
(defun cptext1 ( e_nguon e_dich / text_nguon)
    (setq    text_nguon (cdr(assoc 1 (entget e_nguon)))
    )
    (doithuoctinh e_dich 1 text_nguon)
)
    (prompt "Chon Text Nguon:")
    (while    (not
                (setq    a (ssget "_+.:E:S" '((0 . "TEXT,MTEXT"))) )
                )
        )
    (while
        (progn
            (setvar    'errno 0)
            (setq    b  (entsel "\nChon Text Dich:") )
        
            (cond
                ( (= (getvar 'errno) 7) (princ "\nBan Pick Truot, Hay Pick Lai ") )
                ( (and     b
                         (/= (cdr(assoc 0 (entget (car b)))) "TEXT")
                         (/= (cdr(assoc 0 (entget (car b)))) "MTEXT")
                        
                    )
                         (princ "\nBan Pick Nham, Hay Pick Lai ")
                )
                ( (and b
                       (OR
                        (= (cdr(assoc 0 (entget (car b)))) "TEXT")
                        (= (cdr(assoc 0 (entget (car b)))) "MTEXT")
                        )
                        (cptext1 (SSNAME a 0) (car b))
                    )
                )
                ( (not b) nil)
            )
        )
    )
)

thanks

<<

Download lisp

Filename: 342828_cpt.lsp

Lisp của bạn đây, lệnh là OT5

;;;  Lisp move các *text tai duong bao ra xa khoi duong bao
;;;  Hoac move text elevation duong bao ra xa khoi duong bao (lwpolyline) 
;;; by: Trân Thiêp, 07/2020, tel: 0918841230
;;;================================================================
(defun Get-2Area (lst)
    (apply '+ (mapcar '(lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
              ...
>>

Lisp của bạn đây, lệnh là OT5

;;;  Lisp move các *text tai duong bao ra xa khoi duong bao
;;;  Hoac move text elevation duong bao ra xa khoi duong bao (lwpolyline) 
;;; by: Trân Thiêp, 07/2020, tel: 0918841230
;;;================================================================
(defun Get-2Area (lst)
    (apply '+ (mapcar '(lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
                      lst (cons (last lst) lst)
              )
    )
)
(defun aText (pt height str lay)
    (setq objText (vla-AddText *Model* str (vlax-3d-point pt) height))
    (vla-put-Alignment objText acAlignmentMiddleCenter)
    (vla-put-TextAlignmentPoint objText (vlax-3d-point pt))
    (vla-put-layer objText lay)
)
(defun get_point_above_curve (EntCu pt / param ang)
  (if (setq param (vlax-curve-getParamAtPoint EntCu pt))
      (setq ang (angle '(0 0 0) (vlax-curve-getFirstDeriv EntCu param)))
  )
)
;;;================================================================
(defun c:OT5 (/ ApCad ActDoc *Model* newFontFile tsobj ent_org ent_of1 ent_of2 obj_org lstpo_org lstpo_of1 bit lstpo_of2 dis off eng ele hei lay tz po1
                po2 po pone poin an ssT ang prm)
    (command "undo" "be")
    (defun *error* (msg)
        (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
            (princ (strcat "\n** Error: " msg " **"))
        )
        (acet-sysvar-restore)
        (command "undo" "en")
        (princ)
    )
    (acet-sysvar-set '("cmdecho" 0 "osmode" 0))
    (or ucshold_thiep (setq ucshold_thiep (acet-ucs-get nil)))
    (acet-ucs-cmd '("w"))
    (setq ActDoc  (vla-get-ActiveDocument (vlax-get-acad-object))
          *Model* (vla-get-ModelSpace ActDoc)
          *TextStyles* (vla-get-TextStyles actDoc)
    )
    (setq newFontFile (acet-file-find-font "arial.TTF"))
    (if (not (tblobjname "STYLE" "Arial"))
        (progn (setq tsobj (vla-add *TextStyles* "Arial"))
               (vla-put-FontFile tsobj newFontFile)
        )
    )
    (while (OR (NOT (setq ent_org (car (entsel "\nPick a Curve \U+0111\U+01B0\U+1EDDng bao"))))
               (NOT (wcmatch (DXF 0 ent_org) "LWPOLYLINE"))
           )
        (prompt "\nPick ch\U+01B0a \U+0111úng Curve vui lòng pick l\U+1EA1i")
    )
    (setq obj_org (vlax-ename->vla-object ent_org))
    (setq lstpo_org (ACET-GEOM-VERTEX-LIST ent_org))
    (setq eng (entget ent_org))
    (setq ele (acet-dxf 38 eng)
          lay (acet-dxf 8 eng)
           
    )
    (setq tz (/ (getvar "viewsize") 50))
    (if (eq (getvar "users1") "")
        (setvar "users1" "Text")
    )
    (initget "Text Elevation")
    (setq tmp (acet-str-format
                  "\nMove t\U+1EA5t c\U+1EA3 text có s\U+1EB5n trên \U+0111\U+01B0\U+1EDBng bao hay t\U+1EA1o các text \U+0111\U+1ED9 cao và move ra các \U+0111\U+1EC9nh \U+0111\U+01B0\U+1EDDng bao:  <%1> "
                  (getvar "users1")
              )
          bit (getkword tmp)
    )
    (or bit (setq bit (getvar "users1")))
    (setvar "users1" bit)
;;;    ========
    (Cond ((eq bit "Elevation")
           (setq prm "\nrKho\U+1EA3ng cách t\U+1EEB \U+0111i\U+1EC3m chèn text \U+0111\U+1EBFn \U+0111\U+01B0\U+1EDDng bao: <%1> "))
          ((eq bit "Text")
           (setq prm "\nrKho\U+1EA3ng cách move các text ra xa \U+0111\U+01B0\U+1EDDng bao: <%1> ")))
    (if (eq (getvar "userr1") 0)
        (setvar "userr1" 20)
    )
    (if (null (setq dis (getreal (acet-str-format prm (rtos (getvar "userr1") 2 2)))))
        (setq dis (getvar "userr1"))
    )
    (setvar "userr1" dis)
    (if (< (Get-2Area lstpo_org) 0)
        (setq off (- dis)
              an   (/ pi 2)
        )
        (setq off dis
              an (- (/ pi 2))  
        )
    )
    (cond ((eq bit "Elevation") (if (eq (getvar "userr2") 0)
                                    (setvar "userr2" tz)
                                )
                                (if (null (setq hei (getreal (acet-str-format "\nChi\U+1EC1u cao ch\U+1EEF: <%1> "
                                                                              (rtos (getvar "userr2") 2 2)
                                                             )
                                                    )
                                          )
                                    )
                                    (setq hei (getvar "userr2"))
                                )
                                (setvar "userr2" hei)
                                (vla-offset obj_org off)
                                (Setq ent_of2 (entlast))
                                (setq lstpo_of2 (ACET-GEOM-VERTEX-LIST ent_of2))
                                (setq n 0)
                                (Setvar "textstyle" "arial")
                                (repeat (length lstpo_of2)
                                    (setq po1 (nth n lstpo_org)
                                          po2 (nth n lstpo_of2)
                                    )
                                    (setq po (polar po1 (angle po1 po2) dis))
                                    (aText po hei (rtos ele 2 1) lay)
                                    (setq n (1+ n))
                                )
                                (entdel ent_of2)
          )
          ((eq bit "Text")
           (setq n -1)
           (prompt "\nCh\U+1ECDn các \U+0111\U+1ED1i t\U+01B0\U+1EE3ng text t\U+1EA1o \U+0111\U+01B0\U+1EDDng bao c\U+1EA7n move ra ngoài ")
           (setq ssT (ssget '((0 . "*TEXT"))))
           (while (setq entT (ssname ssT (setq n (1+ n))))
               (setq po  (acet-dxf 10 (entget entT))
                     pone  (vlax-curve-getClosestPointTo ent_org po)
                     ang (+ an (get_point_above_curve ent_org pone))
               )
               (setq poin (polar pone ang dis))
               (vla-move (vlax-ename->vla-object entT) (vlax-3d-point po) (vlax-3d-point poin)) 
           )
          )
    )
    (acet-ucs-set ucshold_thiep)
    (acet-sysvar-restore)
    (command "undo" "en")
    (princ "\nOk")
    (princ)
)

(defun c:p1(/ e e1)
	(setq e (entlast))
	(command ".pline") (while (/= (getvar 'cmdactive) 0) (command pause))
	(and
		(setq e1...
>>

(defun c:p1(/ e e1)
	(setq e (entlast))
	(command ".pline") (while (/= (getvar 'cmdactive) 0) (command pause))
	(and
		(setq e1 (entlast))
		(not (equal e e1))
		(mapcar '(lambda(x)(entmake (list (cons 0 "CIRCLE")(cons 40 2)(cons 10 (cdr x))))) (vl-remove-if-not '(lambda(a)(= (car a) 10)) (entget e1)))
	)
) 

Quick code. Số 2 đằng sau số 40 là cái bạn cần chỉnh

 

Cám ơn bác. Bác có thể chỉnh hộ em để đường tròn ấy và đường pline chỉ là 1 đối tượng được không ạ. Nó chỉ giống như chỉ là 1 dạng linetype thôi ấy. Để khi kích chọn đường và copy đi thi các đường tròn cũng đi theo luôn.

<<

Download lisp

Filename: 416523_p1.lsp

Mình đã làm theo như bạn nói nhưng mở cad lên là tại con trỏ chuột hiện dòng Requires numeric valua.command: Xong cad báo lỗi...

>>

Mình đã làm theo như bạn nói nhưng mở cad lên là tại con trỏ chuột hiện dòng Requires numeric valua.command: Xong cad báo lỗi rồi thoát ra luôn.Dưới đây là đoạn lisp mình đã sửa theo như bạn nói:

(defun c:thutu(/ H I KC PHUONG PT SOCUOI SODAU TDX TDY)
if (not (tblsearch "Layer" "S. TEXT"))(command "-layer" "N" "S. TEXT" ""))
(setq sty (getvar "Textstyle"))
 (setq h (getreal "\n Co chu: "))
 (setq pt (getpoint "\n Chon vi tri danh so: "))
 (setq sodau (getreal "\n So thu tu dau: "))
 (setq socuoi (getreal "\n So thu tu cuoi: "))
 (setq phuong (getstring "\n Phuong <X,Y>: "))
 (setq kc (getreal "\n Khoang cach giua cac so: "))
 (setq i sodau)
 (while (<= i socuoi)
(if (= i sodau)
  (progn
(setq tdy (cadr pt))
(setq tdx (car pt))
(entmake(list(cons 0 "TEXT")(cons 7 sty)(cons 8 "S. TEXT")(cons 10 (list tdx tdy 0.0))(cons 40 h)(cons 1 (rtos i 2 0))))
)
(if (or (= phuong "x")(= phuong "X"))
 (progn
(setq tdx (+ tdx kc))
(entmake(list(cons 0 "TEXT")(cons 7 sty)(cons 8 "S. TEXT")(cons 10 (list tdx tdy 0.0))(cons 40 h)(cons 1 (rtos i 2 0))))
)
 (progn
(setq tdy (- tdy kc))
(entmake(list(cons 0 "TEXT")(cons 7 sty)(cons 8 "S. TEXT")(cons 10 (list tdx tdy 0.0))(cons 40 h)(cons 1 (rtos i 2 0))))
)
 )
  )
  (setq i (1+ i))
)
 )

Trước hàm if phải có dấu (

Bạn bị lỗi này :

(if (not (tblsearch "Layer" "S. TEXT"))(command "-layer" "N" "S. TEXT" ""))

....

<<

Vào lúc 12/7/2020 tại 08:55, quocmanh04tt đã nói:

Lisp bác

>>

Vào lúc 12/7/2020 tại 08:55, quocmanh04tt đã nói:

Lisp bác @thiep post thiếu hàm DXF.

@alibaba2209: Bạn copy hàm này vào lisp:

(defun dxf (k e) (cdr (assoc k (entget e))))

Cảm ơn @quocmanh04ttđã phát hiện thiếu hàm DXF. Sau này Thiệp thấy hàm DXF tự tạo này chạy chậm hơn so với hàm acet-dxf (có sẵn trong acetutil.arx, acetutil*.fas) và dần dần Thiệp thay thế DXF bằng acet-dxf.

@alibaba2209Lisp được rút gọn "đẩy" các text có sẵn ra khỏi đường bao. Lệnh là OT6.

ex: Nếu với BV của bạn có nhiều text và đường bao quá gần nhau, bạn nên dùng lệnh ISOLATEOBJECTS kèm cách chọn đối tượng CP, để chỉ hiện những đối tượng cần thực hiện lisp, còn các đối tượng khác sẽ ẩn.

;;;  Lisp move các *text tai duong bao ra xa khoi duong bao (lwpolyline) 
;;; by: Trân Thiêp, 07/2020, tel: 0918841230
;;;================================================================
(defun Get-2Area (lst)
    (apply '+ (mapcar '(lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
                      lst (cons (last lst) lst)
              )
    )
)
(defun get_point_above_curve (EntCu pt / param ang)
  (if (setq param (vlax-curve-getParamAtPoint EntCu pt))
      (setq ang (angle '(0 0 0) (vlax-curve-getFirstDeriv EntCu param)))
  )
)
;;;================================================================
(defun c:OT6 (/ tsobj ent_org lstpo dis hei po pone a90 ssT entT ang n)
    (command "undo" "be")
    (defun *error* (msg)
        (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
            (princ (strcat "\n** Error: " msg " **"))
        )
        (acet-sysvar-restore)
        (command "undo" "en")
        (princ)
    )
    (acet-sysvar-set '("cmdecho" 0 "osmode" 0))
    (or ucshold_thiep (setq ucshold_thiep (acet-ucs-get nil)))
    (acet-ucs-cmd '("w"))
    
    (while (OR (NOT (setq ent_org (car (entsel "\nPick a Curve \U+0111\U+01B0\U+1EDDng bao"))))
               (NOT (eq (acet-dxf 0 (entget ent_org)) "LWPOLYLINE"))
           )
        (prompt "\nPick ch\U+01B0a \U+0111úng Curve vui lòng pick l\U+1EA1i")
    )
    (setq lstpo (ACET-GEOM-VERTEX-LIST ent_org))
;;;    ========
    (if (eq (getvar "userr3") 0)
        (setvar "userr3" 20)
    )
    (if (null
            (setq dis (getreal
                          (acet-str-format "\nrKho\U+1EA3ng cách move các text ra xa \U+0111\U+01B0\U+1EDDng bao: <%1> "
                                           (rtos (getvar "userr3") 2 2)
                          )
                      )
            )
        )
        (setq dis (getvar "userr3"))
    )
    (setvar "userr3" dis)
    (if (< (Get-2Area lstpo) 0)
        (setq a90 (/ pi 2))
        (setq a90 (- (/ pi 2)))
    )
    (setq n -1)
    (prompt
        "\nCh\U+1ECDn các \U+0111\U+1ED1i t\U+01B0\U+1EE3ng text t\U+1EA1o \U+0111\U+01B0\U+1EDDng bao c\U+1EA7n move ra ngoài "
    )
    (setq ssT (ssget '((0 . "*TEXT"))))
    (while (setq entT (ssname ssT (setq n (1+ n))))
        (setq po   (acet-dxf 10 (entget entT))
              pone (vlax-curve-getClosestPointTo ent_org po)
              ang  (+ a90 (get_point_above_curve ent_org pone))
        )
        (vla-move (vlax-ename->vla-object entT)
                  (vlax-3d-point po)
                  (vlax-3d-point (polar pone ang dis))
        )
    )
    (acet-ucs-set ucshold_thiep)
    (acet-sysvar-restore)
    (command "undo" "en")
    (princ "\nOk")
    (princ)
)

 

<<

8 giờ trước, Hữu Nhân đã nói:

Chào các anh,

Em...

>>

8 giờ trước, Hữu Nhân đã nói:

Chào các anh,

Em muốn nhờ các anh viết dùm lisp vẽ hình chữ nhật bao quanh đa giác.

Bắt đầu lệnh bằng cách click vào diện tích đa giác.

Sau đó vẽ và xuất  1 kích thước theo phương thẳng đứng Y như hình vẽ thôi.

Em mới tham gia diễn đàn à, có gì sai sót mong các anh góp ý. Xin cảm ơn ạ.

Cái này bạn xem có được không nhé!!

(defun c:test ( / ent )
    (if (setq ent (car (entsel)))
        (entmake
            (append
               '(
                    (000 . "LWPOLYLINE")
                    (100 . "AcDbEntity")
                    (100 . "AcDbPolyline")
                    (090 . 4)
                    (070 . 1)
                )
                (mapcar '(lambda ( p ) (cons 10 p)) (LM:boundingbox (vlax-ename->vla-object ent)))
            )
        )
    )
    (princ)
)
(vl-load-com) (princ)
;; Bounding Box  -  Lee Mac
;; Returns the point list describing the rectangular frame bounding the supplied object.
;; obj -  VLA-Object

(defun LM:boundingbox ( obj / a b lst )
    (if
        (and
            (vlax-method-applicable-p obj 'getboundingbox)
            (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))))
            (setq lst (mapcar 'vlax-safearray->list (list a b)))
        )
        (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) lst)) a))
           '(
                (caar   cadar)
                (caadr  cadar)
                (caadr cadadr)
                (caar  cadadr)
            )
        )
    )
)

 

<<

5 giờ trước, Hữu Nhân đã nói:

Hi anh, anh có thể chỉnh lại...

>>

5 giờ trước, Hữu Nhân đã nói:

Hi anh, anh có thể chỉnh lại cách thức input là getpoint trong diện tích của đa giác kín được không anh.

Cám ơn anh rất nhiều.

Của bạn đây nhé:

(defun c:test ( / point entold et entnew)
(setq point (getpoint "\nPick diem trong vung kin"))
(while point
(setq entold (cdr (assoc 5 (entget (entlast)))))
(command "_.-boundary" point "")
   (setq et (entlast))
   (setq entnew (cdr (assoc 5 (entget (entlast)))))
    (if (/= entold entnew) 
	(progn
        (entmake
            (append
               '(
                    (000 . "LWPOLYLINE")
                    (100 . "AcDbEntity")
                    (100 . "AcDbPolyline")
                    (090 . 4)
                    (070 . 1)
                )
                (mapcar '(lambda ( p ) (cons 10 p)) (LM:boundingbox (vlax-ename->vla-object et)))
            )
        )
		(entdel et)
		(setq point (getpoint "\n Chon diem tiep theo: "))
	)
	(progn
	(princ "chon diem sai")
	(setq point (getpoint "\n Chon diem tiep theo: "))
	)
    )
)	
(princ)
)
(vl-load-com) (princ)
;; Bounding Box  -  Lee Mac
; Returns the point list describing the rectangular frame bounding the supplied object.
; obj -  VLA-Object

(defun LM:boundingbox ( obj / a b lst )
    (if
        (and
            (vlax-method-applicable-p obj 'getboundingbox)
            (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))))
            (setq lst (mapcar 'vlax-safearray->list (list a b)))
        )
        (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) lst)) a))
           '(
                (caar   cadar)
                (caadr  cadar)
                (caadr cadadr)
                (caar  cadadr)
            )
        )
    )
)

 

<<

Hi vọng bạn đã hài lòng với code này.

- Cho phép lựa chọn ghi tên điểm tọa độ tự động (giống lisp trước) hay thủ...

>>

Hi vọng bạn đã hài lòng với code này.

- Cho phép lựa chọn ghi tên điểm tọa độ tự động (giống lisp trước) hay thủ công (Pick chuột vào text có sẵn - tên cọc trên tuyến chẳng hạn)

- Cho phép ghi text tọa độ theo một góc xiên bất kỳ

- Cho phép lựa chọn có xuất bảng tọa độ hay không.

 

(prompt"\n - THONG KE TOA DO by Thaistreetz - huuthais@yahoo.com\n")
----------------------------------------------
(defun C:tdn ()
(setvar "cmdecho" 0 )
(command "Undo" "Begin")
(setq om (getvar "osmode"))
(if (not h) (setq h 1))
(setq caot1 (getreal (strcat "\nCao text < " (rtos h 2 2) " >:")))
(if caot1 (setq h caot1))
(setq tapx '() tapy '() stt '())

(setq bit1 (cond (bit1) ("Yes")))
(initget "Yes No")
(setq Tmp1 (strcat "\nTu dong ghi ten nut?  <" bit1 ">: ")
bit1 (cond ((getkword Tmp1)) (bit1)))
(if (eq bit1 "Yes")
(progn
(setq ten (getstring "\nTen Nut:"))
(if (not i) (setq i 1))
(setq i1 (getreal (strcat"\nSTT cua nut bat dau < " (rtos i 2 0) " >: ")))
(if i1 (setq i i1))

(setvar "osmode" 125)
(setq lacol (getvar "CEColor") k (- i 1))
(While
(setq D1 (getpoint (strcat"\nPick diem thu "(rtos (+ k 1) 2 0)"")))
(Progn
(setvar "osmode" 0)
(setq DX (getpoint (strcat"\nDiem dat text thu "(rtos (+ k 1) 2 0)"") D1)
DY (getpoint (strcat"\nHuong goc nghieng cua text "(rtos (+ k 1) 2 0)"") Dx)
angr (angle Dx Dy)
angd (/ (* 180 angr) pi)
x (rtos (car D1) 2 4)
y (rtos (cadr D1) 2 4)
TX (strcat "X:"(rtos (Car D1) 2 4))
TY (strcat "Y:"(rtos (Cadr D1) 2 4))
tapx (append tapx (list x))
tapy (append tapy (list y))
k (+ 1 k)
N (strcat ten (rtos k 2 0))
stt (append stt (list N))
);setq
(if (>= (car DY) (car DX))
(progn
(setq D2 (polar Dx angr (* 0.7 h)))
(command "text" "BL" D2 h angd tX)
(setq TB (textbox (entget(entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar D2 angr (+ di (* 0.4 h)))
pt4 (polar D2 (- angr (* pi 0.5)) (* 1.35 h))
pt5 (polar pt4 angr di)
C (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT4 PT5 h ty
"pline" D1 DX PT3 ""
"circle" (polar PT3 angr (* 1.5 h)) (* 1.5 h)
"text" "m" (polar PT3 angr (* 1.5 h)) h angd N
"CECOLOR" 8
"circle" (polar PT3 angr (* 1.5 h)) (* 1.35 h)
);command
(setvar "CECOLOR" lacol)
);progn
);if
(if (< (car DY) (car DX))
(progn
(setq D2 (polar Dx angr (* 0.7 h)))
(command "text" "BR" D2 h (+ angd 180) tx)
(setq TB (textbox (entget(entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar D2 angr (+ di (* 0.4 h)))
pt4 (polar D2 (+ angr (* pi 0.5)) (* 1.35 h))
pt5 (polar pt4 angr di)
C (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT5 PT4 h TY
"pline" D1 DX PT3 ""
"circle" (polar PT3 angr (* 1.5 h)) (* 1.5 h)
"text" "m" (polar PT3 angr (* 1.5 h)) h (+ angd 180) N
"CECOLOR" 8
"circle" (polar PT3 angr (* 1.5 h)) (* 1.35 h)
);command
(setvar "CECOLOR" lacol)
);progn
);if
);progn
(setvar "osmode" 125)
);while
(setq i (+ k 1))
);progn
);if
(if (eq bit1 "No")
(progn
(setvar "osmode" 125)
(setq lacol (getvar "CEColor") i 1 k (- i 1))
(While
(setq D1 (getpoint (strcat"\nPick diem thu "(rtos (+ k 1) 2 0)"")))
(Progn
(setvar "osmode" om)
(progn
(setq LOOP T)
(while (= LOOP T)
(while (null (setq ten (nentsel "\nChon mot text lam ten nut: ")))
(princ "\nChua tim thay doi tuong la text, chon lai !"));while
(setq Source_text (entget (car ten)))
(if (or (= (cdr (assoc '0 Source_text)) "TEXT")
(= (cdr (assoc '0 Source_text)) "MTEXT")
(= (cdr (assoc '0 Source_text)) "ATTRIB"));or
(progn
(setq N (cdr (assoc 1 Source_text)))
(setq LOOP nil));progn
(progn
(princ "Phai chon mot text lam ten nut !")
(setq LOOP T));progn
)if
);while
);progn
(setvar "osmode" 0)
(setq DX (getpoint (strcat"\nDiem dat text cua nut "N"") D1)
DY (getpoint (strcat"\nHuong goc nghieng cua text") Dx)
angr (angle Dx Dy))
(setq angd (/ (* 180 angr) pi)
x (rtos (car D1) 2 4)
y (rtos (cadr D1) 2 4)
TX (strcat "X:"(rtos (Car D1) 2 4))
TY (strcat "Y:"(rtos (Cadr D1) 2 4))
tapx (append tapx (list x))
tapy (append tapy (list y))
k (+ 1 k)
stt (append stt (list N))
);setq
(if (>= (car DY) (car DX))
(progn
(setq D2 (polar Dx angr (* 0.7 h)))
(command "text" "BL" D2 h angd tX)
(setq TB (textbox (entget(entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar D2 angr (+ di (* 0.4 h)))
pt4 (polar D2 (- angr (* pi 0.5)) (* 1.35 h))
pt5 (polar pt4 angr di)
C (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT4 PT5 h ty
"pline" D1 DX PT3 ""
"circle" (polar PT3 angr (* 1.5 h)) (* 1.5 h)
"text" "m" (polar PT3 angr (* 1.5 h)) h angd N
"CECOLOR" 8
"circle" (polar PT3 angr (* 1.5 h)) (* 1.35 h)
);command
(setvar "CECOLOR" lacol)
);progn
);if
(if (< (car DY) (car DX))
(progn
(setq D2 (polar Dx angr (* 0.7 h)))
(command "text" "BR" D2 h (+ angd 180) tx)
(setq TB (textbox (entget(entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC)
PT3 (polar D2 angr (+ di (* 0.4 h)))
pt4 (polar D2 (+ angr (* pi 0.5)) (* 1.35 h))
pt5 (polar pt4 angr di)
C (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT5 PT4 h TY
"pline" D1 DX PT3 ""
"circle" (polar PT3 angr (* 1.5 h)) (* 1.5 h)
"text" "m" (polar PT3 angr (* 1.5 h)) h (+ angd 180) N
"CECOLOR" 8
"circle" (polar PT3 angr (* 1.5 h)) (* 1.35 h)
);command
(setvar "CECOLOR" lacol)
);progn
);if
);progn
(setvar "osmode" 125)
);while
(setq i (+ k 1))
);progn
);if
(setq bit (cond (bit) ("Yes")))
(initget "Yes No")
(setq Tmp (strcat "\nXuât Bang Toa Ðô?  <" bit ">: ")
bit (cond ((getkword Tmp)) (bit)))
(if (eq bit "Yes")
(progn
(setq di (- di (* 0.4 h))
kc (* 2 di)
PT (getpoint"\nVi tri dat bang")
PTC (list (+ (* 2 kc) (- di h h h h) (car PT)) (cadr PT))
p1 (list (car PT) (+ (cadr PT)(* 2 h)))
p2 (list (car PTC) (+ (cadr PTC)(* 2 h)))
p3 (list (car p1) (+ (cadr p1)(* 2 h)))
p4 (list (car p2) (+ (cadr p2)(* 2 h)))
PTD (list (+ (/ di 2) (car PT)) (+ h (cadr PT)))
PTX (list (+ di (/ di 2) (- 0 h) (car PTD)) (cadr PTD))
PTY (list (+ kc (- h h h h) (car PTX)) (cadr PTX))
p11 (list (+ (/ di 2) (car p1)) (+ (* 1.1 h) (cadr p1)))
p22 (list (+ di (/ di 2) (- 0 h) (car p11)) (- (cadr p11) (* 0.1 h)))
p33 (list (+ kc (- h h h h) (car p22)) (cadr p22))
L1 (list (+ di (car p3))(cadr p3))
L2 (list (+ kc (- 0 h h)(car L1))(cadr L1))
PTB (list (+ (- (* 2 h)) (* 0.5 (+ (* 2 kc) di)) (car PT)) (+ (cadr P3) (* 1.8 h)))
n (length tapx)
k 0
);setq
(setvar "osmode" 0)
(command "CECOLOR" 3 "line" p1 p2 "" "line" p3 p4 "" "CECOLOR" 2
"text" "m" p11 h 0 "Tªn Nót"
"text" "m" p22 h 0 "Täa ®é X"
"text" "m" p33 h 0 "Täa ®é Y"
"text" "m" pTB (* 1.3 h) 0 "%¶ng thèng kª täa ®é nót")
(while (< k n)
(setq xx (nth k tapx) yy (nth k tapy) tstt(nth k stt))
(command "CECOLOR" 2
"text" "m" PTD h 0 tstt
"text" "m" PTX h 0 xx
"text" "m" PTY h 0 yy
"CECOLOR" 3
"line" PT PTC "")
(setq PT (list (car PT) (- (cadr PT)(* 2 h)))
PTC (list (+ (* 2 kc) (- di h h h h) (car PT)) (cadr PT))
PTD (list (+ (/ di 2) (car PT)) (+ h (cadr PT)))
PTX (list (+ di (/ di 2) (- 0 h) (car PTD)) (cadr PTD))
PTY (list (+ kc (- h h h h) (car PTX)) (cadr PTX))
k (+ 1 k));setq
);while
(if (= k n)
(setq PT (list (car PT) (+ (cadr PT)(* 2 h)))
PTC (list (+ (* 2 kc) (- di h h h h) (car PT)) (cadr PT))
L11 (list (+ di (car PT))(cadr PT))
L22 (list (+ kc (- 0 h h) (car L11))(cadr L11))
);setq
);if
(command "CECOLOR" 3
"line" p3 PT ""
"line" p4 PTC ""
"line" L1 L11 ""
"line" L2 L22 "")
);progn
);if
(setvar "CECOLOR" lacol)
(setvar "osmode" om)
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "Undo" "End")
(setvar "cmdecho" 1)
(princ)
);DONG toa do

 

Anh bổ sung dùm em vòng tròn hiện ra khi pick điểm với.thanks

<<

Download lisp

Filename: 387880_tdn.lsp