Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2016)
Ctrキーがl押されているかを判断し、分岐したいです
投稿日時: 20/11/09 08:02:35
投稿者: cxm

以前にこのコーナーで教えていただいたコードですが
Ctrlキーが押されていることで貼り付け方法を変えるという分岐をする方法をご指導ください。
 
'右クリック〜右クリックコピー...ThisWorkbookモジュールに↓。
Private Sub Workbook_SheetBeforeRightClick _
            (ByVal sh As Object _
           , ByVal Target As Range _
           , Cancel As Boolean)
    'シートと範囲限定
'If ActiveSheet.Index = 7 Then’
If Intersect(Target, sh.Range("A1:G300")) Is Nothing Then
        'Exit Sub '範囲
Else
    ' 本来の右クリックの機能を無効にする
    Cancel = True
 
    ' コピーモードの場合
    If Application.CutCopyMode = xlCopy Then
On Error Resume Next
   '******
' ' 値のみ貼り付けをする
' Target.PasteSpecial xlPasteValues
' Target.PasteSpecial -4122
    '******
        ' 値・フォント色・書式の貼り付けをする
        Target.PasteSpecial xlPasteAll
        'すべてを貼り付ける
    '******
        Application.CutCopyMode = False
On Error GoTo 0
    ' コピーモード以外の場合
    Else
        ' コピーする
        Target.Copy
    End If
End If
'End If
End Sub ' 右クリック〜右クリックコピーここまで↑。

回答
投稿日時: 20/11/09 13:19:00
投稿者: simple

「VBA コントロールキーの押し下げを感知する」などと検索してヒットする
「VBAで押されたキーボードを取得する方法」
https://liclog.net/getasynckeystate-function-vba-macro-catia-v5/
が参考になるでしょう。
 
API宣言は、標準モジュールに書いてください。
その上で、例えば

       Const KEY_PRESSED = -32768
        If (GetAsyncKeyState(vbKeyControl) And KEY_PRESSED) = KEY_PRESSED Then
            MsgBox "Ctrlキーが押し下げられています"
        End If
などと使えます。

投稿日時: 20/11/09 17:38:59
投稿者: cxm

Option Explicit
'------------------------------------------------------------------標準モジュールに宣言------↓'
#If Win64 Then
    Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer
#Else
    Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer
#End If
 
Function PressCtrl() As Boolean
    Const KEY_PRESSED = -32768
    PressCtrl = (GetAsyncKeyState(vbKeyControl) And KEY_PRESSED) = KEY_PRESSED
End Function
 
'-------------------------------------------------------------------標準モジュールに宣言-----↑'
'------------------------------------ThisWorkBook内に____________________↓'
If Intersect(Target, sh.Range("A1:G300")) Is Nothing Then
        'Exit Sub '範囲
Else
    ' 本来の右クリックの機能を無効にする
    Cancel = True
 
    ' コピーモードの場合
    If Application.CutCopyMode = xlCopy Then
     
On Error Resume Next
    
  Const KEY_PRESSED = -32768
    If (GetAsyncKeyState(vbKeyControl) And KEY_PRESSED) = KEY_PRESSED Then
' MsgBox "Ctrlキーが押し下げられている-Tlue"
' ' 値のみ貼り付けをする
         Target.PasteSpecial xlPasteValues
' Target.PasteSpecial -4122
    Else
' MsgBox "Ctrlキーが押し下げられていない-False"
        ' 値・フォント色・書式の貼り付けをする
        Target.PasteSpecial xlPasteAll
        'すべてを貼り付ける
    End If
        Application.CutCopyMode = False
On Error GoTo 0
 
    ' コピーモード以外の場合
    Else
        ' コピーする
        Target.Copy
    End If
End If
'End If
End Sub ' 右クリック〜右クリックコピーここまで↑。
 
上記のよう記述で、思いの分岐ができているようです。

回答
投稿日時: 20/11/09 21:08:21
投稿者: simple

対応できているなら結構ですね。
 
ところで、Function PressCtrl()というのは定義しただけですか?
使わないと無駄になってしまうのでは?
 
また、On Error Resume Nextとかはどんな狙いなんですか?
必要なんですか?
 
なお、インデントにもう少し神経を使われた方が可読性が高まると思いますが、いかがですか?

投稿日時: 20/11/10 14:00:23
投稿者: cxm

simpleさん ご指導ありがとうございます
皆さんにいただいた知恵の切り貼りですみません
 
'------------------------------------ThisWorkBook内に____________________↓'
If Intersect(Target, sh.Range("A1:G300")) Is Nothing Then
        'Exit Sub '範囲
Else
    ' 本来の右クリックの機能を無効にする
    Cancel = True
    ' コピーモードの場合
  If Application.CutCopyMode = xlCopy Then
    
    If PressCtrl = True Then
        ' MsgBox "Ctrlキーが押し下げられている-Tlue
        ' 値・フォント色・書式のすべてを貼り付ける
        Target.PasteSpecial xlPasteAll
         
    Else
        ' MsgBox "Ctrlキーが押し下げられていない-False"
        ' 値のみ貼り付けをする"
        Target.PasteSpecial xlPasteValues '値のみ
        ' 値・フォント色の貼り付けをする
        ' Target.PasteSpecial -4122
    End If
   
        Application.CutCopyMode = False
 
     ' コピーモード以外の場合
    Else
        ' コピーする
        Target.Copy
  End If
End If
End Sub
上記のように変更しました
simpleさんの記述はPressCtrl宣言無しでも動作しますね
 

回答
投稿日時: 20/11/10 14:27:59
投稿者: simple

結構ですね。
 
私ならこんな書き方をします。

Private Sub Workbook_SheetBeforeRightClick _
        (ByVal sh As Object, _
         ByVal Target As Range, _
         Cancel As Boolean)
    If Intersect(Target, sh.Range("A1:G300")) Is Nothing Then Exit Sub
    Cancel = True
    If Application.CutCopyMode = xlCopy Then
        If PressCtrl = True Then    'Ctrlキーが押し下げられていたら
            Target.PasteSpecial xlPasteAll
        Else
            Target.PasteSpecial xlPasteValues
        End If
        Application.CutCopyMode = False
    Else
        Target.Copy
    End If
End Sub

投稿日時: 20/11/10 22:00:45
投稿者: cxm

simpleさん ご指導ありがとうございました
Shiftキーも宣言して追加してみました
他にもキーも割り当てれば面白そうです
おかげさまで、出来ることが広がりました。
 
Private Sub Workbook_SheetBeforeRightClick _
        (ByVal sh As Object, _
         ByVal Target As Range, _
         Cancel As Boolean)
    If Intersect(Target, sh.Range("A1:G300")) Is Nothing Then Exit Sub
    Cancel = True
    If Application.CutCopyMode = xlCopy Then
        If PressCtrl = True Then 'Ctrlキーが押し下げられていたら
            Target.PasteSpecial xlPasteAll ’すべて
      ElseIf PressShift = True Then  ’Shiftキーが押し下げられたら
          Target.PasteSpecial xlPasteFormulasAndNumberFormats  ’数式と数値の書式
        Else
            Target.PasteSpecial xlPasteValues ’値のみ
        End If
        Application.CutCopyMode = False
    Else
        Target.Copy
    End If
End Sub