AutoCADマクロ屋本舗 掲示板

長々ですみませんが　下記｛ブロックエディタ もどき」をAutoCAD2023で使用出来るよう変更出来ませんでしょうか。

'ブロックエディタ もどき
Dim Acad
'このステートメントは必ずCreateObjectよりも
'前の位置に挿入する。
'========== ***** ↓↓↓↓↓ ***** ==========
If MustRun Then WScript.Quit '二重起動しているか？
'========== ***** ↑↑↑↑↑ ***** ==========

'Set Acad = CreateObject("AcadRemocon.Body")
'以下何らかの処理をするコード
Dim Cnt, Arr, LayoutName, Clayer, retHist
Dim i, j, Ctab, SPB, SPS, SPM, CVP
Dim ShowPrintBorder, ShowPlotSetup, ShowPaperMargins, CreateViewports
Call Main

Sub Main()
'AcadRemocon作成
Set Acad = CreateObject("AcadRemocon.Body")

'AutoCAD実行中のコマンドを終了させる
If Not Acad.acEscapeCommand() Then Er: Exit Sub
'バージョンチェック
If Not Acad.CheckVersion("314") Then Exit Sub

'ブロック選択
If Not Acad.acSendCommand("^C^Cundo be ") Then Er: Exit Sub
If Not Acad.acSelect("ブロックを選択", Cnt, "SGL", retCancel) Then Acad.acPostCommand "undo e u ": Er: Exit Sub
If Cnt = 0 Then Acad.acPostCommand "undo e u ": Exit Sub
If Not Acad.acDxfOut(, "PREV", , , "2000") Then Er: Exit Sub
If Not Acad.DxfExtract(Cnt, Arr, "ENTITIES", "", "ATTRIB", "8") Then Er: Exit Sub
If Cnt > 0 Then Acad.acPostCommand "undo e u ": Acad.acShowMessage "現在、属性付のブロックには対応していません。" & vbCrLf & "ごめんなさいm(__)m", , "BlockEditor": Exit Sub
If Not Acad.DxfExtract(Cnt, Arr, "ENTITIES", "", "INSERT", "2|8") Then Er: Exit Sub
If Cnt = 0 Then Acad.acPostCommand "undo e u ": Acad.acShowMessage "これはブロックじゃない！", , "BlockEditor": Exit Sub

If Not Acad.acGetVar("Ctab", Ctab) Then Er: Exit Sub
If Not Acad.acGetVar("Clayer", Clayer) Then Er: Exit Sub
If Not Acad.acPostCommand("setenv^MShowPrintBorder^M0^M") Then Er: Exit Sub
SPB = GetDefValue()
If Not Acad.acPostCommand("setenv^MShowPlotSetup^M0^M") Then Er: Exit Sub
SPS = GetDefValue()
If Not Acad.acPostCommand("setenv^MShowPaperMargins^M0^M") Then Er: Exit Sub
SPM = GetDefValue()
If Not Acad.acPostCommand("setenv^MCreateViewports^M0^M") Then Er: Exit Sub
CVP = GetDefValue()
If Not Acad.acSetVar("Clayer", Arr(2, 1)) Then Er: Exit Sub

LayoutName = "BlockEditor(" & Arr(1, 1) & ")^M"
If Not Acad.acPostCommand("-layout d " & LayoutName) Then Er: Exit Sub
If Not Acad.acPostCommand("-layout n " & LayoutName) Then Er: Exit Sub
If Not Acad.acPostCommand("CTAB " & LayoutName) Then Er: Exit Sub
If Not Acad.acPostCommand("^C^C-insert^M*" & Arr(1, 1) & "^M0,0^M1^M0^M^C^C^C") Then Er: Exit Sub
If Not Acad.acGetHistory(retHist, "-insert") Then Er: Exit Sub
If InStr(retHist, "XREF") > 0 Then Acad.acPostCommand "undo e u ": Modosu: Acad.acShowMessage "外部参照は処理できません。", , "BlockEditor": Exit Sub
If Not Acad.acPostCommand("^C^Czoom e ") Then Er: Exit Sub

'ダイアログ作成
CreateDialog
Acad.dlSetProperty "Label3", "Text", "[ " & Arr(1, 1) & " ]"
Acad.acActivate
'イベント監視ループ
Do
'イベント発生待ち(変化があるまでここで待ちます)
Acad.dlWaitEvent CtrlName, CtrlValue, CtrlListIndex

'イベント処理
Select Case DialogEvent(CtrlName, CtrlValue, CtrlListIndex)
Case vbOK: Exit Do
Case vbCancel: Acad.acPostCommand "undo e u ": Modosu: Exit Sub
End Select
Loop While True

'ダイアログアンロード
Acad.dlUnload

'ここで作図
If Not Acad.acPostCommand("^C^C-BLOCK " & Arr(1, 1) & "^MY non 0,0 ALL ") Then Er: Exit Sub
Modosu
' Acad.acShowMessage "作図が完了しました。"

'終了
End Sub
Sub Modosu()
If Not Acad.acPostCommand("-layout d " & LayoutName) Then Er: Exit Sub
If Not Acad.acSetVar("Clayer", Clayer) Then Er: Exit Sub
If Not Acad.acSetVar("Ctab", Ctab) Then Er: Exit Sub
If Not Acad.acPostCommand("setenv ShowPrintBorder^M" & SPB & " ") Then Er: Exit Sub
If Not Acad.acPostCommand("setenv ShowPlotSetup^M" & SPS & " ") Then Er: Exit Sub
If Not Acad.acPostCommand("setenv ShowPaperMargins^M" & SPM & " ") Then Er: Exit Sub
If Not Acad.acPostCommand("setenv CreateViewports^M" & CVP & " ") Then Er: Exit Sub
If Not Acad.acPostCommand("undo e ") Then Er: Exit Sub
End Sub
'エラー処理
Sub Er()
'ユーザーによるキャンセル
If Acad.ErrNumber = vbObjectError + 1000 Then
'ここにキャンセル時の処理を追加
Else
'エラー内容表示
Acad.ShowError
End If
End Sub
Function GetDefValue()
If Not Acad.acGetHistory(retHist, "値") Then Er: Exit Function
mae = InStr(retHist, "<")
ato = InStr(retHist, ">")
GetDefValue = Mid(retHist, mae + 1, ato - mae - 1)

End Function

'ダイアログイベント処理
Function DialogEvent(CtrlName, CtrlValue, CtrlListIndex)
'コントロール名で区別
Select Case CtrlName
Case "cmdOK": DialogEvent = vbOK: Exit Function
Case "cmdCancel": DialogEvent = vbCancel: Exit Function
Case "Button1": DialogEvent = vbOK: Exit Function
End Select

'再度イベント待ち
DialogEvent = vbRetry
End Function

'ダイアログ作成
Sub CreateDialog()
Acad.dlLoad "ブロックエディタ もどき", False, True
Acad.dlAddLabel "Label1", "編集後に↓ボタンを押す", 20, 1, 0
Acad.dlAddButton "Button1", "ブロック更新", 16, 1
Acad.dlAddLabel "Label2", "編集中のブロック名", 18, 1, 0
Acad.dlAddLabel "Label3", "", 20, 0, 0
Acad.dlShow 0, 0
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 & " " & _
WScript.ScriptFullName
objWshShell.Exec(ExecCmd)
MustRun = True
Else 'x86
MustRun = False
End If

Set objWshShell = Nothing
Set ExecCmd = Nothing

End Function

AutoCAD2023でacadremoconの利用は無理だと思いますので、コードを書き換えることでは動くようにはならないと思います。

標準のブロックエディタでは問題があるのでしょうか？
（標準ブロックエディタ内では特定のコマンドが無効になったり、誤作動するから？）

ありがとうございます
複数のブロックが入り混じって作成してあるブロックを　修正編集することが有るのですけど。

　Aブロックの中に Bブロック,Cブロックと有り Bブロックの中にDブロックが有るとした場合
　Dブロックを修正編集したい場合　標準のブロックエディタでは　どのような手順で修正するのでしょうか。

方法1　Aブロックを右クリックしてブロックエディタ→ブロックエディタ内でBブロックを右クリックしてブロックエディタ→ブロックエディタ内でDブロックを右クリックしてブロックエディダ

方法2　Dブロックの名称か形状が分かっている前提で、Aブロックをダブルクリック→ブロック定義を編集ダイアログの左のブロック名からDブロックを選択、あるいは名前を選択して右のプレビューでDブロックを確認して、OKでブロックエディタへ

方法3　表示タブ→パレットパネル→デザインセンター（右に2列ある3個並んだアイコンの左下）を開く→左カラムのブロックを選択して、右側の一覧から該当ブロックを右クリック→ブロックエディタ

LISPで同様の機能を作ってみました。
VBScriptのように編集が終わるまで待機は出来ないので、
編集開始コマンド（BES）と再定義コマンド（BEE）の二つに分けてます。

AUTOCADでは動作確認できませんので、エラーが出ても当方では対処困難です。

;;; 1. 編集開始コマンド: BES (Block Edit Start)
(defun c:BES (/ ent ename bname layname illegal_chars i c err_flag)
(setvar "CMDECHO" 0)
(setq ent (entsel "\n編集するブロックを選択: "))
(cond
((null ent) (princ "\n選択されませんでした。"))
((/= (cdr (assoc 0 (entget (setq ename (car ent))))) "INSERT")
(princ "\nエラー: ブロックではありません。"))
((assoc 66 (entget ename))
(alert "属性付ブロックには対応していません。"))
(t
(setq bname (cdr (assoc 2 (entget ename))))
(setq illegal_chars "<>/\\:;?*|=")
(setq i 1 err_flag nil)
(while (<= i (strlen bname))
(setq c (substr bname i 1))
(if (vl-string-search c illegal_chars) (setq err_flag t))
(setq i (1+ i))
)
(if err_flag
(alert (strcat "ブロック名 [" bname "] に使用禁止文字が含まれています。"))
(progn
(setq layname (strcat "BEdit_" bname))
(if (member (strcase layname) (mapcar 'strcase (layoutlist)))
(alert (strcat "既に [" layname "] は展開されています。"))
(progn
(command "-LAYOUT" "New" layname)
(setvar "CTAB" layname)
(princ (strcat "\nブロック [" bname "] を展開しました。"))
(command "-INSERT" (strcat "*" bname) "0,0" "1" "0")
(command "ZOOM" "E")
(princ "\n完了したらコマンド [ BEE ] を実行。")
)
)
)
)
)
)
(setvar "CMDECHO" 1) (princ)
)

;;; 2. 編集終了コマンド: BEE (Block Edit End)
(defun c:BEE (/ cur_lay bname ss ans proceed target_tab)
(setvar "CMDECHO" 0)
(setq cur_lay (getvar "CTAB"))
(if (wcmatch (strcase cur_lay) "BEDIT_*")
(progn
(setq bname (substr cur_lay 7))
(initget "Yes No Cancel")
(setq ans (getkword (strcat "\n[" bname "] 保存しますか？ [はい(Yes)/いいえ(No)/キャンセル(Cancel)] <Yes>: ")))
(if (null ans) (setq ans "Yes"))
(cond
((= ans "Yes")
(if (setq ss (ssget "X" (list (cons 410 cur_lay))))
(progn
(command "-BLOCK" bname "Y" "0,0" ss "")
(princ (strcat "\nブロック [" bname "] を更新しました。"))
(setq proceed t)
)
(progn (princ "\n図面が空のため更新不可。") (setq proceed nil))
)
)
((= ans "No") (princ "\n破棄します。") (setq proceed t))
(t (setq proceed nil))
)
(if proceed
(progn
;; 戻り先判定を実行してから削除
(setq target_tab (Get_Latest_BEdit_Tab cur_lay))
(setvar "CTAB" target_tab)
(command "-LAYOUT" "Delete" cur_lay)
(command "REGENALL")
(princ (strcat "\n[" target_tab "] へ戻りました。"))
)
)
)
(princ "\nエラー: 編集用レイアウトにいません。")
)
(setvar "CMDECHO" 1) (princ)
)

;;; 3. 戻り先判定サブ関数 (BEdit優先)
(defun Get_Latest_BEdit_Tab (del_lay / lay_dict item lay_name tab_order max_order best_tab)
(setq max_order -1)
(setq best_tab "Model") ;; デフォルトはモデル

;; レイアウト辞書をスキャン
(setq lay_dict (dictsearch (namedobjdict) "ACAD_LAYOUT"))

(foreach item lay_dict
(if (= (car item) 3) ;; レイアウト名
(progn
(setq lay_name (cdr item))
;; 条件：1.今消すタブでない 2.BEdit_で始まる
(if (and (/= (strcase lay_name) (strcase del_lay))
(wcmatch (strcase lay_name) "BEDIT_*"))
(progn
;; TABORDER(71番)を取得
(setq tab_order (cdr (assoc 71 (entget (cdr (assoc -1 (dictsearch (cdr (assoc -1 lay_dict)) lay_name)))))))
;; より大きい（右側にある）BEditを探す
(if (> tab_order max_order)
(setq max_order tab_order
best_tab lay_name)
)
)
)
)
)
)
best_tab
)

LUNE様
アドバイズありがとうございます
R番の使用が浅いものですから　助かります。

Hamu様
長文のアドバイズ ありがとうございます
LISPの方無知ですので　確認しましてまた連絡いたします。