excel vba disable print screen

[joseso]

I need to unarchive the Print Screen function of a file.

The file I posted was the same one I found on the internet.
This code works on this file, but when trying to run in the 2013 version it gets in error.

Would anyone know how to solve it?

Thisworkbook:

[/COLOR]Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    UnsetKeyboardHook
End Sub


Private Sub Workbook_Deactivate()
 UnsetKeyboardHook
End Sub


Private Sub Workbook_Open()
    SetKeyboardHook
End Sub


[COLOR=#333333]

Modules:

[/COLOR]Option Explicit

Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long


Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)


Private Const WH_KEYBOARD_LL = &HD


Private Const WM_KEYDOWN = &H100
Private Const WM_SYSKEYDOWN = &H104


Private Const HC_ACTION = 0


Private Const VK_PRINTSCREEN = &H2C


Public Type KBDLLHOOKSTRUCT
    vkCode As Long
    scanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type


Private hHook As Long


Public Function SetKeyboardHook() As Long


    If hHook = 0 Then
        hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, Application.Hinstance, 0)
        SetKeyboardHook = hHook
    End If


End Function


Public Sub UnsetKeyboardHook()


    Call UnhookWindowsHookEx(hHook)
    hHook = 0


End Sub


Private Function LowLevelKeyboardProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


    Dim lpllkHookStruct As KBDLLHOOKSTRUCT


    If nCode = HC_ACTION Then
        Call CopyMemory(lpllkHookStruct, ByVal lParam, Len(lpllkHookStruct))
        
        If lpllkHookStruct.vkCode = VK_PRINTSCREEN Then
            LowLevelKeyboardProc = True
        Else
            LowLevelKeyboardProc = CallNextHookEx(hHook, nCode, wParam, lParam)
        End If
    Else
        LowLevelKeyboardProc = CallNextHookEx(hHook, nCode, wParam, lParam)
    End If
    
End Function


[COLOR=#333333]

 

[joseso]

You are welcome.

I'll post another code using a different approach hoping it will work .

I appreciate your help.
If you have another idea, I'll be grateful.
Thank you

 

[Jaafar Tribak]

Try this and see if it works :

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

#If VBA7 Then
    Private Type MSG
        hwnd As LongPtr
        tMsg As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type

    Private Declare PtrSafe Function RegisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare PtrSafe Function UnregisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
#Else
    Private Type MSG
        hwnd As Long
        tMsg As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
#End If

Private Const PM_REMOVE = &H1
Private Const PM_NOYIELD = &H2
Private Const WM_HOTKEY = &H312
Private Const VK_PRINTSCREEN = &H2C
Private Const MOD_ALT = &H1
Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4

Private bCancel As Boolean

Private Sub Workbook_Open()
    EnablePrintScreen = False
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    EnablePrintScreen = True
End Sub

Private Property Let EnablePrintScreen(ByVal Enable As Boolean)
    bCancel = Enable
    Call UnregisterHotKey(Application.hwnd, &HBFFF&)
    Call UnregisterHotKey(Application.hwnd, &HBFFE&)
    Call UnregisterHotKey(Application.hwnd, &HBFFD&)
    Call UnregisterHotKey(Application.hwnd, &HBFFC&)
    Call UnregisterHotKey(Application.hwnd, &HBFFB&)
    Call UnregisterHotKey(Application.hwnd, &HBFFA&)
    If Enable = False Then
        Call RegisterHotKey(Application.hwnd, &HBFFF&, 0, VK_PRINTSCREEN)
        Call RegisterHotKey(Application.hwnd, &HBFFE&, MOD_ALT, VK_PRINTSCREEN)
        Call RegisterHotKey(Application.hwnd, &HBFFD&, MOD_SHIFT, VK_PRINTSCREEN)
        Call RegisterHotKey(Application.hwnd, &HBFFC&, MOD_CONTROL, VK_PRINTSCREEN)
         Call RegisterHotKey(Application.hwnd, &HBFFB&, MOD_CONTROL + MOD_SHIFT, VK_PRINTSCREEN)
         Call RegisterHotKey(Application.hwnd, &HBFFA&, MOD_CONTROL + MOD_ALT, VK_PRINTSCREEN)
        Call ProcessMessages
    End If
End Property

Private Sub ProcessMessages()
    Dim tMsg As MSG
    Do While Not bCancel
        WaitMessage
        Call PeekMessage(tMsg, Application.hwnd, WM_HOTKEY, WM_HOTKEY, 0)
        DoEvents
    Loop
End Sub

 

[joseso]

Try this and see if it works :

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Type MSG
        hwnd As LongPtr
        tMsg As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type

    Private Declare PtrSafe Function RegisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare PtrSafe Function UnregisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Type MSG
        hwnd As Long
        tMsg As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const PM_REMOVE = &H1
Private Const PM_NOYIELD = &H2
Private Const WM_HOTKEY = &H312
Private Const VK_PRINTSCREEN = &H2C
Private Const MOD_ALT = &H1
Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4

Private bCancel As Boolean

Private Sub Workbook_Open()
    EnablePrintScreen = False
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    EnablePrintScreen = True
End Sub

Private Property Let EnablePrintScreen(ByVal Enable As Boolean)
    bCancel = Enable
    Call UnregisterHotKey(Application.hwnd, &HBFFF&)
    Call UnregisterHotKey(Application.hwnd, &HBFFE&)
    Call UnregisterHotKey(Application.hwnd, &HBFFD&)
    Call UnregisterHotKey(Application.hwnd, &HBFFC&)
    Call UnregisterHotKey(Application.hwnd, &HBFFB&)
    Call UnregisterHotKey(Application.hwnd, &HBFFA&)
    If Enable = False Then
        Call RegisterHotKey(Application.hwnd, &HBFFF&, 0, VK_PRINTSCREEN)
        Call RegisterHotKey(Application.hwnd, &HBFFE&, MOD_ALT, VK_PRINTSCREEN)
        Call RegisterHotKey(Application.hwnd, &HBFFD&, MOD_SHIFT, VK_PRINTSCREEN)
        Call RegisterHotKey(Application.hwnd, &HBFFC&, MOD_CONTROL, VK_PRINTSCREEN)
         Call RegisterHotKey(Application.hwnd, &HBFFB&, MOD_CONTROL + MOD_SHIFT, VK_PRINTSCREEN)
         Call RegisterHotKey(Application.hwnd, &HBFFA&, MOD_CONTROL + MOD_ALT, VK_PRINTSCREEN)
        Call ProcessMessages
    End If
End Property

Private Sub ProcessMessages()
    Dim tMsg As MSG
    Do While Not bCancel
        WaitMessage
        Call PeekMessage(tMsg, Application.hwnd, WM_HOTKEY, WM_HOTKEY, 0)
        DoEvents
    Loop
End Sub

Did not do it again ...
I decided to try the previous code that you had passed, and this time something happened ..
When I tried to paste after giving the Printscreen this message appeared:


"Unable to run the macro" C: \ Users \ Desktop ... "It may not be available in this workbook or all"


And Print did not paste, but after closing the worksheet and opening it again, it did not work anymore. In fact Printscreen has returned to work