excel vba disable print screen

J

joseso

New Member
Joined
Nov 19, 2017
Messages
13
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:
Code: 
[/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:
Code: 
[/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]

 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
Sort by date Sort by votes


CMIIW...PtrSafe is for MS Office 64 bit, maybe yours MS Office 32 bit.


ThisWorkbook
Code: 
[SIZE=3][COLOR=#0000cd][FONT=arial narrow]Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    UnsetKeyboardHook
End Sub

Private Sub Workbook_Open()
    SetKeyboardHook
End Sub[/FONT][/COLOR][/SIZE]

Module
Code: 
[SIZE=3][COLOR=#0000cd][FONT=arial narrow]#If VBA7 Then
        Private Declare [/FONT][/COLOR][COLOR=#ff0000][FONT=arial narrow]PtrSafe [/FONT][/COLOR][COLOR=#0000cd][FONT=arial narrow]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 [/FONT][/COLOR][COLOR=#ff0000][FONT=arial narrow]PtrSafe [/FONT][/COLOR][COLOR=#0000cd][FONT=arial narrow]Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
        Private Declare [/FONT][/COLOR][COLOR=#ff0000][FONT=arial narrow]PtrSafe [/FONT][/COLOR][COLOR=#0000cd][FONT=arial narrow]Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
        Private Declare [/FONT][/COLOR][COLOR=#ff0000][FONT=arial narrow]PtrSafe [/FONT][/COLOR][COLOR=#0000cd][FONT=arial narrow]Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Private Declare 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 Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
        Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
        Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If[/FONT][/COLOR][/SIZE][COLOR=#000080][SIZE=2][FONT=arial narrow]
[/FONT][/SIZE][/COLOR]
 
Upvote 0
[QUOTE = lhartono; 4953765]

CMIIW ... O PtrSafe é para o MS Office 64 bit, talvez o seu MS Office 32 bits.


ThisWorkbook
Code: 
[SIZE=3][COLOR=#0000cd][FONT=arial narrow]Option Explicit 

Private Sub Workbook_BeforeClose (Cancelar como booleano) 
    UnsetKeyboardHook 
End Sub 

Private Sub Workbook_Open () 
    SetKeyboardHook 
End Sub[/FONT][/COLOR][/SIZE]
 [/ CODE] 

   Módulo 
[CODE] 

[SIZE=3][COLOR=#0000cd][FONT=arial narrow]# Se VBA7 Então 
        Privado Declare [/FONT][/COLOR][COLOR=#ff0000][FONT=arial narrow]PtrSafe [/FONT][/COLOR][COLOR=#0000cd][FONT=arial narrow]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 [/FONT][/COLOR][COLOR=#ff0000][FONT=arial narrow]PtrSafe[/FONT][/COLOR][COLOR=#0000cd][FONT=arial narrow]Função UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) Como Longo 
        Privado Declare [/FONT][/COLOR][COLOR=#ff0000][FONT=arial narrow]PtrSafe [/FONT][/COLOR][COLOR=#0000cd][FONT=arial narrow]Function CallNextHookEx Lib "user32" (ByVal hHook Como Long, ByVal nCode Como Longo, ByVal wParam Como Long, lParam Como Qualquer) Como Longo 
        Privado Declare [/FONT][/COLOR][COLOR=#ff0000][FONT=arial narrow]PtrSafe [/FONT][/COLOR][COLOR=#0000cd][FONT=arial narrow]Sub CopyMemory Lib "kernel32" Alias ​​"RtlMoveMemory" (Destino como qualquer, Origem como qualquer, comprimento ByVal como longo) 
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
         Private Declare Function SetWindowsHookEx Lib "user32" Alias ​​"SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId Tão Longo) Como Long 
        Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
        Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam como Any) Como Longo 
        Privado Declare Sub CopyMemory Lib "kernel32" Alias ​​"RtlMoveMemory" (Destino como qualquer, fonte como qualquer Longitude ByVal Longo) 
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]   se[/FONT][/COLOR][/SIZE] [/ CODE] [/ QUOTE][COLOR=#000080][SIZE=2][FONT=arial narrow]
[/FONT][/SIZE][/COLOR]


Hi
Yes my system is 64 bits, but still it continues with the error.


I'm going to put the Print of the 1st error, so I added the PtrSafe.


Then the second error appeared, as shown in Print 2.




Error 1

Compile error: The code for this project must be updated for use on a 64-bit system. Review and update the Declare statements, and then mark them with the PtrSafe attribute



[COLOR=#574123][url = [/COLOR] [url]https://drive.google.com/open?id=17YOBimCMnX0WRXHx4QWhncdk46m5C8PL[/url] [COLOR=#574123] [/ img] [/ url] 

[/COLOR]Error 2
Compile Error: Incompatible Types


[COLOR=#574123][url = [/COLOR] [url]https://drive.google.com/open?id=1SweKv6SEXxz27hkl2fpSwgMGlbfsZ3s5[/url] [COLOR=#574123] [/ img] [/ url] [/COLOR]
 
Upvote 0
I tested it on my home computer, and it did not work. But I want it to work on 64 because I'm going to use the company I work for, and they only use 64.
 
Upvote 0
The following should work for all systems 32 as well as 64 its :

Code: 
Option Explicit

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

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private hHook As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare 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 Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private hHook As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

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

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Public Function SetKeyboardHook() As LongPtr
        Dim hInstance As LongPtr
        hInstance = Application.HinstancePtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Public Function SetKeyboardHook() As Long
        Dim hInstance As Long
        hInstance = Application.hInstance
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    If hHook = 0 Then
        hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, hInstance, 0)
        SetKeyboardHook = hHook
    End If
End Function

Public Sub UnsetKeyboardHook()
    Call UnhookWindowsHookEx(hHook)
    hHook = 0
End Sub


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function LowLevelKeyboardProc(ByVal ncode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function LowLevelKeyboardProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim lpllkHookStruct As KBDLLHOOKSTRUCT

    If ncode = HC_ACTION Then
        Call CopyMemory(lpllkHookStruct, ByVal lParam, Len(lpllkHookStruct))
        If lpllkHookStruct.vkCode = VK_PRINTSCREEN Then
            LowLevelKeyboardProc = -1
            Exit Function
        Else
            LowLevelKeyboardProc = CallNextHookEx(hHook, ncode, wParam, lParam)
        End If
    Else
        LowLevelKeyboardProc = CallNextHookEx(hHook, ncode, wParam, lParam)
    End If
    
End Function

Note that setting this keyboard hook in this fashion is very dangerous as any unhandled error while the hook is installed will definitely crash the whole application !! so be careful.

Try doing a search for the PeekMessage API with the wRemoveMsg argument set to PM_REMOVE which although requires running a continious loop in the background is much safer ..Otherwise run the above SetWindowsHookEx code from a seperate workbook.
 
Upvote 0
Jaafar Tribak said:
The following should work for all systems 32 as well as 64 its :

Code: 
Option Explicit

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

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private hHook As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare 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 Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private hHook As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

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

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Public Function SetKeyboardHook() As LongPtr
        Dim hInstance As LongPtr
        hInstance = Application.HinstancePtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Public Function SetKeyboardHook() As Long
        Dim hInstance As Long
        hInstance = Application.hInstance
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    If hHook = 0 Then
        hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, hInstance, 0)
        SetKeyboardHook = hHook
    End If
End Function

Public Sub UnsetKeyboardHook()
    Call UnhookWindowsHookEx(hHook)
    hHook = 0
End Sub


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Function LowLevelKeyboardProc(ByVal ncode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Function LowLevelKeyboardProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim lpllkHookStruct As KBDLLHOOKSTRUCT

    If ncode = HC_ACTION Then
        Call CopyMemory(lpllkHookStruct, ByVal lParam, Len(lpllkHookStruct))
        If lpllkHookStruct.vkCode = VK_PRINTSCREEN Then
            LowLevelKeyboardProc = -1
            Exit Function
        Else
            LowLevelKeyboardProc = CallNextHookEx(hHook, ncode, wParam, lParam)
        End If
    Else
        LowLevelKeyboardProc = CallNextHookEx(hHook, ncode, wParam, lParam)
    End If
    
End Function

Note that setting this keyboard hook in this fashion is very dangerous as any unhandled error while the hook is installed will definitely crash the whole application !! so be careful.

Try doing a search for the PeekMessage API with the wRemoveMsg argument set to PM_REMOVE which although requires running a continious loop in the background is much safer ..Otherwise run the above SetWindowsHookEx code from a seperate workbook.
Click to expand...


Hi Jaafar,
Still not working.
I'll explain better what's happening now.

In the company where I work has two different machines:

When I add the code in the machine (Print Cpu) the code appears (Print Error).
And in the normal desktop this highlight does not appear in the code and does not work. You know what the reason is?

Print Cpu
[url = [url]https://drive.google.com/open?id=1LgXdyJKDU40K9lwe06hqZJ-LG34ccHoh[/URL] [/ img] [/ url]

Print Error
[url = [url]https://drive.google.com/open?id=1fYmxq8slCh0iHEt4-uK3COdWOfDGzKYj[/URL] [/ img] [/ url]

When I click Compile VBAProject the following error appears (Print Newerror)
[url = https://drive.google.com/open?id=1d043wpDa8knaqyz36FI8ECeVKArtJIQS [/ img] [/ url]

This error appears on both machines
 
Upvote 0
Upvote 0
Jaafar Tribak said:
Don't worry about those red lines. They are not compiled in excel editions after excel 2010.


That compile error means that the code doesn't see the lpllkHookStruct Type definition. Are you sure that the whole code I posted (including the declarations at the top) resides in the same standard module ?
Click to expand...


Yes, I added all the code you sent in the same module. I tested the code on my cpu at home that has 32bit and it also did not work ...
 
Upvote 0
joseso said:
Yes, I added all the code you sent in the same module. I tested the code on my cpu at home that has 32bit and it also did not work ...
Click to expand...
It should work .. as a matter of fact, I 've just tested the code on a 32bit windows machine Excel 2007 and worked fine as expected.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
1
Views
398
Bib195
B
A
  • Question Question
Using Hittest with more than one Listview Control
Replies
0
Views
40
AlexanderBB
A
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
861
Jaafar Tribak
Jaafar Tribak
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
728
Jaafar Tribak
Jaafar Tribak
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
368
Minh Tuan VN
M

Forum statistics

Threads
1,224,829
Messages
6,181,224
Members
453,025
Latest member
Hannah_Pham93

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top