[[20150802235219]]　『複数階層の右クリックメニューの一階層上のコント』（田吾作）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『複数階層の右クリックメニューの一階層上のコントロール取得』（田吾作）

 こんばんは、よろしくお願いいたします。

 いま、右クリックメニューをWEBの記述などを参考に勉強しております。

 勉強にために、複数階層の右クリックメニューを作成しています。
 下記のコードは、
 シートの右クリックメニューに「日付選択」というメニューを付加しています。
 「日付選択」選択で、右の方に今年の前後5年づつの年一覧のメニューが表示されます。
 今年ですと、2011年〜2020年がリスト表示されます。
 「年」を選択したら更に右に1月〜12月のメニューが表示されます。
 「月」を選択したら、さらに右に1日〜31日のうち、その年月に存在する日がリスト表示されます。

 現状のコードでは、年選択時に実行するコードで年を変数に格納、月選択時に実行するコード
 で月を変数に格納しています。最後に「日」選択時に実行するコードで取得する日と、先に取得し
 て置いた年、月を結合して日付データとし、その日付をアクティブセルに転記しています。

 いま考えているのが、年、月選択時に実行するコードで年、月を変数に格納するのではなく、
 「日」選択時に一覧階層上の選択されているコントロール(月)、さらにその上の階層の選択されて
 いるコントロール(年)を取得できないか、ということです。

 下記のコードでいえば、「hiduke」実行時に年、月、日を取得したい、ということです。

 方法がありましたらご教示お願いいたします。

 'ThisWorkbookモジュール

 Option Explicit

 Private Sub Workbook_Activate()
  Call ableMenu
 End Sub

 Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Call DelMenu
 End Sub

 Private Sub Workbook_Deactivate()
  Call DelMenu
 End Sub

 Private Sub Workbook_Open()
  Call AddMenu
 End Sub

 '標準モジュール

 Option Explicit

 Dim tosi As String
 Dim tuki As String
 Dim hi As String
 Dim cnt As Integer

 Sub AddMenu()
  Dim myCommandBar As CommandBar
  Dim myCommandBarControl As CommandBarControl
  Dim i As Integer
  Dim j As Integer
  Dim k As Integer
   Set myCommandBar = Application.CommandBars("Cell")
   myCommandBar.Reset
   Set myCommandBarControl = myCommandBar.Controls.Add(Before:=1, Type:=msoControlPopup)
   With myCommandBarControl
    .Caption = "日付選択"
    .OnAction = "'tosiadd'"
   End With
 End Sub

 Sub ableMenu()
  Dim mycmd As Object
  Dim flg As Boolean
  Dim Newb
   flg = False
   For Each mycmd In Application.CommandBars("Cell").Controls
    If mycmd.Caption = "日付選択" Then
       flg = True
    End If
   Next mycmd
   If flg = True Then
     Application.CommandBars("Cell").Controls("日付選択").Visible = True
   End If
 End Sub

 Sub DelMenu()
  Dim mycmd As Object
  Dim flg As Boolean
  Dim Newb
   flg = False
   For Each mycmd In Application.CommandBars("Cell").Controls
    If mycmd.Caption = "日付選択" Then
       flg = True
    End If
   Next mycmd
   If flg = True Then
     Application.CommandBars("Cell").Controls("日付選択").Visible = False
   End If
 End Sub

 'DelMenuは単に↓でもOK
 Sub DelMenu2()
  Application.CommandBars("Cell").Reset
 End Sub

 Function tosiadd()
  Dim myCommandBarControl As CommandBarControl
  Dim mycmd As Object
  Dim i As Integer
   On Error Resume Next
   For Each mycmd In Application.CommandBars.ActionControl.Controls
    mycmd.Delete
   Next
   On Error GoTo 0
   For i = 1 To 10
    With Application.CommandBars.ActionControl.Controls.Add(msoControlPopup, , , , True) 'サブメニュー
     .Caption = -5 + i + Year(Date) & "年"
     .OnAction = "'tukiadd'"
    End With
   Next i
 End Function

 Function tukiadd()
  Dim myCommandBarControl As CommandBarControl
  Dim mycmd As Object
  Dim i As Integer
   tosi = Application.CommandBars.ActionControl.Caption '★ここで「年」を変数格納
   On Error Resume Next
   For Each mycmd In Application.CommandBars.ActionControl.Controls
    mycmd.Delete
   Next
   On Error GoTo 0
   For i = 1 To 12
    With Application.CommandBars.ActionControl.Controls.Add(msoControlPopup, , , , True) 'サブメニュー
     .Caption = i & "月"
     .OnAction = "'hiadd'"
    End With
   Next i
 End Function

 Function hiadd()
  Dim myCommandBarControl As CommandBarControl
  Dim mycmd As Object
  Dim matu As Integer
  Dim i As Integer
   On Error Resume Next
   For Each mycmd In Application.CommandBars.ActionControl.Controls
    mycmd.Delete
   Next
   On Error GoTo 0
   tuki = Application.CommandBars.ActionControl.Caption '★ここで「月」を変数格納
   matu = Day(DateAdd("d", -1, DateAdd("m", 1, DateValue(tosi & tuki & "1日"))))
   For i = 1 To matu
    With Application.CommandBars.ActionControl.Controls.Add(msoControlButton, , , , True)  'サブメニュー
     .Caption = i & "日"
     .OnAction = "'hiduke'"
    End With
   Next i
 End Function

 Sub hiduke()
  Dim hi As String
   hi = Application.CommandBars.ActionControl.Caption
   ActiveCell.Value = DateValue(tosi & tuki & hi)
 End Sub

＜ 使用 Excel：Excel2007、使用 OS：WindowsVista ＞

---

　Parentというプロパティがありますから、これを何度か続けて取得すればできそうですよ！！

 例
  MsgBox Application.CommandBars.ActionControl.Parent.Parent.Caption

（ichinose） 2015/08/03(月) 08:13

---

 すでにichinoseさんから、そのものズバリの回答が出ていますので蛇足ですが。

 現在の３層の構成は以下のようになっているようです。

 CommandBarPouUp (Captionあり　2015年　等)
 　　↓
 　　CommandBar
 　　　　↓
 　　　　CommandBarPopUp (Captionあり 6月等)
 　　　　　　↓
 　　　　　　CommandBar
　               ↓
 　　　　　　　　CommandBarButton(現在のActionControl。Captionあり 15日等)

 逆にいえば↑方向が Parent ですから

 現在のActionControl.Parent.Parent のCaption が１階層上のキャプション。
 現在のActionControl.Parent.Parent.Parent.Parent のCaption が２階層上のキャプション。

 ということになりますね。

（β） 2015/08/03(月) 09:26

---

 ichinoseさん、ご回答ありがとうございます。

 ↓のようにしてみたらエラーになりました。

  MsgBox Application.CommandBars.ActionControl.Parent.Caption

 そこで、ネットで調べてみたら、一階層下が
 Parent.Parent

 二階層下が
 Parent.Parent.Parent.Parent

 だと解りました。
 ichinoseさんご呈示のコードはてっきり二階層上を取得するものだと早合点してしまいましたが、
 Parent二つで一階層ということだったんですね。

 ichinoseさんのコードご呈示を受けて調べてヒットしたのは↓でした。

 実行されたメニューを取得する-親オブジェクトの調べ方
http://officetanaka.net/excel/vba/tips/tips07.htm

 右クリックメニューの登録位置の把握
http://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=169788&rev=0

 解決しました。ありがとうございました。

 ゆっくり書いていたらβさんから同様のご回答いただきました。ありがとうございました。
（田吾作） 2015/08/03(月) 09:51

---

 βさん、ありがとうございます。

 >MsgBox Application.CommandBars.ActionControl.Parent.Caption

 Parentは存在するが、オブジェクトにCaptionが無いのでエラーになるのですね。
 勉強になりました。ありがとうございました。
（田吾作） 2015/08/03(月) 09:58

---

 他サイトでこのスレッドが話題に上がってましたので、私が
 右クリックメニューの操作について参考にさせていただいた
 HPをリンクさせていただきます。

http://d.hatena.ne.jp/so_blue/20101116/1289918205

 また、私のコードは、追加したコントロールが沢山残ってしまって
 ましたので修正が必要でした。

 ブック終了時も追加したコントロールを非表示にするだけで後始末が
 不十分でしたので修正が必要でした。

 修正に取り掛かって、完成したら再度アップさせていただきます。
（田吾作） 2015/08/04(火) 23:36

---

 修正版です。
 メニュー削除はコントロールを名前で指定しているのでStep -1にする必要はないですが、インデックス
 で削除していた時のままにしてあります。

 'ThisWorkbookモジュール

 Option Explicit

 Private Sub Workbook_Activate()
  Call visibleMenu
 End Sub

 Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Call DelMenu
 End Sub

 Private Sub Workbook_Deactivate()
  Call imvisibleMenu
 End Sub

 Private Sub Workbook_Open()
  Call AddMenu
 End Sub

 '標準モジュール

 Option Explicit

 Dim tosi As String
 Dim tuki As String
 Dim hi As String
 Dim tagary() As Variant
 Dim cnt As Long
 Dim oyacmd As CommandBarControl

 Sub AddMenu()
  Dim myCommandBar As CommandBar
  Dim myCommandBarControl As CommandBarControl
  Dim i As Integer
  Dim j As Integer
  Dim k As Integer
   Set myCommandBar = Application.CommandBars("Cell")
   myCommandBar.Reset
   Set myCommandBarControl = myCommandBar.Controls.Add(Before:=1, Type:=msoControlPopup)
   Set oyacmd = myCommandBarControl
   With myCommandBarControl
    .Caption = "日付選択"
    .OnAction = "'tosiadd'"
   End With
 End Sub

 'メニュー表示
 Sub visibleMenu()
  Dim mycmd As Object
  Dim flg As Boolean
  Dim Newb
   flg = False
   For Each mycmd In Application.CommandBars("Cell").Controls
    If mycmd.Caption = "日付選択" Then
       flg = True
    End If
   Next mycmd
   If flg = True Then
     Application.CommandBars("Cell").Controls("日付選択").Visible = True
   End If
 End Sub

 'メニュー非表示
 Sub imvisibleMenu()
  Dim mycmd As Object
  Dim flg As Boolean
  Dim Newb
   flg = False
   For Each mycmd In Application.CommandBars("Cell").Controls
    If mycmd.Caption = "日付選択" Then
       flg = True
    End If
   Next mycmd
   If flg = True Then
     Application.CommandBars("Cell").Controls("日付選択").Visible = False
   End If
 End Sub

 'メニュー削除
 Sub DelMenu()
  Dim i As Integer
   On Error Resume Next
   For i = 31 To 1 Step -1
    Application.CommandBars("Cell").Controls("日付選択").Controls(tosi).Controls(tuki).Controls(i & "日").Delete
   Next
   On Error GoTo 0
   On Error Resume Next
   For i = 12 To 1 Step -1
    Application.CommandBars("Cell").Controls("日付選択").Controls(tosi).Controls(i & "月").Delete
   Next
   On Error GoTo 0
   On Error Resume Next
   For i = 10 To 1 Step -1
    Application.CommandBars("Cell").Controls("日付選択").Controls(-5 + i + Year(Date) & "年").Delete
   Next
   On Error GoTo 0
   Application.CommandBars("Cell").Controls("日付選択").Delete
 End Sub

 'DelMenuは単に↓でもOK
 Sub DelMenu2()
  Application.CommandBars("Cell").Reset
 End Sub

 Function tosiadd()
  Dim myCommandBarControl As CommandBarControl
  Dim i As Integer
   '日コントロール削除
   For i = 31 To 1 Step -1
    On Error Resume Next
    Application.CommandBars("Cell").Controls("日付選択").Controls(tosi).Controls(tuki).Controls(i & "日").Delete
    On Error GoTo 0
   Next
   '月コントロール削除
   For i = 12 To 1 Step -1
    On Error Resume Next
    Application.CommandBars("Cell").Controls("日付選択").Controls(tosi).Controls(i & "月").Delete
    On Error GoTo 0
   Next
   '年コントロール削除
   For i = 10 To 1 Step -1
    On Error Resume Next
    Application.CommandBars("Cell").Controls("日付選択").Controls(-5 + i + Year(Date) & "年").Delete
    On Error GoTo 0
   Next
   '年コントロール追加
   For i = 1 To 10
    With Application.CommandBars.ActionControl.Controls.Add(msoControlPopup, , , , True) 'サブメニュー
     .Caption = -5 + i + Year(Date) & "年"
     .OnAction = "'tukiadd'"
     .Tag = "mytag"
    End With
   Next i
 End Function

 Function tukiadd()
  Dim myCommandBarControl As CommandBarControl
  Dim i As Integer
   '日コントロール削除
   For i = 31 To 1 Step -1
    On Error Resume Next
    Application.CommandBars("Cell").Controls("日付選択").Controls(tosi).Controls(tuki).Controls(i & "日").Delete
    On Error GoTo 0
   Next
   '月コントロール削除
   For i = 12 To 1 Step -1
    On Error Resume Next
    Application.CommandBars("Cell").Controls("日付選択").Controls(tosi).Controls(i & "月").Delete
    On Error GoTo 0
   Next
   tosi = Application.CommandBars.ActionControl.Caption
   '月コントロール追加
   For i = 1 To 12
    With Application.CommandBars.ActionControl.Controls.Add(msoControlPopup, , , , True) 'サブメニュー
     .Caption = i & "月"
     .OnAction = "'hiadd'"
     .Tag = "mytag"
    End With
   Next i
 End Function

 Function hiadd()
  Dim myCommandBarControl As CommandBarControl
  Dim matu As Integer
  Dim i As Integer
   '日コントロール削除
   For i = 31 To 1 Step -1
    On Error Resume Next
    Application.CommandBars("Cell").Controls("日付選択").Controls(tosi).Controls(tuki).Controls(i & "日").Delete
    On Error GoTo 0
   Next
   tosi = Application.CommandBars.ActionControl.Parent.Parent.Caption
   tuki = Application.CommandBars.ActionControl.Caption
   matu = Day(DateAdd("d", -1, DateAdd("m", 1, DateValue(tosi & tuki & "1日"))))
   '日コントロール追加
   For i = 1 To matu
    With Application.CommandBars.ActionControl.Controls.Add(msoControlButton, , , , True)  'サブメニュー
     .Caption = i & "日"
     .OnAction = "'hiduke'"
     .Tag = "mytag"
    End With
   Next i
 End Function

 Sub hiduke()
   tosi = Application.CommandBars.ActionControl.Parent.Parent.Parent.Parent.Caption
   tuki = Application.CommandBars.ActionControl.Parent.Parent.Caption
   hi = Application.CommandBars.ActionControl.Caption
   ActiveCell.Value = DateValue(tosi & tuki & hi)
 End Sub

 '追加コントロールチェック
 Sub ctrlchk()
  Dim myCommandBarControl As CommandBarControl
  Dim mycmd As Object
  Dim mysubcmd As Object
  Dim mysubsubcmd As Object
  Dim cnt As Long
   cnt = 0
   On Error Resume Next
   For Each mycmd In Application.CommandBars("Cell").Controls("日付選択").Controls
    cnt = cnt + 1
    ActiveSheet.Cells(cnt, 1).Value = mycmd.Caption
    For Each mysubcmd In mycmd.Controls
     cnt = cnt + 1
     ActiveSheet.Cells(cnt, 1).Value = mysubcmd.Caption
      For Each mysubsubcmd In mysubcmd.Controls
       cnt = cnt + 1
       ActiveSheet.Cells(cnt, 1).Value = mysubsubcmd.Caption
      Next mysubsubcmd
    Next mysubcmd
   Next mycmd
   On Error GoTo 0
 End Sub

（田吾作） 2015/08/06(木) 00:57

---

 たびたびすみません。

 独自追加メニュー削除を
 残っている独自追加メニューを全て取得し配列に格納、配列の最後の方から
 削除、というように修正しました。

 'メニュー削除

 Dim objary() As Variant
 Dim cnt As Integer

 Sub DelMenu3()
  Dim oya As Object
  Dim i As Integer
   Set oya = Application.CommandBars("Cell").Controls("日付選択")
   cnt = -1
   Call cmdget(oya)
   For i = UBound(objary) To 0 Step -1
    objary(i).Delete
   Next i
   oya.Delete
   Erase objary
   Set oya = Nothing
 End Sub

 Function cmdget(ByVal oyacmd As Object)
  Dim mysubcmd As Object
   If oyacmd.Type = msoControlPopup Then
      For Each mysubcmd In oyacmd.Controls
       cnt = cnt + 1
       ReDim Preserve objary(cnt)
       Set objary(cnt) = mysubcmd
       Call cmdget(mysubcmd)
      Next mysubcmd
   End If
 End Function
（田吾作） 2015/08/07(金) 22:39

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.