Lisp căn chỉnh MText và Leader
Một số tính năng căn chỉnh Mtext và Leader tự động từ tác giả PhucLe
Link tải miễn phí kèm Hướng dẫn sử dụng phía cuối bài viết!
Giới thiệu
Khi xử lý bản vẽ kỹ thuật, việc căn chỉnh Leader, Text hay MText thường tốn khá nhiều thao tác lặp lại. Để tăng tốc quá trình hoàn thiện hồ sơ và giữ bản vẽ đồng đều hơn, tác giả PhucLe đã chia sẻ miễn phí bộ AutoLISP tiện ích trên lisp.vn.
Danh sách chức năng:
• ATL – Align Text, Mtext to Leader
Tự động căn Text/MText theo hướng của Leader, giúp ghi chú gọn gàng và đồng nhất.• ALP – Adjust Angle of Multiple Leaders
Hiệu chỉnh góc cho nhiều Leader cùng lúc, giảm thao tác chỉnh tay từng đối tượng.• AVV – Adjust Leader to Horizontal
Đưa Leader về phương ngang nhanh chóng để bản vẽ cân đối và dễ đọc hơn.• AHH – Mirror Leader to Opposite Side
Lật Leader sang phía đối diện mà vẫn giữ bố cục hợp lý.• AMM – Adjust & Move Leader + Texts
Di chuyển đồng thời Leader và nội dung Text đến vị trí mới mà không cần chỉnh lại từng phần.• ALR – Align Leader, Text, Mtext to Right Side
Căn hàng loạt Leader và nội dung sang bên phải.• ALL – Align Leader, Text, Mtext to Left Side
Căn hàng loạt Leader và nội dung sang bên trái.• MTM – Set Background for Text, Mtext
Thiết lập nền che (Background Mask) cho Text/MText để tăng khả năng đọc trên bản vẽ phức tạp.• BGMO – Remove Background of Mtext
Xóa nền che của MText chỉ với một thao tác.• MTW – Change Width for Text, Mtext
Điều chỉnh chiều rộng Text/MText nhanh chóng, hỗ trợ chuẩn hóa trình bày.Bộ công cụ đặc biệt hữu ích cho kỹ sư, kiến trúc sư và người thường xuyên xử lý hồ sơ AutoCAD có nhiều ghi chú.
MÃ NGUỒN MỞ
Tác giả đã chia sẻ mã nguồn mở (Open-Source) toàn bộ lisp. Người dùng có thể tải về và lưu thành tệp tin .lsp để sử dụng:
1 Thêm class Leader & Text utilities 2.4.2-UCS.lsp
Lưu mã sau dưới dạng tệp tin Leader & Text utilities 2.4.2-UCS.lsp
Code:
;; Ver 2.4.2 - UCS
;; By PhucLe - Latest Update 2026-06-18 13:49 UTC+7
(defun c:HDSD_ATL ()
(alert
(strcat
"[1] ATL - Align Text, Mtext to Leader\n"
"[2] ALP - Adjust Angle of Multiple Leaders\n"
"[3] AVV - Adjust Leader to horizontal\n"
"[4] AHH - Mirror Leader to opposite side\n"
"[5] AMM - Adjust & move Leader + Texts to another position\n"
"[6] ALR - Align Leader, Text, Mtext to Right side\n"
"[7] ALL - Align Leader, Text, Mtext to Left side\n"
"[8] MTM - Set background for Text, Mtext\n"
"[9] BGMO - Remove background of Mtext\n"
"[10] MTW - Change width for Text, Mtext\n"
)
)
)
;; --------------------------------------- [1] Align Text, Mtext to Leader ----------------------------------------------
(vl-load-com)
(defun c:ATL ( / *my_error* doc d rdr_ent sstext dtype rslt ent0 tmp ent i n lst lst1 lst2 txt txtht inpt
ent_type obj forprinc olderr OldOsmode endpoint dir max_str_length max_text_height txt_ent
ent_data txt_ht txt_length tbox_pts ucs_ang ep_ucs inpt_ucs
)
(defun *my_error* ( msg )
(if OldOsmode (setvar 'osmode OldOsmode))
(if rdr_ent (redraw rdr_ent 4))
(if olderr (setq *error* olderr))
(if doc (vla-endundomark doc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq ucs_ang (angle '(0 0 0) (getvar 'ucsxdir)))
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq olderr *error* *error* *my_error*)
(setq OldOsmode (getvar 'osmode))
(if (not (member *ans_change_to_leader* '( "Yes" "No" )))
(progn
(setq *ans_change_to_leader* "Yes")
(initget "Yes No")
(if (setq tmp (getkword (strcat "\nConvert selected Polyline or Line to Leader? [Yes/No] <" *ans_change_to_leader* ">: ")))
(setq *ans_change_to_leader* tmp)
)
)
)
(prompt "\nCommand: First, Select a Leader (or Polyline, Line for Align Text) \n")
(while (not (setq d (ssget "_:L+.:E:S" '((0 . "LEADER,LWPOLYLINE,LINE")))))
(princ "\nCommand: No Leader, Polyline or Line selected, select again or <ESC> to cancel \n")
)
(if d (redraw (setq rdr_ent (ssname d 0)) 3))
(prompt "\nCommand: Then, Select Texts to Align or <Enter> to adjust Leader only \n")
(if (setq sstext (ssget "_:L" '((0 . "*TEXT"))))
(princ (strcat "\nCommand: " (itoa (sslength sstext)) " Text, Mtext selected \n"))
)
(if (and d sstext )
(progn
(setvar 'osmode 16384)
(setq lst (LM:ss->ent sstext))
(setq max_str_length 0.0 max_text_height 0.0)
(foreach txt_ent lst
(setq ent_data (entget txt_ent))
(setq txt_ht (cdr (assoc 40 ent_data)))
(setq tbox_pts (tbox:textbox ent_data 0.0))
(setq txt_length (distance (car tbox_pts) (cadr tbox_pts)))
(if (> txt_length max_str_length)
(setq max_str_length txt_length)
)
(if (> txt_ht max_text_height)
(setq max_text_height txt_ht)
)
)
(setq dtype (cdr (assoc 0 (entget (setq ent0 (ssname d 0))))))
(cond
( (eq "LEADER" dtype)
(setq rslt (entmodleader ent0 max_str_length max_text_height))
(setq endpoint (car rslt) dir (cadr rslt))
)
( (eq "LWPOLYLINE" dtype)
(setq rslt (entmodpolyline ent0 max_str_length max_text_height))
(setq endpoint (car rslt) dir (cadr rslt))
(if (= "Yes" *ans_change_to_leader*)
(polylinetoleader ent0)
)
)
( (eq "LINE" dtype)
(setq rslt (entmodline ent0 max_str_length max_text_height))
(setq endpoint (car rslt) dir (cadr rslt))
(if (= "Yes" *ans_change_to_leader*)
(linetoleader ent0)
)
)
)
(setq ep_ucs (trans endpoint 0 1))
(setq lst (mapcar '(lambda (e) (cons (trans (cdr (assoc 10 (entget e))) e 1) e)) lst))
(setq lst1 '())
(setq lst2 '())
(foreach txt lst
(if (>= (cadr (car txt)) (cadr ep_ucs) )
(setq lst1 (cons txt lst1))
(setq lst2 (cons txt lst2))
)
)
(if (< 0 (length lst1))
(progn
(setq lst1 (vl-sort lst1 '(lambda (p q) (< (cadr (car p)) (cadr (car q))))))
(setq txtht (vla-get-height (vlax-ename->vla-object (cdr (nth 0 lst1 )))))
(setq n (length lst1) i 0)
(while (< i n)
(setq inpt_ucs (list (car ep_ucs) (+ (cadr ep_ucs) (* txtht (+ 0.25 (* i 1.5)) )) (caddr ep_ucs)))
(setq inpt (trans inpt_ucs 1 0))
(setq ent_type (cdr (assoc 0 (entget (setq ent (cdr (nth i lst1)))))))
(setq obj (vlax-ename->vla-object ent ))
(cond
( (equal ent_type "TEXT")
(if (equal dir "R") (vla-put-alignment obj acalignmentbottomright) (vla-put-alignment obj acalignmentbottomleft))
(vla-put-textalignmentpoint obj (vlax-3d-point inpt))
(vla-put-rotation obj ucs_ang)
)
( (equal ent_type "MTEXT")
(if (equal dir "R") (vla-put-attachmentpoint obj acbottomright) (vla-put-attachmentpoint obj acbottomleft))
(vla-put-insertionpoint obj (vlax-3d-point inpt))
(vla-put-rotation obj 0.0)
)
)
(setq i (1+ i))
)
)
)
(if (< 0 (length lst2))
(progn
(setq lst2 (vl-sort lst2 '(lambda (p q) (> (cadr (car p)) (cadr (car q))))))
(setq txtht (vla-get-height (vlax-ename->vla-object (cdr (nth 0 lst2 )))))
(setq n (length lst2) i 0)
(while (< i n)
(setq inpt_ucs (list (car ep_ucs) (- (cadr ep_ucs) (* (+ 0.25 i) 1.5 txtht )) (caddr ep_ucs)))
(setq inpt (trans inpt_ucs 1 0))
(setq ent_type (cdr (assoc 0 (entget (setq ent (cdr (nth i lst2)))))))
(setq obj (vlax-ename->vla-object ent ))
(cond
( (equal ent_type "TEXT")
(if (equal dir "R") (vla-put-alignment obj acAlignmentTopRight) (vla-put-alignment obj acAlignmentTopLeft))
(vla-put-textalignmentpoint obj (vlax-3d-point inpt))
(vla-put-rotation obj ucs_ang)
)
( (equal ent_type "MTEXT")
(if (equal dir "R") (vla-put-attachmentpoint obj acTopRight) (vla-put-attachmentpoint obj acTopLeft))
(vla-put-insertionpoint obj (vlax-3d-point inpt))
(vla-put-rotation obj 0.0)
)
)
(setq i (1+ i))
)
)
)
(setvar 'osmode OldOsmode)
(princ (strcat "\nCommand: " (itoa (sslength sstext)) " Text, Mtext aligned successfully \n"))
)
(progn
(if d
(progn
(setq dtype (cdr (assoc 0 (entget (setq ent0 (ssname d 0))))))
(cond
( (eq "LEADER" dtype)
(entmodleader ent0 0.0 0.0)
(setq forprinc "Leader")
)
( (eq "LWPOLYLINE" dtype)
(entmodpolyline ent0 0.0 0.0)
(setq forprinc "Polyline")
(if (= "Yes" *ans_change_to_leader*)
(polylinetoleader ent0)
)
)
( (eq "LINE" dtype)
(entmodline ent0 0.0 0.0)
(setq forprinc "Line")
(if (= "Yes" *ans_change_to_leader*)
(linetoleader ent0)
)
)
)
(princ (strcat "\nCommand: No Text or Mtext selected, only perform for " forprinc " \n"))
)
(princ "\nCommand: No Leader selected, please select again \n")
)
)
)
(if rdr_ent (redraw rdr_ent 4))
(if olderr (setq *error* olderr))
(vla-endundomark doc)
(princ)
)
;; -------------------------------------- [2] ALP - Adjust Angle of Multiple Leaders ---------------------------------------
(defun c:ALP ( / *my_error* doc d OldOsmode entlst ent ed midpoint edrv endpoint midpt startpoint stapt newstapt newmidpt newm dir olderr ep_ucs mp_ucs sp_ucs newmp_ucs newstapt_ucs )
(defun *my_error* ( msg )
(if OldOsmode (setvar 'osmode OldOsmode))
(if olderr (setq *error* olderr))
(if doc (vla-endundomark doc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq olderr *error* *error* *my_error*)
(setq OldOsmode (getvar 'osmode))
(if (null *lst_alv_alp*) (setting_angle_alp))
(prompt (strcat "\nCommand: Current angle is " (if *alp_angle* (vl-princ-to-string *alp_angle*) "Unknown") ", Select Leaders or < Enter > to change Angle \n"))
(cond
( (setq d (ssget "_:L" '((0 . "LEADER"))))
(progn
(setvar 'osmode 16384)
(setq entlst (LM:ss->ent d))
(foreach ent entlst
(setq ed (entget ent))
(setq edrv (reverse ed))
(setq endpoint (cdr (assoc 10 edrv)))
(setq midpoint (cdr (NTHASSOC 1 10 edrv)))
(setq ep_ucs (trans endpoint 0 1))
(setq mp_ucs (trans midpoint 0 1))
(setq dir (if (minusp (- (car ep_ucs) (car mp_ucs )) ) "L" "R"))
(if (NTHASSOC 2 10 edrv)
(progn
(setq startpoint (cdr (NTHASSOC 2 10 edrv)))
(setq sp_ucs (trans startpoint 0 1))
(if (not (equal (cadr ep_ucs) (cadr sp_ucs) (if (= "Model" (getvar 'ctab)) 10.00 5.00)))
(progn
(setq midpt (NTHASSOC 1 10 edrv))
(cond
( (and (= dir "R") (< (cadr sp_ucs) (cadr ep_ucs)))
(setq newmp_ucs (list (findpoint (* 1 (nth 0 *lst_alv_alp*)) (* 1 (nth 1 *lst_alv_alp*)) sp_ucs ep_ucs ) (cadr ep_ucs) (caddr ep_ucs)))
)
( (and (= dir "R") (< (cadr ep_ucs) (cadr sp_ucs)))
(setq newmp_ucs (list (findpoint (* 1 (nth 0 *lst_alv_alp*)) (* -1 (nth 1 *lst_alv_alp*)) sp_ucs ep_ucs ) (cadr ep_ucs) (caddr ep_ucs)))
)
( (and (= dir "L") (< (cadr sp_ucs) (cadr ep_ucs)))
(setq newmp_ucs (list (findpoint (* -1 (nth 0 *lst_alv_alp*)) (* 1 (nth 1 *lst_alv_alp*)) sp_ucs ep_ucs ) (cadr ep_ucs) (caddr ep_ucs)))
)
( (and (= dir "L") (< (cadr ep_ucs) (cadr sp_ucs)))
(setq newmp_ucs (list (findpoint (* -1 (nth 0 *lst_alv_alp*)) (* -1 (nth 1 *lst_alv_alp*)) sp_ucs ep_ucs ) (cadr ep_ucs) (caddr ep_ucs)))
)
)
(setq newmidpt (trans newmp_ucs 1 0))
(setq newm (cons 10 newmidpt))
(setq edrv (subst newm midpt edrv))
(setq ed (reverse edrv))
(entmod ed)
)
)
)
(progn
(setq startpoint (cdr (setq stapt (NTHASSOC 1 10 edrv))))
(setq sp_ucs (trans startpoint 0 1))
(setq newstapt_ucs (list (car sp_ucs) (cadr ep_ucs) (caddr sp_ucs)))
(setq newstapt (trans newstapt_ucs 1 0))
(setq newm (cons 10 newstapt))
(setq edrv (subst newm stapt edrv))
(setq ed (reverse edrv))
(entmod ed)
)
)
)
(setvar 'osmode OldOsmode)
(princ (strcat "\nCommand: Finished Adjustment for " (itoa (sslength d)) " Leader" (if (< 1 (sslength d)) "s" "") " \n"))
)
)
( (setting_angle_alp)
(princ "\nCommand: Press Space to call command again ! \n")
)
)
(if olderr (setq *error* olderr))
(vla-endundomark doc)
(princ)
)
;; ---------------------------------------- [3] Adjust Leader to horizontal --------------------------------------------
(defun c:AVV ( / *my_error* doc ssld OldOsmode ed entld ent stapt startpoint midpt midpoint newstapt olderr sp_ucs mp_ucs newstapt_ucs )
(defun *my_error* ( msg )
(if OldOsmode (setvar 'osmode OldOsmode))
(if olderr (setq *error* olderr))
(if doc (vla-endundomark doc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq olderr *error* *error* *my_error*)
(setq OldOsmode (getvar 'osmode))
(princ "\nCommand: Select Leaders to Adjust \n")
(if (setq ssld (ssget "_:L" '((0 . "LEADER"))))
(progn
(setvar 'osmode 16384)
(setq entld (LM:ss->ent ssld))
(foreach ent entld
(setq ed (entget ent))
(setq startpoint (cdr (setq stapt (NTHASSOC 0 10 ed))))
(setq midpoint (cdr (setq midpt (NTHASSOC 1 10 ed))))
(setq sp_ucs (trans startpoint 0 1))
(setq mp_ucs (trans midpoint 0 1))
(if (not (equal (car sp_ucs) (car mp_ucs) (if (= "Model" (getvar 'ctab)) 10.00 5.00)))
(progn
(setq newstapt_ucs (list (car sp_ucs) (cadr mp_ucs) (caddr mp_ucs) ))
(setq newstapt (cons 10 (trans newstapt_ucs 1 0)))
(setq ed (subst newstapt stapt ed))
(entmod ed)
)
)
)
(setvar 'osmode OldOsmode)
(princ "\nCommand: Finished Adjustment for Leaders \n")
)
(princ "\nCommand: No Leader selected ! \n")
)
(if olderr (setq *error* olderr))
(vla-endundomark doc)
(princ)
)
;; ---------------------------------------- [4] Mirror Leader to opposite side ----------------------------------------
(defun c:AHH ( / *my_error* doc ssld OldOsmode Oldcmdecho ed edrv entld ent endpoint olderr ep_ucs )
(defun *my_error* ( msg )
(if OldOsmode (setvar 'osmode OldOsmode))
(if Oldcmdecho (setvar 'cmdecho Oldcmdecho))
(if olderr (setq *error* olderr))
(if doc (vla-endundomark doc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq olderr *error* *error* *my_error*)
(setq OldOsmode (getvar 'osmode))
(setq Oldcmdecho (getvar 'cmdecho))
(princ "\nCommand: Select Leaders to Adjust \n")
(if (setq ssld (ssget "_:L" '((0 . "LEADER"))))
(progn
(setvar 'osmode 16384)
(setvar 'cmdecho 0)
(setq entld (LM:ss->ent ssld))
(foreach ent entld
(setq ed (entget ent))
(setq edrv (reverse ed))
(setq endpoint (cdr (assoc 10 edrv)))
(setq ep_ucs (trans endpoint 0 1))
(command "._mirror" ent "" ep_ucs (polar ep_ucs (/ pi 2) 100) "yes")
)
(setvar 'osmode OldOsmode)
(setvar 'cmdecho Oldcmdecho)
(princ "\nCommand: Finished Mirror for Leaders \n")
)
(princ "\nCommand: No Leader selected ! \n")
)
(if olderr (setq *error* olderr))
(vla-endundomark doc)
(princ)
)
;; ---------------------------------------- [5] Adjust & move Leader + Texts to another position ----------------------------------------
(defun c:AMM ( / *my_error* doc olderr curr_osmode leader_ent sstext pt ed edrv endpoint midpoint dir midpt startpoint
newmidpt newm newstapt lst lst1 lst2 txtht txt n i inpt ent_type ent obj dis1 dis2 newstartpoint stapt
max_str_length max_text_height txt_ent ent_data txt_ht txt_length tbox_pts ucs_ang ep_ucs mp_ucs sp_ucs newmp_ucs newstartpoint_ucs movepoint_ucs inpt_ucs
)
(defun *my_error* ( msg )
(if curr_osmode (setvar 'osmode curr_osmode))
(if leader_ent (redraw leader_ent 4))
(if olderr (setq *error* olderr))
(if doc (vla-endundomark doc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq ucs_ang (angle '(0 0 0) (getvar 'ucsxdir)))
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq olderr *error* curr_osmode (getvar 'osmode))
(setq *error* *my_error*)
(if (null *lst_alv_amm*) (setting_angle_amm))
(prompt (strcat "\nCommand: Current angle is " (if *amm_angle* (vl-princ-to-string *amm_angle*) "Unknown") ", Select a Leader or < Enter > to change Angle \n"))
(cond
( (setq leader_ent
(car
(AT:GetSel entsel "\nSelect a Leader:"
(lambda (x)
(and (eq (cdr (assoc 0 (entget (car x)))) "LEADER")
(not (check_locked_layer (cdr (assoc 8 (entget (car x))))))
)
)
)
)
)
(redraw leader_ent 3)
(prompt "\nCommand: Select Texts that are associated with the selected leader \n")
(setq sstext (ssget "_:L" '((0 . "*TEXT"))))
(prompt "\nCommand: Select new point \n")
(setq pt (getpoint "\nSelect new point \n"))
(redraw leader_ent 4)
(if (and leader_ent sstext pt)
(progn
(setvar 'osmode 16384)
(setq lst (LM:ss->ent sstext))
(setq max_str_length 0.0 max_text_height 0.0)
(foreach txt_ent lst
(setq ent_data (entget txt_ent))
(setq txt_ht (cdr (assoc 40 ent_data)))
(setq tbox_pts (tbox:textbox ent_data 0.0))
(setq txt_length (distance (car tbox_pts) (cadr tbox_pts)))
(if (> txt_length max_str_length)
(setq max_str_length txt_length)
)
(if (> txt_ht max_text_height)
(setq max_text_height txt_ht)
)
)
(setq ed (entget leader_ent))
(setq edrv (reverse ed))
(setq endpoint (cdr (assoc 10 edrv)))
(setq midpoint (cdr (setq midpt (NTHASSOC 1 10 edrv))))
(setq ep_ucs (trans endpoint 0 1))
(setq mp_ucs (trans midpoint 0 1))
(setq dir (if (minusp (- (car ep_ucs) (car mp_ucs )) ) "L" "R"))
(if (NTHASSOC 2 10 edrv)
(progn
(setq startpoint (cdr (NTHASSOC 2 10 edrv)))
(setq sp_ucs (trans startpoint 0 1))
(if (and (< 0 (setq dis1 (distance sp_ucs mp_ucs )))
(< 0 (setq dis2 (distance mp_ucs ep_ucs)))
(< 0 max_str_length)
)
(progn
(setq dis2 (width_clamp max_str_length (* 2 max_text_height) (+ max_str_length (* 2 max_text_height))))
(cond
( (and (= dir "R") (<= (cadr sp_ucs) (cadr ep_ucs)))
(setq newmp_ucs (polar ep_ucs pi dis2))
(setq newstartpoint_ucs (polar newmp_ucs (nth 0 *lst_alv_amm*) dis1))
(setq movepoint_ucs newstartpoint_ucs)
)
( (and (= dir "R") (< (cadr ep_ucs) (cadr sp_ucs)))
(setq newmp_ucs (polar ep_ucs pi dis2))
(setq newstartpoint_ucs (polar newmp_ucs (nth 1 *lst_alv_amm*) dis1))
(setq movepoint_ucs newstartpoint_ucs)
)
( (and (= dir "L") (<= (cadr sp_ucs) (cadr ep_ucs)))
(setq newmp_ucs (polar ep_ucs 0 dis2))
(setq newstartpoint_ucs (polar newmp_ucs (nth 2 *lst_alv_amm*) dis1))
(setq movepoint_ucs newstartpoint_ucs)
)
( (and (= dir "L") (< (cadr ep_ucs) (cadr sp_ucs)))
(setq newmp_ucs (polar ep_ucs 0 dis2))
(setq newstartpoint_ucs (polar newmp_ucs (nth 3 *lst_alv_amm*) dis1))
(setq movepoint_ucs newstartpoint_ucs)
)
)
(setq stapt (NTHASSOC 2 10 edrv))
(setq newmidpt (trans newmp_ucs 1 0))
(setq newstartpoint (trans newstartpoint_ucs 1 0))
(setq newm (cons 10 newmidpt))
(setq newstapt (cons 10 newstartpoint))
(setq edrv (subst newm midpt edrv))
(setq edrv (subst newstapt stapt edrv))
(setq ed (reverse edrv))
(entmod ed)
)
(setq movepoint_ucs (trans (cdr (NTHASSOC 2 10 edrv)) 0 1))
)
)
(progn
(if (and (< 0 max_str_length) (< 0 max_text_height))
(progn
(setq dis2 (width_clamp max_str_length (* 3 max_text_height) (+ max_str_length (* 3 max_text_height))))
(setq newmp_ucs (polar ep_ucs (if (= dir "L") 0 pi ) dis2))
)
(setq newmp_ucs mp_ucs)
)
(setq newmidpt (trans newmp_ucs 1 0))
(setq newm (cons 10 newmidpt))
(setq edrv (subst newm midpt edrv))
(setq ed (reverse edrv))
(entmod ed)
(setq movepoint_ucs newmp_ucs)
)
)
(setq lst (mapcar '(lambda (e) (cons (trans (cdr (assoc 10 (entget e))) e 1) e)) lst))
(setq lst1 '())
(setq lst2 '())
(foreach txt lst
(if (>= (cadr (car txt)) (cadr ep_ucs) )
(setq lst1 (cons txt lst1))
(setq lst2 (cons txt lst2))
)
)
(if (< 0 (length lst1))
(progn
(setq lst1 (vl-sort lst1 '(lambda (p q) (< (cadr (car p)) (cadr (car q))))))
(setq txtht (vla-get-height (vlax-ename->vla-object (cdr (nth 0 lst1 )))))
(setq n (length lst1) i 0)
(while (< i n)
(setq inpt_ucs (list (car ep_ucs) (+ (cadr ep_ucs) (* txtht (+ 0.25 (* i 1.5)) )) (caddr ep_ucs)))
(setq inpt (trans inpt_ucs 1 0))
(setq ent_type (cdr (assoc 0 (entget (setq ent (cdr (nth i lst1)))))))
(setq obj (vlax-ename->vla-object ent ))
(cond
( (equal ent_type "TEXT")
(if (equal dir "R") (vla-put-alignment obj acalignmentbottomright) (vla-put-alignment obj acalignmentbottomleft))
(vla-put-textalignmentpoint obj (vlax-3d-point inpt))
(vla-put-rotation obj ucs_ang)
)
( (equal ent_type "MTEXT")
(if (equal dir "R") (vla-put-attachmentpoint obj acbottomright) (vla-put-attachmentpoint obj acbottomleft))
(vla-put-insertionpoint obj (vlax-3d-point inpt))
(vla-put-rotation obj 0.0)
)
)
(setq i (1+ i))
)
)
)
(if (< 0 (length lst2))
(progn
(setq lst2 (vl-sort lst2 '(lambda (p q) (> (cadr (car p)) (cadr (car q))))))
(setq txtht (vla-get-height (vlax-ename->vla-object (cdr (nth 0 lst2 )))))
(setq n (length lst2) i 0)
(while (< i n)
(setq inpt_ucs (list (car ep_ucs) (- (cadr ep_ucs) (* (+ 0.25 i) 1.5 txtht )) (caddr ep_ucs)))
(setq inpt (trans inpt_ucs 1 0))
(setq ent_type (cdr (assoc 0 (entget (setq ent (cdr (nth i lst2)))))))
(setq obj (vlax-ename->vla-object ent ))
(cond
( (equal ent_type "TEXT")
(if (equal dir "R") (vla-put-alignment obj acAlignmentTopRight) (vla-put-alignment obj acAlignmentTopLeft))
(vla-put-textalignmentpoint obj (vlax-3d-point inpt))
(vla-put-rotation obj ucs_ang)
)
( (equal ent_type "MTEXT")
(if (equal dir "R") (vla-put-attachmentpoint obj acTopRight) (vla-put-attachmentpoint obj acTopLeft))
(vla-put-insertionpoint obj (vlax-3d-point inpt))
(vla-put-rotation obj 0.0)
)
)
(setq i (1+ i))
)
)
)
(setq sstext (ssadd leader_ent sstext))
(command "._move" sstext "" movepoint_ucs pt )
(setvar 'osmode curr_osmode)
(princ "\nCommand: All done ! \n")
)
(princ "\nCommand: No Leader, Text or Point selected, command cancelled ! \n")
)
)
( (setting_angle_amm)
(princ "\nCommand: Press Space to call command again ! \n")
)
)
(setq *error* olderr)
(vla-endundomark doc)
(princ)
)
;; ------------------------------- [6] Align Leader, Text, Mtext to Right side -------------------------------------------
;; Based on the lisp:
;; LISP CANH TEXT VA LEADER
;; LENH TAT ALR-CANH PHAI, ALL-CANH TRAI
;; THANH TRI AUTOCAD REVIT
(defun c:ALR ( / *my_error* doc Oldcmdecho OldOsmode ss p1 ssl1 n o0 o1 ob1 dt
lst1 lst lst2 lts3 endpoint alignmentpoint attachmentpoint
olderr Ltext ucs_ang p1_ucs ep_ucs newep_ucs newep_wcs pt1_wcs pt1_ucs pt2_ucs pt3_ucs pt2_wcs
)
(defun *my_error* ( msg )
(if OldOsmode (setvar 'osmode OldOsmode))
(if Oldcmdecho (setvar 'cmdecho Oldcmdecho))
(if olderr (setq *error* olderr))
(if doc (vla-endundomark doc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq ucs_ang (angle '(0 0 0) (getvar 'ucsxdir)))
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq olderr *error* *error* *my_error*)
(setq Oldcmdecho (getvar 'cmdecho))
(setq OldOsmode (getvar 'osmode))
(prompt "\nCommand: Select Leaders and Texts for Align to Right Side \n")
(if (and
(setq ss (ssget "_:L" (list (cons 0 "LEADER,*TEXT"))))
(setq p1 (getpoint "\nPick Right Side Endpoint for Leader: "))
)
(progn
(setvar 'cmdecho 0)
(setvar 'osmode 16384)
(setq p1_ucs p1)
(setq ssl1 (sslength ss))
(setq n 0)
(while (< n ssl1)
(setq o0 (ssname ss n))
(setq o1 (entget o0))
(setq dt (cdr(assoc 0 o1)))
(cond
( (= dt "LEADER")
(setq lst1 (reverse o1))
(setq lst (assoc 10 lst1))
(setq endpoint (cdr lst))
(setq ep_ucs (trans endpoint 0 1))
(setq newep_ucs (list (car p1_ucs) (cadr ep_ucs) (caddr ep_ucs)))
(setq newep_wcs (trans newep_ucs 1 0))
(setq lst2 (subst (cons 10 newep_wcs) lst lst1))
(setq lts3 (reverse lst2))
(entmod lts3)
)
( (= dt "TEXT")
(setq pt1_wcs (cdr (assoc 10 o1)))
(setq pt1_ucs (trans pt1_wcs o0 1))
(setq pt2_ucs (list (car p1_ucs) (cadr pt1_ucs) (caddr pt1_ucs)))
(setq Ltext (car (car (cdr (textbox o1))))) ; fix bug count text length
(setq pt3_ucs (polar pt2_ucs pi Ltext))
(setq ob1 (vlax-ename->vla-object o0))
(setq alignmentpoint (vla-get-alignment ob1))
(cond
( (or (= alignmentpoint 0) (= alignmentpoint 1))
(command "._JUSTIFYTEXT" o0 "" "R")
)
( (or (= alignmentpoint 4) (= alignmentpoint 5))
(command "._JUSTIFYTEXT" o0 "" "R")
)
( (or (= alignmentpoint 6) (= alignmentpoint 7))
(command "._JUSTIFYTEXT" o0 "" "TR")
)
( (or (= alignmentpoint 9) (= alignmentpoint 10))
(command "._JUSTIFYTEXT" o0 "" "MR")
)
( (or (= alignmentpoint 12) (= alignmentpoint 13))
(command "._JUSTIFYTEXT" o0 "" "BR")
)
)
(command "._move" o0 "" pt1_ucs pt3_ucs)
(vla-put-rotation ob1 ucs_ang)
)
( (= dt "MTEXT")
(setq ob1 (vlax-ename->vla-object o0))
(setq attachmentpoint (vla-get-attachmentpoint ob1))
(cond
( (or (= attachmentpoint 1) (= attachmentpoint 2))
(vla-put-attachmentpoint ob1 actopright)
)
( (or (= attachmentpoint 4) (= attachmentpoint 5))
(vla-put-attachmentpoint ob1 acmiddleright)
)
( (or (= attachmentpoint 7) (= attachmentpoint 8))
(vla-put-attachmentpoint ob1 acbottomright)
)
)
(setq pt1_wcs (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint ob1))))
(setq pt1_ucs (trans pt1_wcs 0 1))
(setq pt2_ucs (list (car p1_ucs) (cadr pt1_ucs) (caddr pt1_ucs)))
(setq pt2_wcs (trans pt2_ucs 1 0))
(vla-put-insertionpoint ob1 (vlax-3d-point pt2_wcs))
(vla-put-rotation ob1 0.0)
)
)
(setq n (+ n 1))
)
(setvar 'cmdecho Oldcmdecho)
(setvar 'osmode OldOsmode)
(princ (strcat "\nCommand: Finished Align " (itoa ssl1) " Object" (if (< 1 ssl1) "s" "") " to Right Side \n"))
)
)
(if olderr (setq *error* olderr))
(vla-endundomark doc)
(princ)
)
;; ------------------------------------ [7] Align Leader, Text, Mtext to Left side ---------------------------------------
;; Based on the lisp:
;; LISP CANH TEXT VA LEADER
;; LENH TAT ALR-CANH PHAI, ALL-CANH TRAI
;; THANH TRI AUTOCAD REVIT
(defun c:ALL ( / *my_error* doc Oldcmdecho OldOsmode ss p1 ssl1 n o0 o1 ob1 dt lst1 lst endpoint
lst2 lts3 alignmentpoint attachmentpoint olderr ucs_ang p1_ucs ep_ucs newep_ucs newep_wcs pt1_wcs pt1_ucs pt2_ucs pt2_wcs
)
(defun *my_error* ( msg )
(if OldOsmode (setvar 'osmode OldOsmode))
(if Oldcmdecho (setvar 'cmdecho Oldcmdecho))
(if olderr (setq *error* olderr))
(if doc (vla-endundomark doc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq ucs_ang (angle '(0 0 0) (getvar 'ucsxdir)))
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq olderr *error* *error* *my_error*)
(setq Oldcmdecho (getvar 'cmdecho))
(setq OldOsmode (getvar 'osmode))
(prompt "\nCommand: Select Leaders and Texts for Align to Left Side \n")
(if (and
(setq ss (ssget "_:L" (list (cons 0 "LEADER,*TEXT"))))
(setq p1 (getpoint "\nPick Left Side Endpoint for Leader: "))
)
(progn
(setvar 'cmdecho 0)
(setvar 'osmode 16384)
(setq p1_ucs p1)
(setq ssl1 (sslength ss))
(setq n 0)
(while (< n ssl1)
(setq o0 (ssname ss n))
(setq o1 (entget o0))
(setq dt (cdr (assoc 0 o1)))
(cond
( (= dt "LEADER")
(setq lst1 (reverse o1))
(setq lst (assoc 10 lst1))
(setq endpoint (cdr lst))
(setq ep_ucs (trans endpoint 0 1))
(setq newep_ucs (list (car p1_ucs) (cadr ep_ucs) (caddr ep_ucs)))
(setq newep_wcs (trans newep_ucs 1 0))
(setq lst2 (subst (cons 10 newep_wcs) lst lst1))
(setq lts3 (reverse lst2))
(entmod lts3)
)
( (= dt "TEXT")
(setq pt1_wcs (cdr (assoc 10 o1)))
(setq pt1_ucs (trans pt1_wcs o0 1))
(setq pt2_ucs (list (car p1_ucs) (cadr pt1_ucs) (caddr pt1_ucs)))
(setq ob1 (vlax-ename->vla-object o0))
(setq alignmentpoint (vla-get-alignment ob1))
(cond
( (or (= alignmentpoint 1) (= alignmentpoint 2))
(command "._JUSTIFYTEXT" o0 "" "L")
)
( (or (= alignmentpoint 4) (= alignmentpoint 5))
(command "._JUSTIFYTEXT" o0 "" "L")
)
( (or (= alignmentpoint 7) (= alignmentpoint 8))
(command "._JUSTIFYTEXT" o0 "" "TL")
)
( (or (= alignmentpoint 10) (= alignmentpoint 11))
(command "._JUSTIFYTEXT" o0 "" "ML")
)
( (or (= alignmentpoint 13) (= alignmentpoint 14))
(command "._JUSTIFYTEXT" o0 "" "BL")
)
)
(command "._move" o0 "" pt1_ucs pt2_ucs)
(vla-put-rotation ob1 ucs_ang)
)
( (= dt "MTEXT")
(setq ob1 (vlax-ename->vla-object o0))
(setq attachmentpoint (vla-get-attachmentpoint ob1))
(cond
( (or (= attachmentpoint 3) (= attachmentpoint 2))
(vla-put-attachmentpoint ob1 actopleft)
)
( (or (= attachmentpoint 6) (= attachmentpoint 5))
(vla-put-attachmentpoint ob1 acmiddleleft)
)
( (or (= attachmentpoint 9) (= attachmentpoint 8))
(vla-put-attachmentpoint ob1 acbottomleft)
)
)
(setq pt1_wcs (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint ob1))))
(setq pt1_ucs (trans pt1_wcs 0 1))
(setq pt2_ucs (list (car p1_ucs) (cadr pt1_ucs) (caddr pt1_ucs)))
(setq pt2_wcs (trans pt2_ucs 1 0))
(vla-put-insertionpoint ob1 (vlax-3d-point pt2_wcs))
(vla-put-rotation ob1 0.0)
)
)
(setq n (+ n 1))
)
(setvar 'cmdecho Oldcmdecho)
(setvar 'osmode OldOsmode)
(princ (strcat "\nCommand: Finished Align " (itoa ssl1) " Object" (if (< 1 ssl1) "s" "") " to Left Side \n"))
)
)
(if olderr (setq *error* olderr))
(vla-endundomark doc)
(princ)
)
;; ------------------------------------ [8] MTM - Set background for Text, Mtext ---------------------------------------
(defun c:MTM ( / *my_error* Oldcmdecho olderr doc OldOsmode ModMtext texttomtext js n ent type )
(defun *my_error* ( msg )
(if Oldcmdecho (setvar 'cmdecho Oldcmdecho))
(if olderr (setq *error* olderr))
(if doc (vla-endundomark doc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(defun ModMtext ( ent1 / dxf_ent flag1 flag2)
(setq flag1 nil flag2 nil)
(if (/= 0 (getpropertyvalue ent1 "ColumnType"))
(setpropertyvalue ent1 "ColumnType" 0)
)
(setq dxf_ent (entget ent1))
(if (or (/= 0 (cdr (assoc 41 dxf_ent))) (/= 0 (cdr (assoc 46 dxf_ent))) )
(progn
(setq dxf_ent (subst '(41 . 0.0) (assoc 41 dxf_ent) dxf_ent))
(setq dxf_ent (subst '(46 . 0.0) (assoc 46 dxf_ent) dxf_ent))
(setq flag1 T)
)
)
(if (/= 3 (cdr (assoc 90 dxf_ent)))
(progn
(setq dxf_ent (append dxf_ent '((90 . 3) (63 . 256) (45 . 1.0) (441 . 0))))
(setq flag2 T)
)
)
(if (or flag1 flag2) (entmod dxf_ent))
)
;;; By Kent Cooper
(defun texttomtext ( tent / tobj tins tjust )
(setq
tobj (vlax-ename->vla-object tent)
tins (vlax-get tobj 'TextAlignmentPoint)
tjust (vla-get-Alignment tobj)
)
(cond
((= tjust 0) (setq tjust 7 tins (vlax-get tobj 'InsertionPoint)))
((< tjust 3) (setq tjust (+ tjust 7)))
((= tjust 4) (setq tjust 5))
((member tjust '(3 5))
(setq
tjust 8
tins (mapcar '/ (mapcar '+ (vlax-get tobj 'InsertionPoint) tins) '(2 2 2))
)
)
((setq tjust (- tjust 5)))
)
(command "_.txt2mtxt" tent "")
(setq tobj (vlax-ename->vla-object (entlast)))
(vla-put-AttachmentPoint tobj tjust)
(vlax-put tobj 'InsertionPoint tins)
(vlax-vla-object->ename tobj)
)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq olderr *error* *error* *my_error*)
(setq Oldcmdecho (getvar 'cmdecho))
(if (setq js (ssget "_:L" '((0 . "*TEXT"))))
(progn
(setvar 'cmdecho 0)
(repeat (setq n (sslength js))
(setq ent (ssname js (setq n (1- n))))
(setq type (cdr (assoc 0 (entget ent))))
(cond
( (= type "TEXT")
(ModMtext (texttomtext ent))
)
( (= type "MTEXT")
(ModMtext ent)
)
)
)
(setvar 'cmdecho Oldcmdecho)
)
(princ "\n: No Text or Mtext selected, try again \n")
)
(if olderr (setq *error* olderr))
(vla-endundomark doc)
(princ)
)
;; ------------------------------------ [9] BGMO - Remove background of Mtext ------------------------------------------
;; Remove Mtext Background
(defun c:BGMO (/ *my_error* doc olderr ss cnt objMtext) ;Background Mask Off
(vl-load-com)
(defun *my_error* ( msg )
(if olderr (setq *error* olderr))
(if doc (vla-endundomark doc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq olderr *error* *error* *my_error*)
(if (setq ss (ssget "_:L" '((0 . "MTEXT")(-4 . "<OR")(90 . 1)(90 . 3)(90 . 17)(90 . 19)(-4 . "OR>"))))
(repeat (setq cnt (sslength ss))
(setq objMtext (vlax-ename->vla-object (ssname ss (setq cnt (1- cnt)))))
(vla-put-backgroundfill objMtext :vlax-false)
)
)
(if olderr (setq *error* olderr))
(vla-endundomark doc)
(princ)
)
;; ------------------------------------ [10] MTW - Change width for Text, Mtext ----------------------------------------
;; Change Text, Mtext with
;; Original code by Komondormrex
(defun c:MTW (/ *my_error* doc olderr sls m_list m_string width_pos vla_obj )
(vl-load-com)
(defun *my_error* ( msg )
(if olderr (setq *error* olderr))
(if doc (vla-endundomark doc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(setq olderr *error* *error* *my_error*)
(if (setq sls (ssget "_:L" '((0 . "*TEXT"))))
(progn
(initget 6)
(setq wid (cond ( (getreal (strcat "\nText Width ?: <" (rtos (setq wid (cond ( wid ) ( 0.8 )))) ">: ")))( wid )))
(setq m_list (vl-remove-if 'listp (mapcar 'cadr (ssnamex sls))))
(foreach m_ename m_list
(if (= (vla-get-ObjectName (setq vla_obj (vlax-ename->vla-object m_ename))) "AcDbText")
(vla-put-ScaleFactor vla_obj wid)
(progn
(setq m_string (cdr (assoc 1 (entget m_ename))))
(while (or (setq width_pos (vl-string-search "\\w" m_string))
(setq width_pos (vl-string-search "\\W" m_string))
)
(setq m_string (strcat (substr m_string 1 width_pos) (substr m_string (+ 2 (vl-string-search ";" m_string width_pos)))))
)
(if (vlax-property-available-p vla_obj 'textstring)
(vla-put-textstring vla_obj (strcat "{\\W" (rtos wid 2 2) ";" m_string "}"))
)
)
)
)
)
(princ "\n: No Text or Mtext Selected, command cancelled \n")
)
(if olderr (setq *error* olderr))
(vla-endundomark doc)
(princ)
)
;; -------------------------------------- [ List of Sub functions - do not delete ]---------------------------------------
;; Ham kiem tra layer bi locked hay khong
(defun check_locked_layer ( lay_name / lay_data )
(and
(setq lay_data (tblsearch "LAYER" lay_name))
(= (logand (cdr (assoc 70 lay_data)) 4) 4)
)
)
;; Ham tim textbox chinh xac cho text, Mtext de tinh chieu dai thuc cua Text,Mtext
;; The following function is based on code by gile
(defun tbox:textbox ( enx off / mxv b h j l m n o p r w )
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(if
(setq l
(cond
( (= "TEXT" (cdr (assoc 0 enx)))
(setq b (cdr (assoc 10 enx))
r (cdr (assoc 50 enx))
l (textbox enx)
)
(list
(list (- (caar l) off) (- (cadar l) off))
(list (+ (caadr l) off) (- (cadar l) off))
(list (+ (caadr l) off) (+ (cadadr l) off))
(list (- (caar l) off) (+ (cadadr l) off))
)
)
( (= "MTEXT" (cdr (assoc 0 enx)))
(setq n (cdr (assoc 210 enx))
b (trans (cdr (assoc 10 enx)) 0 n)
r (angle '(0.0 0.0 0.0) (trans (cdr (assoc 11 enx)) 0 n))
w (cdr (assoc 42 enx))
h (cdr (assoc 43 enx))
j (cdr (assoc 71 enx))
o (list
(cond
((member j '(2 5 8)) (/ w -2.0))
((member j '(3 6 9)) (- w))
(0.0)
)
(cond
((member j '(1 2 3)) (- h))
((member j '(4 5 6)) (/ h -2.0))
(0.0)
)
)
)
(list
(list (- (car o) off) (- (cadr o) off))
(list (+ (car o) w off) (- (cadr o) off))
(list (+ (car o) w off) (+ (cadr o) h off))
(list (- (car o) off) (+ (cadr o) h off))
)
)
)
)
( (lambda ( m ) (mapcar '(lambda ( p ) (mapcar '+ (mxv m p) b)) l))
(list
(list (cos r) (sin (- r)) 0.0)
(list (sin r) (cos r) 0.0)
'(0.0 0.0 1.0)
)
)
)
)
;; Ham ho tro tim width
(defun width_clamp ( x a b )
(cond
((<= x a) a)
(t b)
)
)
;; make leader landing horizontal
;; [ ld ] - leader entity name
(defun entmodleader ( ld max_text_length max_text_height / ed edrv endpt midpt newmidpt newendpt newm newe endpoint dir midpoint width num ep_ucs mp_ucs newmidpt_ucs newendpt_ucs )
(setq ed (entget ld))
(setq edrv (reverse ed))
(setq endpoint (cdr (setq endpt (assoc 10 edrv))))
(setq midpoint (cdr (setq midpt (NTHASSOC 1 10 edrv))))
(setq ep_ucs (trans endpoint 0 1) mp_ucs (trans midpoint 0 1))
(if (NTHASSOC 2 10 edrv) (setq num 2) (setq num 3))
(setq dir (if (minusp (- (car ep_ucs) (car mp_ucs ))) "L" "R"))
(setq newmidpt_ucs (list (car mp_ucs) (cadr ep_ucs) (caddr mp_ucs)))
(if (and (< 0 max_text_length) (< 0 max_text_height))
(progn
(setq width (width_clamp max_text_length (* num max_text_height) (+ max_text_length (* num max_text_height))))
(setq newendpt_ucs (polar newmidpt_ucs (if (= dir "L") pi 0) width))
)
(setq newendpt_ucs ep_ucs)
)
(setq newmidpt (trans newmidpt_ucs 1 0))
(setq newendpt (trans newendpt_ucs 1 0))
(setq newm (cons 10 newmidpt))
(setq newe (cons 10 newendpt))
(setq edrv (subst newm midpt edrv))
(setq edrv (subst newe endpt edrv))
(setq ed (reverse edrv))
(entmod ed)
(list newendpt dir)
)
;; make Polyline landing horizontal
;; [ pl ] - polyline entity name
(defun entmodpolyline ( pl max_text_length max_text_height / ed edrv endpt midpt newmidpt newendpt newm newe endpoint dir midpoint width num ep_ucs mp_ucs newmidpt_ucs newendpt_ucs ep_wcs mp_wcs ep_wcs_return )
(setq ed (entget pl))
(setq edrv (reverse ed))
(setq endpoint (cdr (setq endpt (assoc 10 edrv))))
(setq midpoint (cdr (setq midpt (NTHASSOC 1 10 edrv))))
(setq ep_wcs (trans endpoint pl 0) mp_wcs (trans midpoint pl 0))
(setq ep_ucs (trans ep_wcs 0 1) mp_ucs (trans mp_wcs 0 1))
(if (NTHASSOC 2 10 edrv) (setq num 2) (setq num 3))
(setq dir (if (minusp (- (car ep_ucs) (car mp_ucs ))) "L" "R"))
(setq newmidpt_ucs (list (car mp_ucs) (cadr ep_ucs) (caddr ep_ucs)))
(if (and (< 0 max_text_length) (< 0 max_text_height))
(progn
(setq width (width_clamp max_text_length (* num max_text_height) (+ max_text_length (* num max_text_height))))
(setq newendpt_ucs (polar newmidpt_ucs (if (= dir "L") pi 0) width))
)
(setq newendpt_ucs ep_ucs)
)
(setq newmidpt (trans (trans newmidpt_ucs 1 0) 0 pl))
(setq newendpt (trans (trans newendpt_ucs 1 0) 0 pl))
(setq newm (cons 10 (list (car newmidpt) (cadr newmidpt))))
(setq newe (cons 10 (list (car newendpt) (cadr newendpt))))
(setq edrv (subst newm midpt edrv))
(setq edrv (subst newe endpt edrv))
(setq ed (reverse edrv))
(entmod ed)
(setq ep_wcs_return (trans newendpt pl 0))
(list ep_wcs_return dir)
)
;; make line landing horizontal
;; [ li ] - line entity name
(defun entmodline ( li max_text_length max_text_height / ed endpt midpt newmidpt newendpt newm newe endpoint dir midpoint width ep_ucs mp_ucs newmidpt_ucs newendpt_ucs )
(setq ed (entget li))
(setq endpoint (cdr (setq endpt (assoc 11 ed))))
(setq midpoint (cdr (setq midpt (assoc 10 ed))))
(setq ep_ucs (trans endpoint 0 1) mp_ucs (trans midpoint 0 1))
(setq dir (if (minusp (- (car ep_ucs) (car mp_ucs ))) "L" "R"))
(setq newmidpt_ucs (list (car mp_ucs) (cadr ep_ucs) (caddr ep_ucs)))
(if (and (< 0 max_text_length) (< 0 max_text_height))
(progn
(setq width (width_clamp max_text_length (* 3 max_text_height) (+ max_text_length (* 3 max_text_height))))
(setq newendpt_ucs (polar newmidpt_ucs (if (= dir "L") pi 0) width))
)
(setq newendpt_ucs ep_ucs)
)
(setq newmidpt (trans newmidpt_ucs 1 0))
(setq newendpt (trans newendpt_ucs 1 0))
(setq newm (cons 10 newmidpt))
(setq newe (cons 11 newendpt))
(setq ed (subst newm midpt ed))
(setq ed (subst newe endpt ed))
(entmod ed)
(list newendpt dir)
)
;; make leader from polyline
;; ByKent1Cooper
;; [ pl ] - polyline entity name
(defun polylinetoleader ( pl / i )
(setq i -1)
(command "_.leader")
(repeat (+ (fix (vlax-curve-getEndParam pl)) (if (vlax-curve-isClosed pl) 0 1))
(command (trans (vlax-curve-getPointAtParam pl (setq i (1+ i))) 0 1))
)
(command "" "" "_none" "_.matchprop" pl (entlast) "" )
(entdel pl)
)
;; make leader from line
;; [ li ] - line entity name
(defun linetoleader ( li / p1 p2)
(setq p1 (trans (cdr(assoc 10 (entget li))) 0 1))
(setq p2 (trans (cdr(assoc 11 (entget li))) 0 1))
(command "_.LEADER" p1 p2 "" "" "N")
(entdel li)
)
;; Assoc n-th ( DCBroad 2008 )
;; [ N ] - n-th order for Assoc to a key
;; [ KEY ] - key for Assoc
;; [ LST ] - list for Assoc
(defun NTHASSOC (N KEY LST / ITEM)
(setq ITEM (assoc KEY LST))
(if (<= N 0)
ITEM
(NTHASSOC (1- N) KEY (cdr (member ITEM LST)))
)
)
;; SelectionSet -> Entities
;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com
;; [ ss ] - selection set
(defun LM:ss->ent ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (ssname ss (setq i (1- i))) l))
)
)
)
;; find point
(defun findpoint ( m n startpt endpt / x a b y )
(setq a (car startpt) b (cadr startpt) y (cadr endpt))
(setq x (+ a (/ (* m (- y b)) n)))
x
)
;; setting angle ALP
(defun setting_angle_alp ( / data_list default ans )
(setq data_list (list "Select Angle for Leader" "90" "60" "45" "30" ))
(setq default (vl-position *alp_angle* data_list))
(if (not default) (setq default 1))
(setq ans (ah:butts default "V" data_list ))
(if ans
(progn
(setq *alp_angle* ans)
(cond
((equal ans "30") (setq *lst_alv_alp* (list (sqrt 3) 1 )))
((equal ans "45") (setq *lst_alv_alp* (list 1 1 )))
((equal ans "60") (setq *lst_alv_alp* (list 1 (sqrt 3) )))
((equal ans "90") (setq *lst_alv_alp* (list 0 1 )))
(T (exit))
)
)
(exit)
)
)
;; setting angle AMM
(defun setting_angle_amm ( / data_list default ans )
(setq data_list (list "Select Angle for Leader" "90" "60" "45" "30" "0"))
(setq default (vl-position *amm_angle* data_list))
(if (not default) (setq default 1))
(setq ans (ah:butts default "V" data_list ))
(if ans
(progn
(setq *amm_angle* ans)
(cond
((equal ans "0") (setq *lst_alv_amm* (list pi pi 0.0 0.0)))
((equal ans "30") (setq *lst_alv_amm* (list (/ (* 7 pi) 6) (/ (* 5 pi) 6) (/ (* 11 pi) 6) (/ pi 6))))
((equal ans "45") (setq *lst_alv_amm* (list (/ (* 5 pi) 4) (/ (* 3 pi) 4) (/ (* 7 pi) 4) (/ pi 4))))
((equal ans "60") (setq *lst_alv_amm* (list (/ (* 4 pi) 3) (/ (* 2 pi) 3) (/ (* 5 pi) 3) (/ pi 3))))
((equal ans "90") (setq *lst_alv_amm* (list (/ (* 3 pi) 2) (/ pi 2) (/ (* 3 pi) 2) (/ pi 2))))
(T (exit))
)
)
(exit)
)
)
;;; Multi button Dialog box for a single choice repalcment of initget
;;; By Alan H Feb 2019
(defun AH:Butts ( AHdef verhor butlst / fo fname x k dcl_id but )
(defun butval ( / l)
(setq x 1)
(repeat (length butlst)
(setq l (strcat "Rb" (rtos x 2 0)))
(if (= (get_tile l) "1" )
(setq but x)
)
(setq x (+ x 1))
)
)
(setq fo (open (setq fname (vl-filename-mktemp "" "" ".dcl")) "w"))
(write-line "AHbutts : dialog {" fo)
(write-line (strcat " label =" (chr 34) (nth 0 butlst) (chr 34) " ;" )fo)
(write-line " : row {" fo)
(if (= (strcase verhor) "V")
(progn
(write-line " : boxed_radio_column {" fo)
(write-line (strcat " width = " (rtos (+ (strlen (nth 0 butlst)) 10) 2 0) " ;") fo) ; increase 10 if label does not appear
)
(write-line " : boxed_radio_row {" fo)
)
(setq x 1)
(repeat (- (length butlst) 1)
(write-line " : radio_button {" fo)
(write-line (strcat "key = " (chr 34) "Rb" (rtos x 2 0) (chr 34) ";") fo)
(write-line (strcat "label = " (chr 34) (nth x butlst) (chr 34) ";") fo)
(write-line " }" fo)
(write-line "spacer_1 ;" fo)
(setq x (+ x 1))
)
(write-line " }" fo)
(write-line " }" fo)
(write-line "spacer_1 ;" fo)
(write-line " ok_cancel;" fo)
(write-line " }" fo)
(close fo)
(setq dcl_id (load_dialog fname))
(if (not (new_dialog "AHbutts" dcl_id "" (cond ( *screenpoint* ) ( '(-1 -1) ))) )
(exit)
)
(setq x 1)
(repeat (- (length butlst) 1)
(setq k (strcat "Rb" (rtos x 2 0)))
(if (= ahdef x) (set_tile k "1"))
(setq x (+ x 1))
)
(action_tile "accept" "(butval) (setq *screenpoint* (done_dialog))")
(action_tile "cancel" "(done_dialog) (exit)")
(start_dialog)
(unload_dialog dcl_id)
(vl-file-delete fname)
(if (= but nil) (setq but 2))
(nth but butlst)
)
;; Getsel
(defun AT:GetSel ( meth msg fnc / ent good)
;; meth - selection method (entsel, nentsel, nentselp)
;; msg - message to display (nil for default)
;; fnc - optional function to apply to selected object
;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC")))
;; Alan J. Thompson, 05.25.10
(setvar 'errno 0)
(while (not good)
(setq ent (meth (cond (msg)
("\nSelect sample object: ")
)
)
)
(cond
((vl-consp ent)
(setq good (if (or (not fnc) (fnc ent))
ent
(prompt "\n: Invalid object!")
)
)
)
((eq (type ent) 'STR) (setq good ent))
((setq good (eq 52 (getvar 'errno))) nil)
((eq 7 (getvar 'errno)) (setq good (prompt "\n: Missed, try again.")))
)
)
)
;; ---------------------------- [ Text lines printed in Command Line when LISP loaded successfully ] ---------------------------------
(princ "\n [ Leader & Text utilities - Ver 2.4.2 UCS ]\n")
(princ "\n [ Type HDSD_ATL to show all available commands of this tool ]\n")
(princ)Link tải (MediaFire)
---------------------------------------------------------------------------------------------
Mọi thông tin xin liên hệ Fanpage AutoLISP Thật là đơn giản!
Cảm ơn bạn đã theo dõi!
Không có nhận xét nào:
Đăng nhận xét