AutoCADマクロ屋本舗 掲示板

文字に斜め線を描くくマクロを探していましたが見つけられなくて、お願いの投稿です。
素人考えの描画イメージは、justifytextで起点を左下、右上と変えて対角の座標を結ぶというものですが、それをマクロにする知識も無く。
文字枠マクロなら2点の座標を使ってて編集でなんとかならないかとこちらのマクロ集のものを見ましたがさっぱりわからず手が出せず。
ベテランの方ならすぐ作れそうだと思うのですが、もし煩わしくないようでしたら作っていただけないでしょうか。
わがままが通るなら、文字の回転角度も追って斜線描画できると嬉しいです。


環境　2021R、TdMacros.lsp登録済み。

justifytextで起点を左下、右上とは少し違いますが

^C^C_select;$M=$(if,$(getvar,CMDACTIVE),\,)undo;be;erase;all;r;p;;zoom;e;line;non;$M="$(getvar,EXTMIN)";non;$M="$(getvar,EXTMAX)";;copybase;non;0<0;l;;undo;e;u;pasteclip;non;0<0;^Z

操作方法はオブジェクトを選択するだけです

選択後マクロ起動でもマクロ起動後選択でもＯＫです。

以前に『EXTMIN』、『EXTMAX』の座標が取れなかった場合があったので
少し修正しました

*^C^C_select;$M=$(if,$(getvar,CMDACTIVE),\,)undo;be;ucs;w;erase;all;r;p;;zoom;e;line;non;$M="$(index,0,$(getvar,EXTMIN))",$M="$(index,1,$(getvar,EXTMIN))";non;$M="$(index,0,$(getvar,EXTMAX))",$M="$(index,1,$(getvar,EXTMAX))";;ucs;p;copybase;non;0<0;l;;undo;e;u;pasteclip;non;0<0^M

あと、繰り返し仕様にしたので終了はEscキーになります

>文字の回転角度も追って斜線描画できると嬉しいです
すいません、見落としてました
未対応です

もうすぐみんながLISPを使えるようになると思うので練習。練習。
とてもマクロ臭の強いLISPができました。
レスポンスと精度を求めないならこれで十分じゃなかと？

(defun c:ShasenTxt ( / t1)
(while (setq t1 (car (entsel "\n 基準文字を選択： ")))
(if (= (cdr (assoc 0 (entget t1))) "TEXT")
(command "ucs" "w" "ucs" "m" (cdr (assoc 10 (entget t1))) "line" "non" (car (textbox (entget t1))) (cadr (textbox (entget t1))) "" "rotate" "l" "" "non" "0<0" (rtos (* 180 (/ (cdr (assoc 50 (entget t1))) PI))) "ucs" "p" "ucs" "p")
)
)
(princ)
)

レイアウト使ってみました

*^C^C$M=setenv;to;0;$(nth,$(getenv,to),join;文字を選択(R-Clickで終了)^X\$M="""$(if,$(getvar,CMDACTIVE),;select;non;@;non;@;;ucs;ob;non;@;setenv;to;1,^Csetenv;to;0)""",,,)$(nth,$(getenv,to),,copybase;non;0<0;p;;-layout;d;tmplo;;n;tmplo;;s;tmplo;point;0<0;erase;all;;pasteclip;non;0<0;setenv;to;2,,)$(nth,$(getenv,to),,,zoom;e;line;non;$(getvar,EXTMIN);non;$(getvar,EXTMAX);;copybase;non;0<0;l;;erase;all;;setenv;to;3,)$(nth,$(getenv,to),,,,-layout;s;model;pasteclip;non;0<0;ucs;p;-layout;d;tmplo;setenv;to;0)^M

１.マクロ起動
２.文字オブジェクト選択(R-Clickで終了できます)

繰り返し

※同じ名前のレイアウトがあるとＮＧなので現状『tmplo』レイアウトがある場合はマクロ内の
『tmplo』を変更してください

自己満足で複数一度に

*^C^C$M=setenv;to;0;$(nth,$(getenv,to),select;\copybase;non;0<0;p;;-layout;d;tmplo1;;n;tmplo1;;s;tmplo1;point;0<0;erase;all;;pasteclip;non;0<0;setenv;to;1,,,,)$(nth,$(getenv,to),,;to;4;ucs;ob;l;copybase;non;0<0;l;;-layout;d;tmplo2;;n;tmplo2;;s;tmplo2;point;0<0;erase;all;;pasteclip;non;0<0;zoom;e;setenv;to;2,,,)$(nth,$(getenv,to),,,line;non;$(getvar,EXTMIN);non;$(getvar,EXTMAX);;copybase;non;0<0;l;;erase;all;;setenv;to;3,,)$(nth,$(getenv,to),,,,-layout;s;tmplo1;pasteclip;non;0<0;ucs;p;copybase;non;0<0;l;;erase;l;;;l;;-layout;s;model;pasteclip;non;0<0;-layout;s;tmplo1;setenv;to;1,)$(nth,$(getenv,to),,,,,-layout;s;model;;d;tmplo1;;d;tmplo2;setenv;to;0)^M

１.マクロ起動
２.文字オブジェクト選択(複数可)

繰り返し

終了はEscキーです

※レイアウトを利用して作業しているため数が多いとフリーズのような状態が長く続くと思います
※同じ名前のレイアウトがあるとＮＧなので現状『tmplo1』『tmplo2』レイアウトがある場合はマクロ内の
『tmplo1』『tmplo2』をすべて変更してください

複数選択バージョンLisp。

(defun c:ShasenTxt2 ( / ss t1 p1 p2 wp1 wp2 cnt)

(setq ss (ssget '((0 . "text"))))
(setq cnt 0)

(repeat (sslength ss)
(setq t1 (ssname ss cnt))

(command "ucs" "OB" t1)

(setq p1 (car (textbox (entget t1))))
(setq p2 (cadr (textbox (entget t1))))

(setq wp1 (trans p1 1 0 ))
(setq wp2 (trans p2 1 0 ))

(command "ucs" "p" )
(entmake (list (cons 0 "LINE")
(cons 10 wp1)
(cons 11 wp2)))
(setq cnt (1+ cnt))

)

(princ)
)