スパイのメッセージ & ＭｓｇＢｏｘをスパイのメッセージに変換！　自動化必須メッセージ無料公開！　　　史上最強ＶＢＡユーティリティ！　ＣｈａｎｔＶＢＴ：ＥＸＣＥＬ　ＭＡＣＲＯ　ＭＡＮＡＧＥＲ　自動化必須アイテム

スパイメッセージは、スパイが使うような自動消滅するメッセージ機能です。MsgBoxをスパイメッセージ（MsgInf）に変換するツールも公開です。

スパイメッセージは、自動化に必須のメッセージ機能です。
ここで使用するツールは、ChantVBT:EXCEL MACRO MANAGERというマクロ管理ツール内のユーティリティーです。ChantVBTは、ＡＩ時代の必須アイテムとして、ＶＢＡを使う人に、とても便利なユーティリティーです。

スパイメッセージは、MsgInfを使用します。
下記のようにMsgBoxをMsgInfにして、時間を秒で指定です。
MsgInf 5, "Test Message 1"
コードの最後にSub TestAfterとSub TestBeforedeを配置しています。
MsgBoxからMsgInfへの変換前後となっています。
Sub TestAfterを実行すると、違いがわかります。

ＭｓｇＢｏｘ変換は、ConvMsgBoxを実行です。
使用方法は、YouTubeを見てください。
（動画作成時MsgInfoでしたがMsgInfに変更しました）
https://youtu.be/5I37Lvy7DFo

下記のコードをコピーして、ＶＢＥを開いてください。(Alt＋F11)
標準モジュールのモジュールの先頭に配置して使用してください。

Option Explicit
'デフォルトボタンの設定
'vbDefaultButton1 最初のボタンをデフォルトにする(デフォルト)
'vbDefaultButton2 2 番目のボタンをデフォルトにする
'vbDefaultButton3 3 番目のボタンをデフォルトにする
' Display a timed message box with custom options
'options : combination OK => vbYesNo + vbQuestion
'options
'ボタンの種類
'vbOKOnly [OK] ボタンのみ表示（デフォルト）
'vbOKCancel [OK] と [キャンセル] ボタンを表示
'vbAbortRetryIgnore [中止]、[再試行]、[無視] ボタンを表示
'vbYesNoCancel [はい]、[いいえ]、[キャンセル] ボタンを表示
'vbYesNo [はい] と [いいえ] ボタンを表示
'vbRetryCancel [再試行] と [キャンセル] ボタンを表示
'アイコンの種類
'vbInformation 情報メッセージのアイコンを表示
'vbCritical エラーメッセージのアイコンを表示
'vbQuestion 質問のアイコンを表示
'vbExclamation 警告のアイコンを表示
'vbDefaultButton4 4 番目のボタンをデフォルトにする
'モーダルの種類
'vbApplicationModal アプリケーション モーダル（デフォルト）
'vbSystemModal システム モーダル
' Windows Api Command
#If Win64 Then
' Excel Bit64
Public Declare PtrSafe Function _
MessageBoxTimeoutA Lib "User32.dll" _
(ByVal hwnd As LongPtr, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long
#Else
' Excel Bit32
Public Declare PtrSafe Function _
MessageBoxTimeoutA Lib "User32.dll" _
(ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long
#End If
Public MsgText As String
Function MsgInf(ByVal WaitTime As Double, ByVal Prompt As String, _
Optional ByVal Buttons As VbMsgBoxStyle = vbInformation, _
Optional ByVal Title As String = "") As VbMsgBoxResult
Dim Milliseconds As Long
Dim CustomCaption As String
' If no timeout is specified, use 0
If WaitTime <= 0 Then
WaitTime = 0
End If
' Convert seconds to milliseconds
Milliseconds = CLng(WaitTime * 1000)
' Set the custom title if not provided
If Title = "" Then
If WaitTime = 0 Then
CustomCaption = "Wait time is zero, so this message won't disappear."
Else
CustomCaption = "This message will self-destruct in " & WaitTime & " seconds"
End If
Else
CustomCaption = Title
End If
' Display a message box with a timeout
MsgInf = MessageBoxTimeoutA(0, Prompt, CustomCaption, Buttons, 0, Milliseconds)
End Function
Function MsgErr(ByVal WaitTime As Double, ByVal Prompt As String, _
Optional ByVal Buttons As VbMsgBoxStyle = vbExclamation, _
Optional ByVal Title As String = "") As VbMsgBoxResult
Dim Milliseconds As Long
Dim CustomCaption As String
' If no timeout is specified, use 0
If WaitTime <= 0 Then
WaitTime = 0
End If
' Convert seconds to milliseconds
Milliseconds = CLng(WaitTime * 1000)
' Set the custom title if not provided
If Title = "" Then
If WaitTime = 0 Then
CustomCaption = "Wait time is zero, so this message won't disappear."
Else
CustomCaption = "This message will self-destruct in " & WaitTime & " seconds"
End If
Else
CustomCaption = Title
End If
' Display a message box with a timeout
MsgErr = MessageBoxTimeoutA(0, Prompt, CustomCaption, Buttons, 0, Milliseconds)
End Function
Sub Sample_MsgInf()
Dim a As Long: a = 7
Sample1:
MsgText = "Sample_MsgInf." & vbCrLf _
& vbCrLf & "James Bond code name : " & Format(a, "#,000")
Call MsgInf(5, MsgText)
Sample2:
MsgText = "Processing completed."
Call MsgInf(3, MsgText)
Sample3:
Call MsgInf(0.5, "The process is proceeding correctly.")
Sample4:
MsgText = "Sample_MsgErr." & vbCrLf _
& vbCrLf & "James Bond code name : " & Format(a, "#,000")
Call MsgErr(5, MsgText)
Sample5:
MsgText = "An error has occurred !"
Call MsgErr(3, MsgText)
Sample6:
Call MsgErr(0.5, "Continuing with minor warning !")
End Sub
Sub ConvMsgBox()
' MsgBox関数をMsgInf関数に置換
' コメント内に ChangeNG がある場合、置換しない
' 置き換え対象キーワードは下記文字（大文字小文字を区別しない）
' "CALL MSGBOX(","MSGBOX ","MSGBOX("　　　　　　　　　　　　　　ChangeNG
' 行内に下記文字ありの場合、置き換え対象外
' "ChangeNG","= MsgBox(","If MsgBox(","UCase(Left(TrimmedCodePart","UCase(Left(MsgBoxCode")
Dim VBComp As Object
Dim CodeModule As Object
Dim StartLine As Long, EndLine As Long
Dim LineNum As Long
Dim CntBlank As Long
Dim CntArglist As Long
Dim CodeLine As String
Dim UpdatedCode As String
Dim MsgContent As String
Dim MsgType As String
Dim ReplaceText As String
Dim UserResponse As VbMsgBoxResult
Dim CodePart As String
Dim CodeCall As String
Dim CommentPart As String
Dim TrimmedCodePart As String
Dim Indent As String
On Error GoTo ErrorHandler
' すべての標準モジュールを処理
For Each VBComp In ThisWorkbook.VBProject.VBComponents
If VBComp.Type = vbext_ct_StdModule Then
Set CodeModule = VBComp.CodeModule
With CodeModule
StartLine = 1
EndLine = .CountOfLines
UpdatedCode = ""
For LineNum = StartLine To EndLine
CodeLine = .lines(LineNum, 1)
' コード部分とコメント部分を分離
Dim CommentPos As Long
CommentPos = InStr(CodeLine, "'")
If CommentPos > 0 Then
CodePart = Left(CodeLine, CommentPos - 1)
CommentPart = Mid(CodeLine, CommentPos)
Else
CodePart = CodeLine
CommentPart = ""
End If
' コード部分をトリムしてインデントを保持
TrimmedCodePart = LTrim(CodePart)
Indent = Left(CodePart, Len(CodePart) - Len(TrimmedCodePart))
' キーワードを確認（大文字小文字を区別しない）
If UCase(Left(TrimmedCodePart, 12)) = "CALL MSGBOX(" Or _
UCase(Left(TrimmedCodePart, 7)) = "MSGBOX " Or _
UCase(Left(TrimmedCodePart, 7)) = "MSGBOX(" Then
' コメント内に 'ChangeNG' が含まれている場合は置換しない
' このプロシージャと一般に置き換え不要なものを置換しない
If InStr(1, CommentPart, "ChangeNG", vbTextCompare) > 0 Or _
InStr(1, CodePart, "= MsgBox(", vbTextCompare) > 0 Or _
InStr(1, CodePart, "If MsgBox(", vbTextCompare) > 0 Or _
InStr(1, CodePart, "UCase(Left(MsgBoxCode", vbTextCompare) > 0 Or _
InStr(1, CodePart, "UCase(Left(TrimmedCodePart", vbTextCompare) > 0 Then
UpdatedCode = UpdatedCode & CodeLine & vbCrLf
Else
CodeCall = ""
If UCase(Left(TrimmedCodePart, 4)) = "CALL" Then
CodeCall = "CALL "
If Right(TrimmedCodePart, 1) = ")" Then
TrimmedCodePart = Mid(TrimmedCodePart, 1, Len(TrimmedCodePart) - 1)
End If
End If
' MsgBox行を解析
Call ParseMsgBox(TrimmedCodePart, MsgContent, MsgType, CntArglist)
' MsgContent が空の場合は次の行へ
If MsgContent = "" Then
UpdatedCode = UpdatedCode & CodeLine & vbCrLf
GoTo NextLine
End If
UserResponse = MsgBox("MsgBox置き換え確認" _
& vbCrLf & vbCrLf & "以下のMsgBoxを置き換えますか？" _
& vbCrLf & "はい、いいえ、キャンセルを選択してください" _
& vbCrLf & vbCrLf & TrimmedCodePart & vbCrLf & vbCrLf & _
"　　　　　　　　　", vbYesNoCancel + vbQuestion)
Select Case UserResponse
Case vbYes
' 引数に応じて置換テキストを作成
If CodeCall = "" Then
If MsgType = "" Then
CntBlank = CommentPos - Len(Indent & CodeCall & "MsgInf 5, " & MsgContent)
CntBlank = IIf(CntBlank > 0, CntBlank + 2 + CntArglist, 0)
ReplaceText = Indent & CodeCall & "MsgInf 5, " & MsgContent & Space(CntBlank) & CommentPart
Else
CntBlank = CommentPos - Len(Indent & CodeCall & "MsgInf 5, " & MsgContent & ", " & MsgType)
CntBlank = IIf(CntBlank > 0, CntBlank + 1 + CntArglist, 0)
ReplaceText = Indent & CodeCall & "MsgInf 5, " & MsgContent & ", " & MsgType & Space(CntBlank) & CommentPart
End If
Else
If MsgType = "" Then
CntBlank = CommentPos - Len(Indent & CodeCall & "MsgInf(5, " & MsgContent & ")")
CntBlank = IIf(CntBlank > 0, CntBlank + 2 + CntArglist, 0)
ReplaceText = Indent & CodeCall & "MsgInf(5, " & MsgContent & ")" & Space(CntBlank) & CommentPart
Else
CntBlank = CommentPos - Len(Indent & CodeCall & "MsgInf(5, " & MsgContent & ", " & MsgType)
CntBlank = IIf(CntBlank > 0, CntBlank + 1 + CntArglist, 0)
ReplaceText = Indent & CodeCall & "MsgInf(5, " & MsgContent & ", " & MsgType & Space(CntBlank) & CommentPart
End If
End If
' 置換後の行を追加
UpdatedCode = UpdatedCode & ReplaceText & vbCrLf
Case vbNo
' 置換せずそのまま
UpdatedCode = UpdatedCode & CodeLine & vbCrLf
Case vbCancel
Exit Sub
End Select
End If
Else
' MsgBoxを含まない行はそのまま
UpdatedCode = UpdatedCode & CodeLine & vbCrLf
End If
NextLine:
Next LineNum
' 更新したコードをモジュールに反映
.DeleteLines StartLine, EndLine
.InsertLines StartLine, UpdatedCode
End With
End If
Next VBComp
Exit Sub
ErrorHandler:
Call ErrorHandle
End Sub
Sub ParseMsgBox(ByVal MsgBoxCode As String, ByRef MsgContent As String, _
ByRef MsgType As String, ByRef CntArglist As Long)
' 構文解析
MsgBoxCode = Trim(MsgBoxCode)
If UCase(Left(MsgBoxCode, 12)) = "CALL MSGBOX(" Then
MsgBoxCode = Mid(MsgBoxCode, 13)
ElseIf UCase(Left(MsgBoxCode, 7)) = "MSGBOX " Then
MsgBoxCode = Mid(MsgBoxCode, 8)
ElseIf UCase(Left(MsgBoxCode, 7)) = "MSGBOX(" Then
MsgBoxCode = Mid(MsgBoxCode, 8)
Else
' MsgBox行でない場合
MsgContent = ""
MsgType = ""
Exit Sub
End If
' コードをトリム
MsgBoxCode = Trim(MsgBoxCode)
' 引数がない場合
If MsgBoxCode = "" Then
MsgContent = ""
MsgType = ""
Exit Sub
End If
' 引数を分割
Dim ArgList As Variant
ArgList = SplitArgs(MsgBoxCode)
CntArglist = UBound(ArgList)
If UBound(ArgList) >= 0 Then
MsgContent = ArgList(0)
If UBound(ArgList) >= 1 Then
MsgType = ArgList(1)
If UBound(ArgList) >= 2 Then
MsgType = MsgType & "," & ArgList(2) & " "
End If
Else
MsgType = ""
End If
Else
MsgContent = ""
MsgType = ""
End If
End Sub
Function SplitArgs(ByVal ArgString As String) As Variant
Dim Args As Collection
Set Args = New Collection
Dim InQuote As Boolean
Dim StartPos As Long
Dim i As Long
Dim ch As String
StartPos = 1
InQuote = False
For i = 1 To Len(ArgString)
ch = Mid(ArgString, i, 1)
' 大文字小文字を区別しないように小文字に変換(現在不要)
' ch = LCase(ch)
Select Case ch
Case """"
If InQuote Then
' 連続する二重引用符の場合はエスケープとみなす
If i < Len(ArgString) And Mid(ArgString, i + 1, 1) = """" Then
i = i + 1 ' 次の二重引用符をスキップ
Else
InQuote = False
End If
Else
InQuote = True
End If
Case ","
If Not InQuote Then
Args.Add Mid(ArgString, StartPos, i - StartPos)
StartPos = i + 1
End If
Case " "
' 空白を無視（必要に応じて）
Case Else
' 何もしない
End Select
Next i
' 最後の引数を追加
If StartPos <= Len(ArgString) Then
Args.Add Mid(ArgString, StartPos)
End If
' コレクションを配列に変換
Dim Result() As String
ReDim Result(Args.Count - 1)
For i = 1 To Args.Count
Result(i - 1) = Args(i)
Next i
SplitArgs = Result
End Function
Sub TestAfter()
' MsgBox テスト　Test Message 4,8 はコメントに ChangeNG ありで変換なし、その他を変換
MsgInf 5, "Test Message 1"
MsgInf 5, "Test Message 2", vbExclamation + vbYesNo ' ChangeOK
MsgInf 5, "Test Message 3", vbExclamation + vbYesNo, "option" ' ChangeOK
MsgBox "Test Message 4" ' ChangeNG
Call MsgInf(5, "Test Message 5")
Call MsgInf(5, "Test Message 6", vbInformation) ' ChangeOK
Call MsgInf(5, "Test Message 7", vbInformation, "option") ' ChangeOK
Call MsgBox("Test Message 8") ' ChangeNG
End Sub
Sub TestBefore()
' MsgBox テスト　Test Message 4,8 はコメントに ChangeNG ありで変換なし、その他を変換
MsgBox "Test Message 1"
MsgBox "Test Message 2", vbExclamation + vbYesNo ' ChangeOK
MsgBox "Test Message 3", vbExclamation + vbYesNo, "option" ' ChangeOK
MsgBox "Test Message 4" ' ChangeNG
Call MsgBox("Test Message 5")
Call MsgBox("Test Message 6", vbInformation) ' ChangeOK
Call MsgBox("Test Message 7", vbInformation, "option") ' ChangeOK
Call MsgBox("Test Message 8") ' ChangeNG
End Sub