AutoCADマクロ屋本舗 掲示板

文字オブジェクトをクリックして文字内容をクリップボードにコピーする物です。
マクロとVBSを併用です。

※このVBSにはAcadRemoconは必要ありません。
※VBS=AcadRemoconと思い込んでいる人も多いようですので念のため。
※「AcadRemoconって何？」って人は気にしなくて良いです。使いませんので。
※参考スレhttps://totthi.bbs.fc2.com/?act=reply&tid=16703972

まずは、下記のプログラム構文をコピーしてメモ帳に貼り付けて下さい。
そして、Dドライブの直下（フォルダを作らないでD:の中）に、「TextClip.vbs」の名前で保存してください。
拡張子は「.txt」ではありません。「.vbs」です。
保存する際の文字コードは「ANSI」です。（これ大事）
保存したファイルのアイコンが水色の「S」という文字のロゴに変わっていれば正常に保存された事になります。
アイコンがテキストファイルのままなら、拡張子を確認して下さい。
本来は、保存ファイル名や保存する場所は、どこでも良いのですが、
今回は、従って下さい。うまく実行出来たら、お好きに変えて下さい。
「私のパソコンにはDドライブなんて無いわよ」なんて人はお好きな場所にどうぞ。
その代わり、文末のマクロ内のDドライブの記述（AI_STARTAPP "D:TextClip.vbs"）を書き換えて。


↓ここからvbsプログラム

Option Explicit
Call Main
Sub Main

Dim s
WScript.Sleep 500
s = GetClipboardText()
s = mid(s , InStrRev(s , "新しい文字を入力 <"))

s = mid(s , InStr(s , "<") + 1)
s = mid(s , 1 , InStr(s , ">: lonLONLon") - 1)

SetClipboard s

End Sub

Function GetClipboardText()
Dim objHTML
Set objHTML = CreateObject("htmlfile")
GetClipboardText = Trim(objHTML.ParentWindow.ClipboardData.GetData("text"))
End Function


Function SetClipboard(ScrMsg)
Dim ws, cl, si
Set ws = CreateObject("WScript.Shell")
Set cl = ws.Exec("Clip")
Set si = cl.stdIn
si.Write ScrMsg
si.Close
Set si = Nothing
Set cl = Nothing
SEt ws = Nothing
End Function

↑ここまでvbsプログラム

マクロはこうなります。（R版で使用する場合は、次の書き込みを確認＆実行してください）
*^C^Cchange;si;\;;;;;$M=$(if,$(getvar,cmdactive),,change;p;;;;;;)lonLONLon;u;copyhist;GRAPHSCR;AI_STARTAPP "D:TextClip.vbs"^M

※このマクロは、ダイナミックテキスト専用です。
マルチテキストや寸法値にも使いたい場合は、次の次の次の書き込みを参考にしてください。
属性文字には使えません。

①マクロ起動
②文字オブジェクトクリック
③EXCELのセルを右クリックして貼付け

R版で使用する場合は、下記LISPをロードした後に、マクロを実行してください。
毎回ロードするのが面倒なら、スタートアップに登録すると良いです。

(defun C:AI_STARTAPP ( / )
(setq Q (getstring ""))
(STARTAPP "C:/WINDOWS/SYSTEM32/WSCRIPT.EXE" Q)
(PRINC)
)

VBSの中身を下記の様にすれば、

①EXCELの記入開始セルをクリック
②文字オブジェクトクリックすると、EXCELのセルに記入して改行
以降②を繰り返し

の操作になります。
参考スレhttps://totthi.bbs.fc2.com/?act=reply&tid=16719821


↓ここからvbsプログラム

Option Explicit
Call Main
Sub Main

Dim s
WScript.Sleep 500
s = GetClipboardText()
s = mid(s , InStrRev(s , "新しい文字を入力 <"))

s = mid(s , InStr(s , "<") + 1)
s = mid(s , 1 , InStr(s , ">: lonLONLon") - 1)

SetClipboard ""

Dim ex
Set ex = GetObject(, "Excel.Application")
ex.ActiveCell.Value = s
ex.ActiveCell.Offset(1,0).Select

End Sub

Function GetClipboardText()
Dim objHTML
Set objHTML = CreateObject("htmlfile")
GetClipboardText = Trim(objHTML.ParentWindow.ClipboardData.GetData("text"))
End Function

Function SetClipboard(ScrMsg)
Dim ws, cl, si
Set ws = CreateObject("WScript.Shell")
Set cl = ws.Exec("Clip")
Set si = cl.stdIn
si.Write ScrMsg
si.Close
Set si = Nothing
Set cl = Nothing
SEt ws = Nothing
End Function

↑ここまでvbsプログラム

某掲示板（知〇袋）にて、このスレッドが紹介され、
「寸法値に対応していない」とのご指摘を受けましたので、考えてみました。

起動用のマクロ
*^C^Cchange;si;\;;;;;$M=$(if,$(getvar,cmdactive),,change;p;;;;;;)lonLONLon;u;copyhist;GRAPHSCR;AI_STARTAPP "D:TextClip.vbs"^M

を下記の様に変更すると、寸法値やマルチテキストにも対応できると思います。
*^C^C$M=setenv;to;0;$(nth,$(getenv,to),copy;\non;@;;non;@;non;@;setenv;to;1,,)$(nth,$(getenv,to),,setenv;to;1;explode;@;$M="""$(if,$(getvar,cmdactive),;setenv;to;2,erase;p;r;l;)""",)$(nth,$(getenv,to),,,change;l;;;;;;;$M="""$(if,$(getvar,cmdactive),,change;l;;;;;;)"""lonLONLon;u;copyhist;erase;l;;GRAPHSCR;AI_STARTAPP "D:TextClip.vbs")^M


※使用しているAutoCADがR版（LTと付かないバージョン）の場合、下記の2つの処理を行ってください。

〇setenv,getenvを使用可能にする。（「TdMacros.lsp」の登録）
https://ameblo.jp/totthi-macro/entry-10895232361.html

〇AI_STARTAPPコマンドを定義する。
下記をLISPファイルにして、ロードする。（又はスタートアップ登録する）

(defun C:AI_STARTAPP ( / )
(setq Q (getstring ""))
(STARTAPP "C:/WINDOWS/SYSTEM32/WSCRIPT.EXE" Q)
(PRINC)
)

某掲示板に質問した者です。
まさか違う掲示板にて回答頂けるとは思ってもいませんでしたが、

やりたかった仕様での答えを頂き、無事に解決しました。
既に作成したマクロを改良し、使いやすくして頂きまして、
ありがとうございました。

今後もコチラの掲示板を参考にさせて頂ければと思います。
どうぞよろしくお願いいたします。