Sub MyMacroLancher() Rem *----*----* *----*----* *----*----* *----*----* Rem マクロ起動用ポップアップメニュー表示処理 Rem 作譜:Hitrock Camellia Shinopy Rem 言語:Word VBA Rem 機能... Rem 1. マクロを起動するためのポップアップメニューを表示する。 Rem 注記... Rem 1.「MyMacroLancher」を起動して、処理を実行する。 Rem 2.「MyMacroLancherMyMacro」内に「マクロ名: マクロ処理名」を記述しておくこと。 Rem (この処理で指定されているマクロ名・マクロ処理名は一例。) Rem 3.「myIconFolder」にアイコン用の画像データのフォルダを指定しておくこと。 Rem 履歴... Rem 第01版:2008/07/27:作成。 Rem 第02版:2011/04/02:画像データのフォルダを指定をマイドキュメント内にする。 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String Dim myMacro As String Rem *----*----* *----*----* *----*----* *----*----* ' myTitle = "MyMacroLancher" myMacro = "" ' On Error Resume Next CommandBars(myTitle).Delete On Error GoTo 0 ' Call MyMacroLancherMyMacro(myMacro) Call MyMacroLancherShow(myTitle, myMacro) ' On Error Resume Next CommandBars(myTitle).Delete On Error GoTo 0 End Sub ' MyMacroLancher *----*----* *----*----* *----*----* *----*----* Sub MyMacroLancherShow(myTitle As String, myMacro As String) Rem *----*----* *----*----* *----*----* *----*----* Rem ポップアップメニュー表示処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myCmmdBar As CommandBar Dim myCtrlBttnIcon As CommandBarControl Dim myCtrlBttnCancel As CommandBarControl Dim myShell As Variant ' IWshShell3 Dim myArray As Variant Dim myItem As Variant Dim i As Long Dim x As Long Dim y As Long Dim myMacroName As String Dim myMacroLocal As String Dim myBeginGroup As Boolean Dim myFolder As String Dim myIconFolder As String Dim myIconFile As String Dim myPicBttn As IPictureDisp Dim myFaceId As Long Dim myMsg As String Rem *----*----* *----*----* *----*----* *----*----* ' Set myShell = CreateObject("WScript.Shell") myFolder = myShell.Specialfolders("MyDocuments") ' マイドキュメント myIconFolder = myFolder & "\000MyVBA\Icon" ' アイコン用の画像データのフォルダ myArray = Split(myMacro, ",") ' Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttnIcon = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) ' myMsg = myTitle & vbCrLf myMsg = myMsg & "マクロ起動用ポップアップメニュー表示処理" & vbCrLf & vbCrLf Rem *----*----* *----*----* *----*----* *----*----* ' With myCtrlBttnIcon .DescriptionText = "マクロ起動用ポップアップメニュー表示処理ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myMsg & "処理を実行しますか?" .TooltipText = "処理を実行しますか?" .FaceId = 1089 myFaceId = .FaceId .OnAction = "MyMacroLancherBttnMyIcon" End With ' With myCtrlBttnCancel .BeginGroup = True .DescriptionText = "[キャンセル]ボタン" .Style = msoButtonIconAndCaption .Caption = "キャンセル" & String(13, " ") .TooltipText = "処理を中止します。" .FaceId = 330 .OnAction = "MyMacroLancherBttnMyCancel" End With ' i = 2 myBeginGroup = False For Each myItem In myArray myMacroName = Left(myItem, InStr(myItem, ": ") - 1) myMacroLocal = Mid(myItem, InStr(myItem, ": ") + 1) ' If myMacroName = "----" Then myBeginGroup = True Else i = i + 1 myCmmdBar.Controls.Add Type:=msoControlButton, Before:=i, Temporary:=True With myCmmdBar.Controls(i) .DescriptionText = "マクロ起動用ボタン" .BeginGroup = myBeginGroup .Style = msoButtonIconAndCaption .Caption = myMacroLocal .TooltipText = myMacroLocal .OnAction = myMacroName ' On Error Resume Next myIconFile = myIconFolder & "\" & myMacroName & ".gif" Set myPicBttn = stdole.StdFunctions.LoadPicture(myIconFile) If Err.Number = 0 Then myCmmdBar.Controls(i).Picture = myPicBttn End If On Error GoTo 0 End With ' myBeginGroup = False End If Next ' myItem Rem *----*----* *----*----* *----*----* *----*----* ' x = -1: y = -1 myFaceId = myCmmdBar.Controls(1).FaceId Beep ' Do On Error Resume Next If x = -1 Then myCmmdBar.ShowPopup Else myCmmdBar.ShowPopup x, y End If On Error GoTo 0 DoEvents Select Case myCmmdBar.Controls(1).FaceId Case 459, 330 ' 実行/キャンセル Exit Do ' Case 220, 6963 ' [チェックボックス]オン・オフ ' x = myCmmdBar.Left ' y = myCmmdBar.Top ' myCmmdBar.Controls(1).FaceId = myFaceId Case 1089 ' [処理を実行しますか?] Exit Do Case Else x = -1: y = -1 End Select Loop ' myCmmdBar.Controls(1).FaceId = myFaceId Set myShell = Nothing End Sub ' MyMacroLancherShow *----*----* *----*----* *----*----* *----*----* Sub MyMacroLancherBttnMyIcon(Optional MyDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [処理を実行しますか?]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars("MyMacroLancher").Controls(1).FaceId = 1089 End Sub ' MyMacroLancherBttnMyIcon *----*----* *----*----* *----*----* *----*----* Sub MyMacroLancherBttnMyCancel(Optional MyDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem コマンドボタン[キャンセル]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars("MyMacroLancher").Controls(1).FaceId = 330 End Sub ' MyMacroLancherBttnMyCancel *----*----* *----*----* *----*----* *----*----* Sub MyMacroLancherBttnMyDetail(Optional MyDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem For Future Use [チェックボックス]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* ' With CommandBars("MyMacroLancher").Controls(999) If .FaceId = 6963 Then .FaceId = 220 .TooltipText = "詳細RSSも取り込む。" Else .FaceId = 6963 .TooltipText = "詳細RSSは取り込まない。" End If End With CommandBars("MyMacroLancher").Controls(1).FaceId = CommandBars("MyMacroLancher").Controls(999).FaceId End Sub ' MyMacroLancherBttnMyDetail *----*----* *----*----* *----*----* *----*----* Sub MyMacroLancherMyMacro(myMacro As String) Rem *----*----* *----*----* *----*----* *----*----* Rem 「マクロ名: マクロ処理名」の設定処理 Rem 半角「:」と半角空白1文字で区切って記述すること。 Rem *----*----* *----*----* *----*----* *----*----* ' myMacro = "----: BeginGroup" myMacro = myMacro & "," & "MyUndoClear: [元に戻す]ボックス操作一覧クリア処理" myMacro = myMacro & "," & "----: BeginGroup" myMacro = myMacro & "," & "MyToolBar: マイツールバー処理" myMacro = myMacro & "," & "----: BeginGroup" myMacro = myMacro & "," & "Espizo: エスペラント語 代用文字 範囲内置換処理" myMacro = myMacro & "," & "EspRevizo: エスペラント語辞書参照処理(即席スペルチェッカー)" myMacro = myMacro & "," & "EspVortizo: エスペラント語 代用文字 範囲内 置換処理/PEJVO 辞書ファイル 照会処理" myMacro = myMacro & "," & "EspPilgerizo: エスペラント語 基本語根集 辞書ファイル 照会処理" myMacro = myMacro & "," & "----: BeginGroup" myMacro = myMacro & "," & "MyFileCbox: 同一フォルダ内文書ファイル選択処理([開く]/[閉じる]随時切り替え)" myMacro = myMacro & "," & "MyPhoneticGuide: 漢字ルビ逐次入力処理" myMacro = myMacro & "," & "----: BeginGroup" myMacro = myMacro & "," & "MyAdoZip: 郵便番号データファイル問い合わせ処理" myMacro = myMacro & "," & "MyCsvLbox: 選択文字列挿入処理" End Sub ' MyMacroLancherMyMacro *----*----* *----*----* *----*----* *----*----*