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 *----*----*    *----*----*    *----*----*    *----*----*

inserted by FC2 system