項目

DATEDIF関数のバグ

内容説明

DATEDIF関数は、指定された期間内の日数、月数、または年数を返すワークシート関数です。
この関数はLotus 1-2-3 関数との互換性を保つために用意されていて、[関数の貼り付け]ダイアログボックスの[関数名]のリストには出てきません。
但しDATEDIF関数のヘルプは使えますので、関数の詳細はヘルプをご覧下さい。
結構便利な関数で使われている方も多いと思いますが、バグがある事でも知られており要注意です。
バグ情報に付いては、"DATEDIF関数" "バグ" 等をキーワードでWEB検索すれば多くが見つかります。
ここでは、DATEDIF関数のバグを取り除いた完全互換のkDateDif関数を紹介します。

'DATEDIF関数 バグ をキーワードでWEB検索
'[関数の貼り付け]ダイアログボックスの[関数名]のリストには出てきません。
'但しDATEDIF関数のヘルプは使えます。詳細はヘルプをご覧下さい。
'kDateDif関数
'書式
'DATEDIF(date1,date2,unit)
'date1: 開始日 期間の開始日を指定します
'       日付は"を前後に付けた文字列("2001/1/30"等)、シリアル値(2001年1月30日を表す36921等)、他の関数の結果(DATEVALUE("2001/1/30")等)
'date2: 終了日 期間の終了日を指定します
'unit : 単位 戻り値の種類を指定します
'  "Y"  期間内の満年数
'  "M"  期間内の満月数
'  "D"  期間内の日数
'  "MD" 開始日から終了日までの日数。この場合、月と年は考慮されません
'  "YM" 開始日から終了日までの月数。この場合、日と年は考慮されません
'  "YD" 開始日から終了日までの日数。この場合、年は考慮されません
'  ""   y年mヶ月d日 省略値
'戻り値:単位で指定した値
Public Function kDateDif(ByVal date1 As Date, ByVal date2 As Date, Optional ByVal unit As String) As Variant
  Dim yy&, mm&, ym& 'Y :期間内満年数, M :期間内満総月数, YM:年未満の端数の月数
  Dim md&, yd&   'MD:月未満の端数の日数, YD:年未満の端数の日数
  Dim tdate As Date '作業用日付作成
  yy = Evaluate("datedif(""" & date1 & """, """ & date2 & """, ""Y"")") 'Y
  mm = Evaluate("datedif(""" & date1 & """, """ & date2 & """, ""M"")") 'M
  ym = Evaluate("datedif(""" & date1 & """, """ & date2 & """, ""YM"")") 'YM
  If (Day(date1 + 1) = 1) Then '開始日が月末日の場合
    md = IIf(Day(date2 + 1) = 1, 0, Day(date2)) 'MD
    tdate = DateAdd("yyyy", yy, (date1 + 1))
    yd = DateDiff("d", tdate, (date2 + 1)) 'YD
  Else
    tdate = DateAdd("m", mm, date1)
    If (tdate > date2) Then tdate = DateAdd("m", mm, date1)
    md = DateDiff("d", tdate, date2) 'MD
    tdate = DateAdd("yyyy", yy, date1)
    yd = DateDiff("d", tdate, date2) 'YD
  End If
  Select Case UCase(unit) '戻り値設定
  Case "Y":  kDateDif = yy
  Case "M":  kDateDif = mm
  Case "D":  kDateDif = Evaluate("datedif(""" & date1 & """, """ & date2 & """, ""D"")") 'M
  Case "YM": kDateDif = ym
  Case "MD": kDateDif = md
  Case "YD": kDateDif = yd
  Case Else: kDateDif = yy & "年" & ym & "ヶ月" & md & "日"
  End Select
End Function

'マクロの説明を設定 注)1度だけ実行してファイルを保存して下さい
Private Sub MacroOptions_kDateDif()
  Dim msg$
  msg = "date1:開始日  date2:終了日" & vbCr & _
    "unit :単位 ""Y""満年数 ""M""満月数 ""D""日数 ""MD"" ""YM"" ""YD"""
  Application.MacroOptions Macro:="kDateDif", Description:=msg, Category:=2
End Sub

項目

ユーザーフォームをアクティブウィンドウに合わせて表示する

内容説明

ユーザーフォームをアクティブウィンドウの位置に合わせて表示する簡単な方法を示します。
示すマクロはアクティブウィンドウの左上にユーザーフォームの左上を合わせて表示する一例です。
アクティブウィンドウの位置とサイズをスクリーン座標で所得しポイント単位に変換する方法を示しています。

'UserFormモジュール
Option Explicit
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
  (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetWindowRect Lib "user32" _
  (ByVal hWnd As Long, lpRect As RECT) As Long

Private Sub UserForm_Initialize()
  Dim hWnd&, rc As RECT, ww&, hh&, ia As IAccessible
  Set ia = Me
  ia.accParent.accLocation 0, 0, ww, hh
  hWnd = FindWindowEx(0, 0, "XLMAIN", Application.Caption)
  hWnd = FindWindowEx(hWnd, 0, "XLDESK", vbNullString)
  hWnd = FindWindowEx(hWnd, 0, "EXCEL7", vbNullString)
  If hWnd = 0 Then Exit Sub
  GetWindowRect hWnd, rc 'ワークブックのウィンドウの位置を取得する
  Move rc.Left * Width / ww, rc.Top * Height / hh
  If ActiveWindow.WindowState = xlMaximized Then _
    Move Left - ActiveWindow.Left, Top - ActiveWindow.Top
  StartUpPosition = 0
End Sub

項目

ユーザーフォームをデスクトップの任意の位置に表示する

内容説明

ユーザーフォームをデスクトップの任意の位置に表示する簡単な方法を示します。
ユーザーフォームの位置はMoveメソッドやLeft,Topプロパティで設定出来ますのでデスクトップのサイズが分かれば右下隅とか右端中央とか任意に表示する事が出来ます。
ここではAPIを用いずIAccessibleインターフェイス(Accessibility)にてデスクトップのサイズを取得しています。

'UserFormモジュール
Option Explicit
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
  (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_WORKAREA = &H30&
Private Type RECT
  Left As Long
  Top  As Long
  Right  As Long
  Bottom As Long
End Type

Private Sub UserForm_Initialize()
  Dim ww&, hh&, ia As IAccessible, dsk As RECT ', dskw&, dskh&
  Set ia = Me
  ia.accParent.accLocation 0, 0, ww, hh
  'ia.accParent.accParent.accLocation 0, 0, dskw, dskh
  SystemParametersInfo SPI_WORKAREA, 0&, dsk, 0& 'デスクトップ領域
  'Debug.Print "デスクトップのサイズ " & dskw & "x" & dskh & "ピクセル " _
    & dskw * Width / ww & "x" & dskh * Height / hh & "ポイント"
  'デスクトップの右端中央に表示する例
  Move dsk.Right * Width / ww - Width, (dsk.Bottom * Height / hh - Height) / 2
  '左上
  'Move dsk.Left * Width / ww, dsk.Top * Height / hh
  '左下
  'Move dsk.Left * Width / ww, dsk.Bottom * Height / hh - Height
  '右上
  'Move dsk.Right * Width / ww - Width, dsk.Top * Height / hh
  '右下
  'Move dsk.Right * Width / ww - Width, dsk.Bottom * Height / hh - Height
  StartUpPosition = 0
End Sub

追記： ユーザーフォームの下部が表示しきれない
（SystemParametersInfo関数のもうひとつの使用例）
環境(画面の解像度)によってはユーザーフォームがデスクトップに全て表示されず下部が隠れてしまう場合があります。
ユーザーフォームのサイズを縮小して最下部まで表示する方法です。
解像度1280x800の環境の場合はユーザーフォームのHeightプロパティを610ポイント(≒813ポイント)(800ピクセル以上)に設定してお試し下さい。

'UserFormモジュール
Option Explicit
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
  (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_WORKAREA = &H30&
Private Type RECT
  Left As Long
  Top  As Long
  Right  As Long
  Bottom As Long
End Type

Private Sub UserForm_Initialize()
  Dim ww&, hh&, ia As IAccessible, dsk As RECT
  Set ia = Me
  ia.accParent.accLocation 0, 0, ww, hh
  SystemParametersInfo SPI_WORKAREA, 0&, dsk, 0& 'デスクトップ領域
  If dsk.Bottom - dsk.Top < hh Then
    Zoom = (dsk.Bottom - dsk.Top) / hh * 100
    Height = Height * Zoom / 100: Width = Width * Zoom / 100
    'Debug.Print Zoom & " %"
  End If
End Sub

項目

プロジェクトロックに蓋をする

内容説明

VBAプロジェクトの保護をしたExcelファイルに対して保護を解除する[VBAProjectパスワード]の入力ダイアログを表示しないように処置する方法を示します。
VBE[ツール]-[プロパティ]でパスワードの入力をしようとすると
[プロジェクトを表示できません。]
と、ダイアログが表示されパスワード入力が出来なくなります。

注）必ずソースファイルは別途保管して、プロジェクト保護したリリースファイルに対して処置を行って下さい。
処置済みのリリースファイルはVBAの編集が出来なくなります。

■簡易な方法 kProjectCovered関数

'標準モジュール
Option Explicit
Option Private Module

'kProjectCovered関数
'機能 プロジェクトロックに蓋をする
'　　プロジェクトパスワードの入力が出来ないようにする
'　　(｢プロジェクトを表示できません。｣と表示される)
'引数 file:処理を行うフルファイル名(拡張子はxl?)
'　　プロジェクトの保護済みのリリース用Excelファイルを指定の事
'戻り値 0=成功 0<>エラー
Function kProjectCovered(ByVal file As String)
  Dim wb As Workbook, ii&, pw$
  On Error Resume Next
  If Dir(file) = "" Then kProjectCovered = 1: Exit Function
  Randomize
  For ii = 1 To 8: pw = pw & Int(256 * Rnd): Next
  With Application
    .DisplayAlerts = False
    .EnableEvents = False
    If Dir(file & ".bak") = "" Then FileCopy file, file & ".bak"
    Set wb = Workbooks.Open(file)
    wb.ProtectSharing Filename:=wb.FullName, SharingPassword:=pw
    wb.Close
    .ShowWindowsInTaskbar = False
    .EnableEvents = True
    .DisplayAlerts = True
  End With
  kProjectCovered = Err
End Function

'kProjectCovered関数の使用例
Sub testProjectCovered()
  Dim file$, rt&
  file = "c:\ddd\eee\test1.xla"
  rt = kProjectCovered(file)
  Debug.Print rt
End Sub

処置を行うファイルのOpenイベントに以下を記述の事 (kProjectCovered関数を適用する場合に必須)

'ブック(ThisWorkbook)モジュール
Private Sub Workbook_Open()
  Application.ShowWindowsInTaskbar = False
  With Windows(Name)
    If .Visible Or Not IsAddin Then .Caption = Name
  End With
End Sub

■本格的な方法
本格的にプロジェクトロックに蓋をするには拙作、k茶-[プロジェクトロックに蓋をする]コマンドをご利用下さい。
上記で示した処置を行うファイルのOpenイベントへの記述は不要です。
詳細はk茶のヘルプをご参照下さい
お茶ですよ[k茶] エクセルVBA開発ツール

項目

コマンドバー操作メモ(応用 VBE)

内容説明

コマンドバー(メニュー)の応用的な操作メモ VBE編です。
VBE(Visual Basic Editor)のコマンドバーを操作するサンプルを示します。 VBEのコマンドバーはOnActionプロパティが機能しないのでWithEventsキーワードによるイベントをハンドルする必要があります｡
VBEコマンドバー情報(項目一覧、FaceId表示)は拙作、k茶をご参照下さい。
お茶ですよ[k茶] エクセルVBA開発ツール

'■VBEコマンドバーの基本(CommandBarEventsオブジェクトとCommandBarButtonオブジェクト)
'標準モジュール
Option Explicit
Dim dvbebar As CVbeBar

Sub test_VbeBarAdd()
  Set dvbebar = New CVbeBar
  dvbebar.VbeBarAdd
End Sub

Sub test_VbeBarDel()
  dvbebar.VbeBarDelete
  Set dvbebar = Nothing
End Sub

'CVbeBar クラスモジュール
Option Explicit
Private WithEvents BarReset As Office.CommandBarButton
'↓参照設定 Microsoft Visual Basic for Applications Extensibility x.x
Private WithEvents ImmediateClear As VBIDE.CommandBarEvents
Const dIMMEDI = "すべてクリア(&D)"
Const dEXRESET = "コマンドバークリア(&C)"

Sub VbeBarAdd()
  Dim cb As CommandBarButton
  VbeBarDelete
  'CommandBarEventsオブジェクトによる方法
  'イミディエイトウインドウの右クリックメニューに[すべてクリア(&D)]コマンドを追加
  With Application.VBE
    Set cb = .CommandBars("Immediate Window").Controls.Add(Type:=msoControlButton, Temporary:=True)
    cb.Caption = dIMMEDI
    Set ImmediateClear = .Events.CommandBarEvents(cb)
  End With
  'CommandBarButtonオブジェクトによる方法
  'VBE-[ツール]メニューに[コマンドバークリア(&C)]コマンドを追加
  Set BarReset = Application.VBE.CommandBars.FindControl(, 30007).Controls.Add(Type:=msoControlButton, Temporary:=True)
  BarReset.Caption = dEXRESET
End Sub

Sub VbeBarDelete()
  On Error Resume Next
  With Application.VBE
    .CommandBars("Immediate Window").Controls(dIMMEDI).Delete
    .CommandBars.FindControl(, 30007).Controls(dEXRESET).Delete
  End With
End Sub

Private Sub BarReset_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  Dim cb As CommandBar
  On Error Resume Next
  For Each cb In Application.CommandBars
    cb.Enabled = True
    If cb.Index < 20 Then _
      cb.Visible = IIf(InStr("Worksheet Menu Bar,Standard,Formatting,Drawing", cb.Name), True, False)
    If cb.BuiltIn Then cb.Reset Else cb.Delete
  Next
End Sub

Private Sub ImmediateClear_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean)
  SendKeys "^a{DEL}"
End Sub

'■VBEメニューバーと右クリックショートカットメニューへ複数のコマンド追加例
'標準モジュール
Option Explicit
Dim dvbemenu As CVbeMenu

Sub test_VbeMenuAdd()
  Set dvbemenu = New CVbeMenu
  dvbemenu.Add
End Sub

Sub test_VbeMenuDel()
  dvbemenu.Delete
  Set dvbemenu = Nothing
End Sub

'CVbeMenu クラスモジュール
Option Explicit
Public WithEvents VbeMenu As Office.CommandBarButton
Private dvbe As New Collection
Const dMNUCAP = "TestVbe(&V)"
Const dCODECAP = "TestCode(&C)"

'メニュー削除
Sub Delete()
  Dim ii&
  On Error Resume Next
  With Application.VBE
    .CommandBars("メニュー バー").Controls(dMNUCAP).Delete
    .CommandBars("Code Window").Controls(dCODECAP).Delete
  End With
  For ii = 1 To dvbe.Count: dvbe.Remove 1: Next '雛型として
End Sub

'メニュー作成
Sub Add()
  Delete
  'VBEのメニューバーへ追加
  With Application.VBE.CommandBars("メニュー バー").Controls.Add(Type:=msoControlPopup, Temporary:=True, Before:=1)
    .Caption = dMNUCAP
    With AddMenuEvents(.CommandBar)
      .Caption = "Aaa(&A)"
      .FaceId = 481
    End With
    With AddMenuEvents(.CommandBar)
      .Caption = "Bbb(&B)..."
      .FaceId = 482
    End With
    With .CommandBar.Controls.Add(Type:=msoControlPopup) '階層
      .Caption = "SubVbe(&S)"
      .BeginGroup = True
      With AddMenuEvents(.CommandBar)
        .Caption = "Ccc(&C)"
        .FaceId = 483
      End With
      With AddMenuEvents(.CommandBar)
        .Caption = "Ddd(&D)..."
        .FaceId = 484
      End With
    End With
  End With
  'VBEのCodeWindowの右クリックショートカットメニューへ追加
  With Application.VBE.CommandBars("Code Window").Controls.Add(Type:=msoControlPopup, Temporary:=True)
    .Caption = dCODECAP
    With AddMenuEvents(.CommandBar)
      .Caption = "Eee(&E)"
      .FaceId = 59
    End With
    With AddMenuEvents(.CommandBar)
      .Caption = "Fff(&F)..."
      .FaceId = 276
    End With
  End With
End Sub

'コマンドバーのコントロール作成とイベントのセット
Private Function AddMenuEvents(cb As CommandBar) As CommandBarButton
  Dim eve As New CVbeMenu
  Set AddMenuEvents = cb.Controls.Add(Type:=msoControlButton)
  Set eve.VbeMenu = AddMenuEvents
  dvbe.Add eve
End Function

'イベント
'ここで各コマンドの実務処理ルーチンを呼ぶ
Private Sub VbeMenu_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  Select Case Ctrl.Caption
  Case "Aaa(&A)"
    Debug.Print Ctrl.Caption
  Case "Bbb(&B)..."
    MsgBox Ctrl.Caption
  Case "Ccc(&C)"
    Debug.Print Ctrl.Caption
  Case "Ddd(&D)..."
    MsgBox Ctrl.Caption
  Case "Eee(&E)"
    Debug.Print Ctrl.Caption
  Case "Fff(&F)..."
    MsgBox Ctrl.Caption
  End Select
End Sub

項目

コマンドバー操作メモ(応用 クラス)

内容説明

コマンドバー(メニュー)の応用的な操作メモ クラス編です。

'■ふりがな-表示/非表示(&S)コマンドをカスタマイズ
既存のコマンドをラップしてカスタマイズする例その1
[書式]-[ふりがな]-[表示/非表示(&S)]コマンドはIMEを使用せずに入力した漢字ではふりがなを取得できません。
他からコピー&貼り付けされた漢字にもふりがなをセットするようカスタマイズします。

'標準モジュール
Option Explicit
Dim dphonetic As CWrapPhonetic

'ふりがな-表示/非表示(&S)コマンドのカスタマイズを開始
Sub kWrapPhoneticSet()
  Set dphonetic = New CWrapPhonetic
End Sub
'ふりがな-表示/非表示(&S)コマンドのカスタマイズを解除
Sub kWrapPhoneticRelease()
  Set dphonetic = Nothing
End Sub

'CWrapPhonetic クラスモジュール
Option Explicit
Public WithEvents WrapPhonetic As Office.CommandBarButton

Private Sub Class_Initialize()
  Set WrapPhonetic = Application.CommandBars("Phonetic Guide").Controls("表示/非表示(&S)")
End Sub

Private Sub WrapPhonetic_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  With Selection
    If StrComp(.Item(1).Phonetic.Text, .Item(1).Value, vbTextCompare) = 0 Then
      .SetPhonetic
    End If
  End With
End Sub

'■行の挿入(&I)コマンドをカスタマイズ
既存のコマンドをラップしてカスタマイズする例その2
行の挿入コマンドをクリックしたとき、行挿入イベントに応答するカスタムコードを実行する方法を示します。

'標準モジュール
Option Explicit
Dim drow As CWrapRow

'行挿入コマンドのラップ開始
Private Sub testWrapRowOn()
  Set drow = New CWrapRow
  drow.Initialize
End Sub
'行挿入コマンドのラップ終了
Private Sub testWrapRowOff()
  drow.Terminate
  Set drow = Nothing
End Sub

'CWrapRow クラスモジュール
'[行の挿入]コマンドをカスタマイズ
Option Explicit
Public WithEvents Row As Office.CommandBarButton
Dim dcol As New Collection

'行挿入ラップ開始処理
Sub Initialize()
  Dim eve As New CWrapRow, ele
  'Id=296 行(&R)、Id=3182 セル(&E)、Id=3183 挿入(&I)
  For Each ele In Array(296, 3182, 3183)
    Set eve.Row = Application.CommandBars.FindControl(ID:=ele)
    dcol.Add eve
    Set eve = Nothing '必須
  Next
End Sub

'行挿入イベント(行挿入イベントに応答するカスタムコードを記述)
Private Sub Row_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  MsgBox "行挿入 " & Selection.Address '確認用
  'ここで行挿入前の処理
  '
  CancelDefault = True '行挿入をキャンセル
  Selection.EntireRow.Insert '行挿入実行
  'ここで行挿入後の処理
  '
End Sub

'■印刷プレビュー(&V)コマンドをカスタマイズ
既存のコマンドをラップしてカスタマイズする例その3
E00M089 プレビューのボタンを使用不可にする
追記1：にて、コマンドバーの[プレビュー]コマンドを実行したときにプレビューの[印刷]ボタン等を使用不可にするサンプルを示しています。

'■コメントの挿入(&M)コマンドをカスタマイズ
既存のコマンドをラップしてカスタマイズする例その4
セルの右クリックショートカットメニュー[コメントの挿入]をカスタマイズして任意の仕様のコメントを挿入するクラス CWrapComment です。
[挿入]-[コメント]コマンドは元のままなので既定の仕様のコメントを挿入する事が出来ます。

'標準モジュール
Option Explicit
Dim dcomment As CWrapComment

'コメントの挿入(&M)コマンドのカスタマイズを開始
Sub kWrapCommentSet()
  Set dcomment = New CWrapComment
End Sub
'コメントの挿入(&M)コマンドのカスタマイズを解除
Sub kWrapCommentRelease()
  Set dcomment = Nothing
End Sub

'クラスモジュール　CWrapComment
'セルの右クリック"コメントの挿入(&M)"のカスタマイズ
Option Explicit
Public WithEvents WrapComment As Office.CommandBarButton
Private dcap$

Private Sub Class_Initialize()
  Set WrapComment = Application.CommandBars.FindControl(ID:=2031) 'セルの右クリック "コメントの挿入(&M)"
  dcap = WrapComment.Caption
End Sub

Private Sub WrapComment_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  If dcap <> Ctrl.Caption Then Exit Sub
  '以下好みのコメント仕様(書式)設定
  With ActiveCell.AddComment.Shape
    .Shadow.Visible = msoFalse '影なし
    .AutoShapeType = msoShapeRoundedRectangle '角丸角形
    With .TextFrame
      .AutoSize = True 'テキストに合わせてサイスを自動変更
      With .Characters.Font
        '.Name = "ＭＳ Ｐゴシック"
        .Size = 10
        '.ColorIndex = xlAutomatic
      End With
    End With
  End With
End Sub

'■コピー(&C)コマンドをカスタマイズ
既存のコマンドをラップしてカスタマイズする例その5
[コピー(&C)]コマンドにてコピーされたセル範囲を取得するクラスCWrapCopyです。
セルをコピーした場合に選択範囲の枠線が点滅状態になります。この状態で他のセルを選択すると点滅状態のセル範囲はもはや取得できません。
あるいは他のコマンド等によりコピーモード(枠線点滅の状態)が解除された場合もコピーしたセル範囲は取得できません。
クラスCWrapCopyはこのように取得出来なくなった、直前にコピーされたセル範囲を保持します。

'標準モジュール
Option Explicit
Dim dcopy As CWrapCopy

'クラスモジュールCWrapCopyの開始
Sub WrapCopyOn()
  Set dcopy = New CWrapCopy
End Sub

'クラスモジュールCWrapCopyの停止
Sub WrapCopyOff()
  Set dcopy = Nothing
End Sub

Sub testWrapCopy()
  If dcopy Is Nothing Then Beep: Exit Sub 'クラスは動作していない
  'Nothingならコピーされていない或いは破棄されている(削除、閉じる等)
  If Not dcopy.Range Is Nothing Then _
    Debug.Print dcopy.Range.Address(False, False, , True)
End Sub

'クラスモジュールCWrapCopy
'直前にコピーされたセル範囲を保持する
Option Explicit
Private WithEvents Cp As Office.CommandBarButton
Private dcp As Range

Private Sub Class_Initialize()
  Set Cp = Application.CommandBars.FindControl(ID:=19)
End Sub

Private Sub Cp_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  If TypeOf Selection Is Excel.Range Then _
    Set dcp = Selection 'ActiveWindow.RangeSelection
End Sub

Property Get Range() As Range
  If VarType(dcp) = vbObject Then Set dcp = Nothing
  Set Range = dcp
End Property
Property Let Range(rg As Range)
  Set dcp = rg
End Property
Property Set Range(rg As Range)
  Set dcp = rg
End Property

'■セル編集中はコマンドバーを使用不可に
E00M094 セル編集中はマクロが実行出来ない？
セル編集中はコマンドバーを使用不可(淡色)にするサンプルです。
OnActionプロパティを用いずにWithEventsキーワードによるイベント処理を行っています。
(高度な再帰ルーチンによるイベント設定)

'■ユーザーフォームのテキストボックス等に右クリックショトカットメニューを付加
拙作、カレンダーによる日付設定 [k可憐] にてユーザーフォームのテキストボックスとコンボボックスに右クリックショトカットメニューを付加するクラスモジュール[CRightClick]を公開しています。
カレンダーによる日付設定 [k可憐]
メニュー項目：[切り取り][コピー][貼り付け][削除][すべて選択]

'使用例(利用方法は超簡単)
'事前準備：[CRightClickクラスモジュール]の組込み(ドラッグコピー/インポート等)
'ユーザーフォームモジュール
Option Explicit
Dim dcp As CRightClick

Private Sub UserForm_Initialize()
  Set dcp = New CRightClick
  dcp.Initialize Me
End Sub

項目

コマンドバー操作メモ(応用)

内容説明

コマンドバー(メニュー)の応用的な操作メモです。

Option Explicit
Private Declare Function GetKeyState Lib "User32.dll" _
  (ByVal nVirtKey As Integer) As Integer

'■メニューを[Shift]+クリックしたときに別コマンドを実行する
Sub testShiftAdd() 'msoBarFloating
  testShiftDel
  With Application.CommandBars.Add(Name:="testShift", Position:=msoBarFloating, Temporary:=True)
    With .Controls.Add(Type:=msoControlButton)
      .Caption = "testShiftOn"
      .FaceId = 728
      .OnAction = "testShiftOn"
    End With
    .Visible = True
  End With
End Sub
Sub testShiftDel()
  On Error Resume Next
  Application.CommandBars("testShift").Delete
End Sub
Sub testShiftOn()
  '要Declare宣言 GetKeyState関数
  Select Case GetKeyState(vbKeyShift) < 0
  Case True
    MsgBox "Shiftキーが押されたときのコマンド"
    '
  Case Else
    MsgBox "通常のコマンド"
    '
  End Select
End Sub

'■状況によりメニューの表示を変更する
'・シフトキーを押してメニューをクリックした場合、項目のキャプションを変える
'・切り取りまたはコピーモードでなければコマンドを使用不可にする
'・項目のキャプションにチェックを付けたり外したりする
Sub testShift2Add() 'msoControlPopup
  testShift2Del
  With Application.CommandBars("Worksheet Menu Bar")
    With .Controls.Add(Type:=msoControlPopup, Temporary:=True)
      .Caption = "Test(&T)"
      .OnAction = "testShift2Action"
      With .CommandBar.Controls.Add(Type:=msoControlButton)
        .Caption = "Aaa(&A)..."
        .OnAction = "testShift2Parameter"
        .FaceId = 728
      End With
      With .CommandBar.Controls.Add(Type:=msoControlButton)
        .Caption = "Bbb(&B)"
        .OnAction = "bbb"
        .FaceId = 22
      End With
      With .CommandBar.Controls.Add(Type:=msoControlButton)
        .Caption = "Ccc(&C)"
        .OnAction = "testShift2Chack"
        .State = msoButtonDown 'チェック
      End With
    End With
  End With
End Sub
Sub testShift2Del()
  On Error Resume Next
  Application.CommandBars("Worksheet Menu Bar").Controls("Test(&T)").Delete
End Sub
'状況によりメニューの表示を変更するプロシージャ例
Sub testShift2Action()
  With Application.CommandBars("Worksheet Menu Bar").Controls("Test(&T)")
    With .Controls(1)
      '要Declare宣言 GetKeyState関数
      Select Case GetKeyState(vbKeyShift) < 0
      Case True 'Shiftキーが押された
        .Caption = "Zzz(&Z)..."
        .Parameter = "Shift"
      Case Else
        .Caption = "Aaa(&A)..."
        .Parameter = ""
      End Select
    End With
    '切り取りまたはコピーモードでなければコマンドを使用不可にする例
    .Controls(2).Enabled = Application.CutCopyMode
    'チェックを付けたり外したりする例
    .Controls(3).State = testShift2Chack(True)
  End With
End Sub
Sub testShift2Parameter()
  Select Case Application.CommandBars.ActionControl.Parameter
  Case "Shift"
    MsgBox "Shiftキーが押されたときのコマンド"
  Case Else
    MsgBox "通常のコマンド"
  End Select
End Sub
Function testShift2Chack(Optional flg As Boolean)
  Static down As Boolean
  If flg Then testShift2Chack = down: Exit Function
  down = Not down 'チェックの反転
  '以下実際の処理を記述
End Function

'■コマンドバーの情報を利用する
'Excelで利用出来るフォントリストを取得する例
Private Sub testGetFontList()
  Dim ii&
  With Application.CommandBars.Add(Temporary:=True).Controls.Add(ID:=1728)
    For ii = 1 To .ListCount
      Debug.Print ii, .List(ii)
    Next
    .Parent.Delete
  End With
End Sub

項目

コマンドバー操作メモ(基本3)

内容説明

コマンドバー(メニュー)の基本的な操作メモその3です。
メニューの表示/非表示・修復に関するTipsです。

'■全てのコマンドバ−を非表示
Sub kAllBarDisabled()
  Dim cb As CommandBar
  For Each cb In CommandBars
    cb.Enabled = False
  Next
End Sub
Sub kAllBarEnabled() '元に戻す
  Dim cb As CommandBar
  For Each cb In CommandBars
    cb.Enabled = True
  Next
End Sub

'■既存のコマンドバ−を全て非表示にして独自メニューを作る
'先に示したkAllBarDisabled関数及びkAllBarEnabledを用います
'注)終了時は必ずtestOriginalMenuDel関数を実行すること
'　変更のままExcelを終了するとExcelのコマンドバーがその独自メニューに置き換わってしまいます
Sub testOriginalMenu()
   kAllBarDisabled
  'メニューバー例
  With Application.CommandBars.Add _
    (Name:="OriginalMenuBar", Position:=msoBarTop, Temporary:=True, MenuBar:=True)
    .Visible = True
    With .Controls.Add(Type:=msoControlPopup)
      .Caption = "ファイル(&F)"
    End With
    With .Controls.Add(Type:=msoControlPopup)
      .Caption = "編集(&E)"
    End With
    With .Controls.Add(Type:=msoControlPopup)
      .Caption = "データ(&D)"
    End With
    With .Controls.Add(Type:=msoControlPopup)
      .Caption = "ウィンドウ(&W)"
    End With
    With .Controls.Add(Type:=msoControlPopup)
      .Caption = "ヘルプ(&H)"
    End With
  End With
  'ツールメニュー例
  With Application.CommandBars.Add _
    (Name:="OriginalToolBar", Position:=msoBarLeft Or msoBarTop, Temporary:=True)
    .Visible = True
    With .Controls.Add(Type:=msoControlButton)
      .Caption = "新規作成(&N)..."
      .FaceId = 18
    End With
    With .Controls.Add(Type:=msoControlButton)
      .Caption = "開く(&O)..."
      .FaceId = 23
    End With
    With .Controls.Add(Type:=msoControlButton)
      .Caption = "上書き保存(&S)"
      .FaceId = 3
    End With
    .Controls.Add Type:=msoControlButton, ID:=4   '印刷
    .Controls.Add Type:=msoControlButton, ID:=109 '印刷プレビュー(&V)
    .Controls.Add Type:=msoControlButton, ID:=21  '切り取り(&T)
    .Controls(.Controls.Count).BeginGroup = True
    .Controls.Add Type:=msoControlButton, ID:=19  'コピー(&C)
    .Controls.Add Type:=msoControlButton, ID:=22  '貼り付け(&P)
    .Controls.Add Type:=msoControlComboBox, ID:=1733 'ズーム(&Z)
    .Controls(.Controls.Count).BeginGroup = True
    With .Controls.Add(Type:=msoControlButton)
      .FaceId = 928
      .Caption = "並べ替え(&S)..."
      .BeginGroup = True '区切り線
    End With
    With .Controls.Add(Type:=msoControlButton)
      .Caption = "ヘルプ(&H)"
      .FaceId = 984
    End With
  End With
End Sub
'独自メニューを削除し既存のコマンドバ−に戻す
Sub testOriginalMenuDel()
  On Error Resume Next
  Application.CommandBars("OriginalMenuBar").Delete
  Application.CommandBars("OriginalToolBar").Delete
  On Error GoTo 0
  kAllBarEnabled
End Sub
'Sub Auto_Close() '終了時にtestOriginalMenuDel関数を実行する例
'  testOriginalMenuDel
'End Sub

'■コマンドバーをリセット
マクロの不都合や異常終了等によりコマンドバーが使用不可や変更される場合があります。
そのような時にkバーを用いると簡単にコマンドバーを修復する事が出来ます。 ツールバーファイル(Excel*.xlb)の再構築を行います。
Excelコマンドバーの修復　kバー

'■簡易コマンドバーリセット1
'(ユーザー設定のコマンドバーは削除)
Sub kBarsReset1()
  Dim cb As CommandBar, ad As Object
  On Error Resume Next
  For Each cb In Application.CommandBars
    cb.Protection = msoBarNoProtection 'Borders 罫線 Id=59〜Line Color 線の色 Id=64 まで解除出来ない
    If cb.BuiltIn Then cb.Reset Else cb.Delete
  Next
  On Error GoTo 0
  '使用中のアドインなら元に戻す
  For Each ad In Application.COMAddIns
    If ad.Connect Then ad.Connect = False: ad.Connect = True
  Next
  For Each ad In Application.AddIns
    If ad.Installed Then ad.Installed = False: ad.Installed = True
  Next
End Sub

'■簡易コマンドバーリセット2
'(ワークシートメニューバー、標準、書式設定、図形描画を表示)
Sub kBarsReset2()
  Dim cb As CommandBar ' Object
  For Each cb In Application.CommandBars
    cb.Enabled = True
    If cb.Index < 20 Then _
      cb.Visible = IIf(InStr("Worksheet Menu Bar,Standard,Formatting,Drawing", cb.Name), True, False)
    If cb.BuiltIn = False Then
      cb.Protection = msoBarNoProtection
      cb.Delete
    Else
      cb.Reset
    End If
  Next
  With Application
    .CommandBars("Toolbar List").Enabled = True
    .DisplayFormulaBar = True
    .DisplayStatusBar = True
  End With
End Sub

'■コマンドバーの右クリックを制御
  'コマンドバーの右クリックを無効に
  Application.CommandBars("Toolbar List").Enabled = False
  'コマンドバーの右クリックを有効に
  Application.CommandBars("Toolbar List").Enabled = True

'■メニューバー右端の[質問を入力してください]ボックスを非表示に
  'Office2000以降
  If Val(Application.Version) > 9 Then _
    CallByName Application.CommandBars, "DisableAskAQuestionDropdown", VbLet, True
  'Application.CommandBars.DisableAskAQuestionDropdown = True

'■[オブジェクトの選択]を解除
  'Id:=182はCommandBars("Drawing").Controls("オブジェクトの選択(&S)")
  With Application.CommandBars.FindControl(ID:=182)
    If .State = msoButtonDown Then .Execute
  End With

'■ツールバーの配置
'[標準]と[書式設定]ツールバーを横に並べて配置する
Sub kBarOneLine()
  Dim Standard As CommandBar
  Set Standard = Application.CommandBars("Standard")
  With Application.CommandBars("Formatting")
    .RowIndex = Standard.RowIndex
    Standard.Left = 0
    .Left = (Standard.Width + .Width) / 2
  End With
End Sub
'[標準]と[書式設定]ツールバーを2行に並べて配置する
Sub kBarTwoLine()
  Dim Standard As CommandBar
  Set Standard = Application.CommandBars("Standard")
  With Application.CommandBars("Formatting")
    .RowIndex = Standard.RowIndex + 1
    .Left = 0
  End With
  Standard.Left = 0
End Sub

項目

コマンドバー操作メモ(基本2)

内容説明

コマンドバー(メニュー)の基本的な操作メモその2です。


'■ドロップダウンリストとコンボボックスのツールバー
Sub testDropdownAdd()
  Dim ii&
  testDropdownDel
  With Application.CommandBars.Add(Name:="testDropdown", Position:=msoBarFloating, Temporary:=True)
    'コマンドバーにドロップダウンリストボックスを追加
    With .Controls.Add(Type:=msoControlDropdown)
      .Caption = "シート選択(&S)"
      .OnAction = "testSheetSelect"
      For ii = 1 To Worksheets.Count
        .AddItem Worksheets(ii).Name
        If Worksheets(ii).Name = ActiveSheet.Name Then .ListIndex = ii
      Next
    End With
    'コマンドバーにドロップダウンコンボボックスを追加
    With .Controls.Add(Type:=msoControlComboBox)
      .Caption = "セル値(&L)"
      '定型句
      .AddItem Text:="aaa" ', Index:=1
      .AddItem Text:="bbb" ', Index:=2
      .AddItem Text:="ccc" ', Index:=3
      .DropDownLines = 3
      .DropDownWidth = 75
      .ListHeaderCount = 0
      '.ListIndex = 1
      .Text = ActiveCell.Value
      .OnAction = "testLetCell"
    End With
    .Visible = True
  End With
End Sub
Sub testDropdownDel()
  On Error Resume Next
  Application.CommandBars("testDropdown").Delete
End Sub
Private Sub testSheetSelect() 'シート選択
  Worksheets(Application.CommandBars.ActionControl.Text).Activate
End Sub
Private Sub testLetCell() '定型句を入力
  ActiveCell.Value = Application.CommandBars.ActionControl.Text
End Sub

'■コマンドバーボタンにプルダウンメニューを
'階層メニューはTypeがmsoControlPopupのコントロールにのみ作成出来ます
'従ってTypeがmsoControlButtonのボタンはコマンドを実行するのみです
'ここではボタンに階層メニューを実装する方法を示します
Sub testPulldownToButtonAdd()
  testPulldownToButtonDel
  With CommandBars.Add(Name:="testPulldown", Temporary:=True)
    .Controls.Add ID:=128
    .Controls.Add ID:=37
    With .Controls.Add(Type:=msoControlButton)
      .Caption = "プルダウンメニュー(&P)"
      .OnAction = "testPulldown"
      .FaceId = 855
    End With
    .Visible = True
  End With
End Sub
Sub testPulldownToButtonDel()
  On Error Resume Next
  CommandBars("testPulldown").Delete
End Sub
Private Sub testPulldown()
  With Application.CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
    With .Controls.Add
      .Caption = "aaa(&A)"
      .FaceId = 108
    End With
    .Controls.Add.Caption = "bbb(&B)"
    .ShowPopup
    .Delete
  End With
End Sub

'■コマンドバーのボタンコントロールに任意のイメージを設定
'イメージは非表示シートに貼り付けて置く又は動的にシェイプで描く
'以下例ではWorksheets("FaceImage")に"FaceImage1","FaceImage2"を配置
Sub testPasteFaceAdd()
  Dim ws As Worksheet
  testPasteFaceDel
  Set ws = ThisWorkbook.Worksheets("FaceImage")
  With Application.CommandBars.Add(Name:="testPasteFace", Position:=msoBarFloating, Temporary:=True)
    With .Controls.Add(Type:=msoControlPopup)
      .Caption = "Aaa(&A)"
      With .Controls.Add(Type:=msoControlButton)
        .Caption = "Xxx(&X)"
        '.OnAction = "xxx"
        ws.Shapes("FaceImage1").Copy
        .PasteFace
      End With
      With .Controls.Add(Type:=msoControlButton)
        .Caption = "Yyy(&Y)"
        ws.Shapes("FaceImage2").Copy
        .PasteFace
      End With
      With .Controls.Add(Type:=msoControlButton)
        .Caption = "Zzz(&Z)"
        .FaceId = 1090
      End With
    End With
    .Visible = True
  End With
End Sub
Sub testPasteFaceDel()
  On Error Resume Next
  Application.CommandBars("testPasteFace").Delete
End Sub

注： OfficeXP以降では以下をご参照下さい。
Office XP CommandBars の Mask プロパティと Picture プロパティを設定する方法

項目

コマンドバー操作メモ(基本)

内容説明

コマンドバー(メニュー)の基本的な操作メモです。
コマンドバー操作に必須のツールとしてk茶をご活用下さい。
お茶ですよ[k茶] エクセルVBA開発ツール
コマンドバーFaceId一覧やコマンドバー情報(コマンドバー及びVBEコマンドバーの全項目)を取得出来ます。

'■メニューバーへ追加
Sub testMenuBarAdd()
  testMenuBarDel
  'With Application.CommandBars.ActiveMenuBar
  'With Application.CommandBars("Chart Menu Bar")
  With Application.CommandBars("Worksheet Menu Bar")
    '.Protection = msoBarNoProtection
    With .Controls.Add(Type:=msoControlPopup, Temporary:=True)
      .Caption = "Test(&T)"
      With .CommandBar.Controls.Add(Type:=msoControlButton)
        .Caption = "Aaa(&A)..."
        .OnAction = "aaa"
        .FaceId = 51 'アイコン
      End With
      With .CommandBar.Controls.Add(Type:=msoControlButton)
        .Caption = "Bbb(&B)"
        .OnAction = "bbb"
        .State = msoButtonDown 'チェック　'msoButtonUp 'msoButtonMixed
        .ShortcutText = "Ctrl+Shift+A" 'キャプションの隣にショートカットキーのテキストを表示
      End With
    End With
  End With
End Sub
Sub testMenuBarDel()
  On Error Resume Next
  With Application.CommandBars("Worksheet Menu Bar")
    .Protection = msoBarNoProtection
    .Controls("Test(&T)").Delete
  End With
End Sub

'■メニューバーのコントロールに追加
Sub testToolsAdd() '[ツール]に追加する例
  testToolsDel
  '"Worksheet Menu Bar"
  With Application.CommandBars(1).Controls("ツール(&T)").Controls.Add(Type:=msoControlPopup, Temporary:=True)
    .Caption = "Test(&T)"
    .BeginGroup = True '区切り
    With .CommandBar.Controls.Add(Type:=msoControlButton)
      .Caption = "Aaa(&A)..."
      .OnAction = "aaa"
    End With
    With .CommandBar.Controls.Add(Type:=msoControlButton, ID:=2044)
      .Caption = "ブックの結合(&W)..."
    End With
  End With
End Sub
Sub testToolsDel()
  On Error Resume Next
  Application.CommandBars(1).Controls("ツール(&T)").Controls("Test(&T)").Delete
End Sub

'■ツールバーに追加
Sub testToolBarAdd() 'ツールバー[標準]に追加する例
  testToolBarDel
  With Application.CommandBars("Standard")
    With .Controls.Add(Type:=msoControlButton, ID:=3823) 'Webページとして保存
      .BeginGroup = True
    End With
    With .Controls.Add(Type:=msoControlButton)
      .Caption = "Aaa"
      .FaceId = 126
      .OnAction = "aaa"
    End With
  End With
  Application.CommandBars("Formatting").Controls.Add _
    Type:=msoControlButton, ID:=290, Before:=1 '取り消し線
End Sub
Sub testToolBarDel()
  On Error Resume Next
  With Application.CommandBars("Standard")
    .FindControl(ID:=3823).Delete
    .Controls("Aaa").Delete
  End With
  Application.CommandBars("Formatting").FindControl(ID:=290).Delete
End Sub

'■新規ツールバーを作成
Sub testNewToolBarAdd()
  Dim cb As CommandBar
  testNewToolBarDel
  Set cb = Application.CommandBars.Add(Name:="testNewToolBar", Position:=msoBarTop, Temporary:=True)
  With cb '自動メンバ表示するため
    '固定位置についてはRowIndexプロパティ、Leftプロパティ等で設定
    'ツールバーを横に並べて表示するにはRowIndexプロパティを同じにする
    .RowIndex = Application.CommandBars("Standard").RowIndex 'この領域に
    .Controls.Add Type:=msoControlButton, ID:=47
    With .Controls.Add(Type:=msoControlButton)
      .Caption = "Aaa"
      .FaceId = 266
      .OnAction = "aaa"
    End With
    .Visible = True
  End With
End Sub
Sub testNewToolBarDel()
  On Error Resume Next
  Application.CommandBars("testNewToolBar").Delete
End Sub

'■フロ−トメニュ−を作成
Sub testFloatAdd() '浮動コマンド バー
  testFloatDel
  With Application.CommandBars.Add(Name:="testFloat", Position:=msoBarFloating, Temporary:=True)
    '.Protection = msoBarNoChangeVisible '非表示にしない(Xの非表示)
    With .Controls.Add(Type:=msoControlButton)
      .Caption = "Aaa"
      .FaceId = 548
      .OnAction = "aaa"
      '.State = msoButtonMixed
    End With
    With .Controls.Add(Type:=msoControlButton)
      .Style = msoButtonCaption
      .Caption = "Bbb(&B)"
      .FaceId = 855
      .OnAction = "bbb"
    End With
    With .Controls.Add(Type:=msoControlPopup)
      .Caption = "Ccc(&C)"
      .Controls.Add Type:=msoControlButton, ID:=19 'コピー(&C)
      .Controls.Add Type:=msoControlButton, ID:=22 '貼り付け(&P)
    End With
    .Visible = True
  End With
End Sub
Sub testFloatDel()
  On Error Resume Next
  Application.CommandBars("testFloat").Delete
End Sub

'■ポップアップメニュ−を表示
Sub testShowPopup()
  Dim cb As CommandBar
  Set cb = Application.CommandBars.Add _
    (Position:=msoBarPopup, Temporary:=True) ', Name:="testShowPopup")
  With cb
    .Controls.Add Type:=msoControlButton, ID:=247 'ページ設定
    .Controls.Add Type:=msoControlButton, ID:=109 '印刷プレビュー
    With .Controls.Add(Type:=msoControlButton)
      .Caption = "Aaa(&A)"
      .FaceId = 279
      .OnAction = "aaa"
    End With
    With .Controls.Add(Type:=msoControlPopup) '階層
      .Caption = "編集(&E)"
      .Controls.Add Type:=msoControlButton, ID:=21 '切り取り(&T)
      .Controls.Add Type:=msoControlButton, ID:=19 'コピー(&C)
      .Controls.Add Type:=msoControlButton, ID:=22 '貼り付け(&P)
      .Controls.Add Type:=msoControlButton, ID:=755 '形式を選択して貼り付け(&S)...
      .Controls.Add Type:=msoControlButton, ID:=369 '書式のみ貼り付け
      .Controls.Add Type:=msoControlButton, ID:=370 '値のみ貼り付け
      With .Controls.Add(Type:=msoControlButton)
        .Caption = "Bbb(&B)"
        .FaceId = 343
        .OnAction = "bbb"
      End With
    End With
    .ShowPopup
    .Delete
  End With
End Sub

'■セルを右クリックしたときのショ−トカットメニュ−
E03M101 セルの右クリックショートカットメニューを設定する
E03M121 切り取り又はコピーされたセル範囲を取得する
セルの右クリックショートカットメニューに拡張貼り付けのコマンドを設定したアドインがダウンロード出来ます。