AutoCADマクロ屋本舗 掲示板

はじめまして。いつもサイトを参考にさせて頂いてます。
件名の通りですが、寸法値の文字色が一部変更されているファイルを受け取りました。
付け足されている文字内容等はすべてそのままで、色変更が行われている文字をByLayer
に変更したいのですが、1つ1つ地道に変更することしか出来ず困っています。
（具体的には、変更箇所に色がついてきたのですが色だけを元に戻したい）
寸法の数が大量なので、一括で指定の色にする、もしくはリセット（ByLayer）するなど
マクロで出来ないでしょうか。
ご回答宜しくお願い致します。（LT2018以降で対応可能）

^C^Cdimoverride;dimclrt;$M=$(getvar,dimclrt);;all;^M
実行すると、現在の寸法スタイルの設定色に変更します。

色を指定したい場合は、$M=$(getvar,dimclrt)の部分を色名か色番号に書き換えです。
例えば赤にしたいなら
^C^Cdimoverride;dimclrt;RED;;all;^M
30番の色にしたいなら
^C^Cdimoverride;dimclrt;30;;all;^M
ByLayerにしたいなら
^C^Cdimoverride;dimclrt;ByLayer;;all;^M
です。

早速のご回答ありがとうございます！

しかしながら、教えて頂いた内容では変更ができませんでした。。
寸法値のすべてがByLayerから色変更されている場合には、マクロ通り色変更が出来ましたが
今回のように、寸法値の一部だけが色変更行われているものには、効きませんでした。。

伝え方が足りず、イメージの認識が違うかもしれないと思いましたので、補足させて頂きます。

＞寸法値の文字色が一部変更されている･･･
これは、例えば長さ寸法記入で寸法線を引き出したあと、個々に “TEXTEDIT” で「〇〇長　L=＜＞m」と付け加えたとします。
その中の「〇〇長」の文字だけを色（仮に10番）変更し、あとの文字色はByLayerのままとした状態のことを表しています。

このように、あとから個々に編集された各種寸法線が大量にあります。
付け加える文字内容は「〇〇長　L=＜＞m」以外にも色々ありますが、共通しているのは文字内容の一部の色がByLayerから
あえて変更されているということです。
今回はすべて共通の色（仮に10番）としていますが、ByLayer以外の各種色変更を行われてくることもあるかもしれないので、
ご提案頂いたとおり、色を指定して変更したり、ByLayerにしたり出来れば大変助かります。

お手数ですが、上記内容でまたご回答頂けると助かります。
宜しくお願い致します。

イメージ画像を添付させて頂きます。
宜しくお願い致します。

状況は理解できました。　出来るか判りませんが考えてはみます。


ちなみに、寸法の自動調整は使ってますか？
使ってる場合、それが解除されても良いですか？

マクロで考えるのが面倒だったのでVBS(with AcadRemocon)で作りました。
注意：寸法の自動調整は解除されます。

AcadRemoconがインストールしてあれば、下記をVBSファイルにして、ダブルクリックするだけです。

ファイルデータが滅茶苦茶重たい（またはパソコンスペックが著しく低い）場合は、
プログラム中の「Acad.Wait 2000」の2000を3000、4000と増やしてください。
「Acad.Wait 2000」は2ヶ所ありますので、どちらとも。

'↓ここからがVBSです。
Dim Acad
'========== ***** ↓↓↓↓↓ ***** ==========
'極楽鳥さんに感謝！！
If MustRun Then WScript.Quit '二重起動しているか？
'========== ***** ↑↑↑↑↑ ***** ==========

Call Main

Sub Main()
Set Acad = CreateObject("AcadRemocon.Body")
fileName = Acad.GetWindowsTemp() & "AcadRemocon.dxf"
Acad.acPostCommand "^C^Cundo^Mbe^Mdimdisassociate^MALL^M^Mfiledia^M0^Mdxfout^M" & fileName & "^Mo^Mp^M^Mv^M2000^M16^My^M^C^Cfiledia^M1^M"
Acad.Wait 2000
Acad.DxfExtract Cnt, Arr, "ENTITIES", "", "DIMENSION", "1"
If Cnt = 0 Then Exit Sub
UPD = False
For i = 1 To Cnt
TmpStr = RePlace(Arr(1, i) , "\\C" , "Doskoi7Tsuppari8")
If InStr(Arr(1, i) , "\C") > 0 Then
Do
ST = InStr(TmpStr , "\C")
ED = ST + 1
Do
If Mid(TmpStr , ED , 1) = ";" Then Exit Do Else ED = ED + 1
Loop
TmpStr = Mid(TmpStr , 1 , ST - 1) & Mid(TmpStr , ED + 1)
If InStr(TmpStr , "\C") = 0 Then Exit Do
Loop
Arr(1, i) = RePlace(TmpStr , "Doskoi7Tsuppari8" , "\\C")
UPD = True
End If
Next

If Not UPD Then Acad.acPostCommand "^C^CUNDO^ME^Mu^M" : Acad.acShowMessage "上書き寸法の着色は見つかりませんでした。" : Exit Sub

Acad.DxfUpdate Arr
Acad.Wait 2000
Acad.acPostCommand "^C^Cucs^Mw^M-insert^M*" & fileName & "^M0,0^M1^M0^Mucs^Mp^MERASE^MP^M^MUNDO^ME^M"

Acad.acShowMessage "上書き寸法の着色を解除しました。"
End Sub

Public Function MustRun()
'実行している環境が64ビット環境か、32ビット環境か判断し、
'64ビット環境であれば、32ビット環境で自身の再起動を試みる。
'そして、Trueを返す。32ビット環境であれば、Falseを返す。
Const WSHOST = "wscript.exe"
Dim objWshShell 'WshShell オブジェクト
Dim ExecCmd '実行するコマンドライン

Set objWshShell = WScript.CreateObject("WScript.Shell")
If objWshShell.ExpandEnvironmentStrings("%PROCESSOR_ARCHITECTURE%") = "AMD64" Then
ExecCmd = objWshShell.ExpandEnvironmentStrings("%WINDIR%") & _
"\SysWOW64\" & WSHOST & " " & _
Chr(34) & WScript.ScriptFullName & Chr(34)
objWshShell.Exec(ExecCmd)
MustRun = True
Else 'x86
MustRun = False
End If

Set objWshShell = Nothing
Set ExecCmd = Nothing

End Function
'↑ここまでがVBSです。

※　上記VBS：2020/02/16 (Sun) 01:01　に修正。

AcadRemoconのインストールは、
http://hp.vector.co.jp/authors/VA026873/

この中の、
「AcadRemocon導入・更新支援ソフト(Aremoupd.exe)・・・48KB」
からダウンロードしてインストールです。
【重要】リンクをクリックしたら、ダウンロードしなくてもインストールができますが、
そこではインストールせず、必ず、ダウンロードを行ってパソコンに保存してください。
そして保存したファイルを右クリックして「管理者として実行」です。
後は、指示に従ってインストールを完了させて下さい。
「管理者として実行」せずにインストールした場合は、機能しません。

VBSの使い方は、
①メモ帳を起動して、VBSプログラムをコピペ。
②名前を付けて保存で、ファイルの種類を「すべてのファイル(*.*)」にしてから、
　「〇〇.vbs」の名前で保存。（〇〇は何でも良い）

※保存するときの文字コードはANSIにする。何も設定していないとUTF-8（ユニコード）で保存される。
※そのファイルが水色のアイコンになってたら成功。テキストファイルのアイコンなら失敗。

③そのVBSファイルをデスクトップの隅っこに置き、
AutoCADに対象の図面を開いた状態で、AutoCADの枠を少し小さくしてVBSファイルが見えるようにする。
そして、VBSファイルをダブルクリックする。

数秒待ったら、「上書き寸法の着色を解除しました」の表示が出ます。

ご連絡ありがとうございます！！
こんな短時間ですごい式を組んで頂けて、本当に驚愕しております！
すぐご対応頂いたのに、まだ試すことが出来ておらず申し訳ありませんが、
未熟者ながらやってみようと思います。
また何かあれば、ご連絡させて頂きます。
ひとまず、お礼まで。本当にありがとうございました！！！！！！！

Lon様

お世話になっております。
教えて頂いた「AcadRemocon」ですが、エラーが出てしまいインストール出来ませんでした。
（「AcadRemocon.dllをシステムフォルダにコピーできませんでした」とメッセージが出ました。）

サイトに導入EXEを使わずに手動でインストールする方法が書かれていたので試みようと思いましたが、
肝心なlzhやmsiデータなどがダウンロードできず（見つからず）断念しました。。。

このソフトをインストールする方法、もしくはこのソフトを使わずして出来る方法が分かれば
教えて頂けると助かります。
宜しくお願い致します。

セキュリティの問題でしょうね。多分。

「AcadRemocon導入・更新支援ソフト(Aremoupd.exe)・・・48KB」
のリンクをクリックしたら、そのままインストールしない！！。
「Aremoupd.exe」をPCに保存してください。

そして、保存した「Aremoupd.exe」をダブルクリックしない！！
右クリックして、「管理者として実行」です。

これでインストールできると思いますよ。

Lon様

出来ましたーーーーーーーー！！！！！！！！！

大げさでなく本当に感動しました！！！！！！！

「AcadRemocon」というソフトも初めて知りましたが、こんな事が出来てしまうのかと本当に驚きました！！

迅速かつ丁寧なご対応にも本当に感謝いたします。

ありがとうございました！！

Lon様

昨日は作成頂いた通り出来て感動していたのですが。。
別PCで同作業をしたところ、添付のようなエラーが出てしまいました。。
CADのバージョンは同一のものを使用していますが、念のため別のバージョンでも試してみましたが
やはりエラーが出てしまいました。。
「AcadRemocon」は古い？ので上手く作動するバージョンやPCがあるとかないとか･･･
そんな記事を読みましたが、これもその類なのでしょうか？？

ご回答宜しくお願い致します。

こんなエラーが出ました。。

そのエラーは読み込んだデータを処理しきれない場合に発生します。

まずは、昨日成功したデータと同じデータでやってみてください。
それで成功するなら、エラーの出るデータが問題である可能性が高いです。

VBSで読み込むことのできない特殊文字列を使っているデータだったり。
色だけでなく大きさやフォントを変えてたり。
色を変える命令の後に何も文字列が無かったり。

昨日のデータでもエラーが出るなら、VBSやVB6のランタイムを更新すると改善する可能性があります。
それでもダメなら、原因はパッと思いつかない・・・というか、色々な可能性が在りすぎて、
コレと断定できる物がないです。

そこにエラーコードが出てますので、
「VBS エラー 800a0005」のようなキーワードでネット検索すると、色々と情報が出てきます。

「データが問題」という言い方は不適切ですね。

CADのデータとしては問題ありません。
それをこのVBSで処理することに対して問題がある。と言うことです。

例えるなら、
報告書を英語で書くことは問題ではありません。
でも、私は簡単な英語しか読めないので、難しい英語の報告書を貰っても、ダメ！と言って突き返します。

Lon様

とても分かりやすいご説明ありがとうございます。
何通りか試してみましたが、やはりご指摘の通り成功した時には使用していなかった文字配列などが
原因でエラーが出ていたようでした。
そして、それを追求するには可能性が膨大にありすぎて特定が困難なこともよく分かりました。

なんとなく分かったものは、実際の寸法値よりも後ろにある文字に色がついていると比較的エラーが
出るっぽいということだけです。（イメージ画像でいうと「m」のところ）
基本的には、寸法値よりも前部分を想定してるので問題はないかと思いますが、エラーが出たおかげで
事前に要注意するべき点があるということがわかって良かったです。

何度もご対応頂きまして、本当にありがとうございました！！！

>寸法値よりも後ろにある文字に色がついていると比較的エラーが出るっぽい

なるほど。

>色を変える命令の後に何も文字列が無かったり。
と危惧した事に関連してます。

その部分を改善してみました。

上のプログラムを修正していますので、もう一度コピペしてVBSファイルを作り直してください。

Lon様

だい～～～～～～～ぶお返事遅くなってしまいましたが、改善して頂いたものも、その前のものも
無事に本番？で使用することが出来ました！！
大量にあったので、中にはエラーが出てしまうものもあるのではないかと少々心配しましたが
すべて綺麗に色が変わってくれました！感動です！！！
本当にありがとうございました！！！