【Access VBA】テキストボックスに日付しか入力できないようにする

クリップボードに日付型データが入っている場合のみ日付型テキストボックスの右クリックメニューの「貼り付け」を有効にする

クリップボードに日付型データが入っている場合は日付型テキストボックスの右クリックメニューの「貼り付け」を有効にし、クリップボードに日付型データが入っていない場合は日付型テキストボックスの右クリックメニューの「貼り付け」を無効にします。

クリップボードのデータを取得する関数の記述

標準モジュールにクリップボードのデータを取得する関数を記述します。

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr

Public Function GetClipboard() As String
    Dim iStrPtr As LongPtr
    Dim iLen As LongPtr
    Dim iLock As LongPtr
    Dim sUniText As String
    Const CF_UNICODETEXT As LongPtr = 13&
    OpenClipboard 0&
    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        iStrPtr = GetClipboardData(CF_UNICODETEXT)
        If iStrPtr Then
            iLock = GlobalLock(iStrPtr)
            iLen = GlobalSize(iStrPtr)
            sUniText = String$(CLng(iLen \ 2& - 1&), vbNullChar)
            lstrcpy StrPtr(sUniText), iLock
            GlobalUnlock iStrPtr
        End If
        GetClipboard = sUniText
    End If
    CloseClipboard
End Function

下記サイトからコピペしました。
VBAでクリップボードへ文字列を送信・取得する3つの方法｜VBA技術解説

ショートカットメニューの作成

標準モジュールに下記コードを記述します。

Sub CreateShortcutMenu(ByVal SCM As String)
'エラーなら引数のコマンドバーを削除
On Error Resume Next
  CommandBars(SCM).Delete
On Error GoTo 0
' "shortcut"をCommandBarオブジェクト変数に設定　→①
Dim Shortcut As CommandBar
'新しいショートカット型のコマンド バーを作成し、コマンド バーのコレクションに追加。→②
Set Shortcut = CommandBars.Add(SCM, msoBarPopup, False, True)
'作成したコマンドバーにid=19「コピー」コントロール,id=22「貼り付け」コントロールを追加。→③
Shortcut.Controls.Add Type:=msoControlButton, ID:=19, before:=1
Shortcut.Controls.Add Type:=msoControlButton, ID:=22, before:=2
If SCM = "ShortcutMenu_Date" Then 
　If IsDate(GetClipboard) Then
    　Shortcut.Controls(2).Enabled = True
　Else
    　Shortcut.Controls(2).Enabled = False
　End If
End If
' "shortcut" 変数がCommandbarオブジェクトを参照するのを解除 →④
Set Shortcut = Nothing
End Sub

下記サイトのコードを改変してショートカット型コマンドバーの名前がShortcutMenu_Dateの場合でクリップボードのデータが日付でないときは「貼り付け」を無効にしています。
ランタイム版で右クリックショートカットメニューを使用する静にして以て幽なり

オブジェクトの参照設定

「ツール」タブの「参照設定」をクリック
　　　↓
「Microsoft Office ××.× Object Library」をチェック

ショートカットメニュー作成用プロシージャの実行

フォームに下記コードを記述します。

Private Sub Form_Open(Cancel As Integer)
    CreateShortcutMenu ("ShortcutMenu_Date")
    CreateShortcutMenu ("ShortcutMenu_Name")
End Sub

ショートカットメニュープロパティの設定

「ファイル」タブの「オプション」をクリック
　　　↓
「Accessのオプション」ダイアログボックスを表示
　　　↓
「カレントデータベース」をクリック
　　　↓
「既定のショートカットメニュー」のチェックを外す
　　　↓
フォームのショートカットメニュープロパティで「はい」を選択
　　　↓
テキストボックスのショートカットメニューバープロパティにショートカットメニュー名を入力
日付テキストボックス：ShortcutMenu_Date
名前テキストボックス：ShortcutMenu_Name

日付テキストボックスのイベントプロシージャの記述

日付テキストボックスのイベントプロシージャに下記コードを記述します。

Private Sub txtDate_KeyDown(KeyCode As Integer, Shift As Integer)
    KeyCode = 0
End Sub

Private Sub txtDate_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = acRightButton Then
        CreateShortcutMenu ("ShortcutMenu_Date")
    End If
    txtDate.SelStart = 0
    txtDate.SelLength = Len(Nz(txtDate.Text))
End Sub

アプリ作成で学ぶ Access VBAプログラミングワンランク上のフォーム&レポート

作者:横山達大
秀和システム

Amazon