Verrouiller le pavé numérique par vba ...
François
Sur le site de Daniel Josserand, j'ai trouvé une macro pour activer le
verrouillage numérique à l'ouverture d'Excel.
Je voudrais lancer une procédure de ce type à la fin d'une macro (qui
systématiquement me désactive par mystère le blocage).
Je ne sais pas comment l'intégrer, et je n'ai pas trouver comment la
commander par la fonction OnKey ...
Si certains ont une solution pour ce faire, c'est ce que je recherche ...
Merci à tous
François
ci-dessous le code de D.J.
Comment activer le Num(ou Caps) lock à chaque lancement d' Excel?
Private Declare Function SetKeyboardState Lib "User32" _
(kbArray As Byte) As Long
Private Declare Function GetKeyboardState Lib "User32" _
(lpKeyState As Byte) As Long
Sub TestLock()
Dim KeyState(0 To 255) As Byte
GetKeyboardState KeyState(0)
KeyState(&H90) = 1 'Num Lock
'KeyState(&H14) = 1 'Caps Lock
SetKeyboardState KeyState(0)
End Sub
LSteph
En effet, je ne sais pas si c'est exclusif à Vista ou si cela peut
dépendre du type de clavier utilisé, il ne me semblait pas avoir ce pb avant
Exemple
Sendkeys "{HOME}, 1
fonctionne
tandis qu'avec CAPSLOCK NUMLOCK ou SCROLLLOCK
ça marche pas.
--
lSteph
François a écrit :
michdenis
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
' API declarations:
Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetKeyboardState Lib "user32" _
(pbKeyState As Byte) As Long
Private Declare Function SetKeyboardState Lib "user32" _
(lppbKeyState As Byte) As Long
' Constant declarations:
Const VK_NUMLOCK = &H90
Const VK_CAPITAL = &H14
Const VK_SCROLL = &H91
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1
'Verrouille ou déverrouille la touche CapsLock selon
'l'état dans laquelle elle est au moment de l'exécution.
'---------------------------------------
Sub DeVerrouilleCapsLock()
'Cette procédure est suffisante pour une fois
'désactiver Caplock ou la fois suivante l'activer
Dim o As OSVERSIONINFO
Dim NumLockState As Boolean
Dim ScrollLockState As Boolean
Dim CapsLockState As Boolean
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(1)
' CapsLock handling:
CapsLockState = keys(VK_CAPITAL)
' If CapsLockState <> False Then 'Turn capslock on
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then '=== Win95/98
keys(VK_CAPITAL) = 1
SetKeyboardState keys(1)
ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then '=== WinNT
'Simulate Key Press
keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
'Simulate Key Release
keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY _
Or KEYEVENTF_KEYUP, 0
End If
End Sub
'---------------------------------------
'Cette procédure ne fait que déverrouiller la touche CapsLock
'----------------------------------------
Sub VerrouilleCapsLock()
Dim o As OSVERSIONINFO
Dim NumLockState As Boolean
Dim ScrollLockState As Boolean
Dim CapsLockState As Boolean
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
' CapsLock handling:
CapsLockState = keys(VK_CAPITAL)
If CapsLockState <> True Then 'Turn capslock on
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then '=== Win95/98
keys(VK_CAPITAL) = 1
SetKeyboardState keys(0)
ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then '=== WinNT
'Simulate Key Press
keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
'Simulate Key Release
keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY _
Or KEYEVENTF_KEYUP, 0
End If
End If
End Sub
'----------------------------------------
"François" <nos...@nospam.fr> a écrit dans le message de groupe de discussion :
e$mf7$8hJHA...@TK2MSFTNGP06.phx.gbl...
michdenis
Pour NumLock, il s'agit d'adapter... voici
Je l'ai fait pour vous pour verrouiller le numlock :
'évidemment, nécessite les API déjà publiées
'---------------------------------
Sub VerrouilleCapsLock()
Dim o As OSVERSIONINFO
Dim NumLockState As Boolean
Dim ScrollLockState As Boolean
Dim CapsLockState As Boolean
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
' CapsLock handling:
NumLockState = keys(VK_NUMLOCK)
If CapsLockState <> True Then 'Turn capslock on
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then '=== Win95/98
keys(VK_NUMLOCK) = 1
SetKeyboardState keys(0)
ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then '=== WinNT
'Simulate Key Press
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
'Simulate Key Release
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY _
Or KEYEVENTF_KEYUP, 0
End If
End If
End Sub
'---------------------------------
"michdenis" <mich...@hotmail.com> a écrit dans le message de groupe de discussion :
8586510E-BB9D-4C4A...@microsoft.com...
michdenis
a été désactivé... tu peux la remplacer par ceci :
(c'est tout simple ;-)) )
'Déclaration des API dans le haut du module :
Private Declare Function SendInput Lib "user32.dll" _
(ByVal nInputs As Long, pInputs As Any, ByVal cbSize As Long) As Long
Public Declare Function VkKeyScan Lib "user32" Alias "VkKeyScanA" _
(ByVal cChar As Byte) As Integer
Private Type KeyboardInput ' typedef struct tagINPUT {
dwType As Long ' DWORD type;
wVK As Integer ' union {MOUSEINPUT mi;
wScan As Integer ' KEYBDINPUT ki;
dwFlags As Long ' HARDWAREINPUT hi;
dwTime As Long ' };
dwExtraInfo As Long ' }INPUT, *PINPUT;
dwPadding As Currency ' 8 extra bytes, because mouses take more.
End Type
Private Const INPUT_MOUSE As Long = 0
Private Const INPUT_KEYBOARD As Long = 1
Private Const KEYEVENTF_KEYUP As Long = 2
Private m_Data As String
Private m_DatPtr As Long
Private m_Events() As KeyboardInput
Private m_EvtPtr As Long
Dim vbShiftMask As Boolean
Private m_NamedKeys As Collection
Private m_ShiftFlags As Long
Private Const defBufferSize As Long = 1024
Private Sub MySendKeys(Data As String)
Dim i As Long
' Make sure our collection of named keys has been built.
If m_NamedKeys Is Nothing Then
Call BuildNamedKeys
End If
' Clear buffer, reset pointers, and cache send data.
ReDim m_Events(0 To defBufferSize - 1) As KeyboardInput
m_EvtPtr = 0
m_DatPtr = 0
m_Data = Data
' Loop through entire passed string.
Do While m_DatPtr < Len(Data)
' Process next token in data string.
Call DoNext
' Make sure there's still plenty of room in the buffer.
If m_EvtPtr >= (UBound(m_Events) - 24) Then
ReDim Preserve m_Events(0 To (UBound(m_Events) + defBufferSize) - 1)
End If
Loop
' Send the processed string to the foreground window!
If m_EvtPtr > 0 Then
' All events are keyboard based.
For i = 0 To m_EvtPtr - 1
m_Events(i).dwType = INPUT_KEYBOARD
Next i
' m_EvtPtr is 0-based, but nInputs is 1-based.
Debug.Print SendInput(m_EvtPtr, m_Events(0), Len(m_Events(0))),
Debug.Print Err.LastDllError
End If
End Sub
Private Sub DoNext()
Dim this As String
' Advance data pointer, and extract next char.
m_DatPtr = m_DatPtr + 1
this = Mid$(m_Data, m_DatPtr, 1)
' Branch to appropriate helper routine.
If InStr("+^%", this) Then
Call ProcessShift(this)
ElseIf this = "(" Then
Call ProcessGroup
ElseIf this = "{" Then
Call ProcessNamedKey
Else
Call ProcessChar(this)
End If
End Sub
Private Sub ProcessChar(this As String)
Dim vk As Integer
Dim capped As Boolean
' Add input events for single character, taking capitalization
' into account. HiByte will contain the shift state, and LoByte
' will contain the key code.
vk = VkKeyScan(Asc(this))
capped = CBool(ByteHi(vk) And 1)
vk = ByteLo(vk)
Call StuffBuffer(vk, capped)
End Sub
Private Sub ProcessGroup()
Dim EndPtr As Long
Dim this As String
Dim i As Long
' Groups of characters are offered together, surrounded by parenthesis,
' in order to all be modified by shift key(s). We need to dig out the
' remainder of the group, and process each in turn.
EndPtr = InStr(m_DatPtr, m_Data, ")")
' No need to do anything if endgroup immediateyl follows beginning.
If EndPtr > (m_DatPtr + 1) Then
For i = 1 To (EndPtr - m_DatPtr - 1)
this = Mid$(m_Data, m_DatPtr + i, 1)
Call ProcessChar(this)
Next i
' Advance data pointer to closing parenthesis.
m_DatPtr = EndPtr
End If
End Sub
Private Sub ProcessNamedKey()
Dim EndPtr As Long
Dim this As String
Dim pieces() As String
Dim repeat As Long
Dim vk As Integer
Dim capped As Boolean
Dim i As Long
' Groups of characters are offered together, surrounded by braces,
' representing a named keystroke. We need to dig out the actual
' name, and optionally the number of times this keystroke is repeated.
EndPtr = InStr(m_DatPtr, m_Data, "}")
' No need to do anything if endgroup immediately follows beginning.
If EndPtr > (m_DatPtr + 1) Then
' Extract group of characters.
this = Mid$(m_Data, m_DatPtr + 1, EndPtr - m_DatPtr - 1)
' Break into pieces, if possible.
pieces = Split(this, " ")
' Second element, if avail, is number of times to repeat stroke.
If UBound(pieces) > 0 Then repeat = Val(pieces(1))
If repeat < 1 Then repeat = 1
' Attempt to retrieve named keycode, or else retrieve standard code.
vk = GetNamedKey(pieces(0))
If vk = 0 Then
vk = VkKeyScan(Asc(this))
capped = CBool(ByteHi(vk) And 1)
vk = ByteLo(vk)
End If
' Stuff buffer as many times as required.
For i = 1 To repeat
Call StuffBuffer(vk, capped)
Next i
' Advance data pointer to closing parenthesis.
m_DatPtr = EndPtr
End If
End Sub
Private Sub ProcessShift(shiftkey As String)
' Press appropriate shiftkey.
With m_Events(m_EvtPtr)
Select Case shiftkey
Case "+"
.wVK = vbKeyShift
m_ShiftFlags = m_ShiftFlags Or vbShiftMask
Case "^"
.wVK = vbKeyControl
m_ShiftFlags = m_ShiftFlags Or vbCtrlMask
Case "%"
.wVK = vbKeyMenu
m_ShiftFlags = m_ShiftFlags Or vbAltMask
End Select
End With
m_EvtPtr = m_EvtPtr + 1
' Process next set of data
Call DoNext
' Unpress same shiftkey.
With m_Events(m_EvtPtr)
Select Case shiftkey
Case "+"
.wVK = vbKeyShift
m_ShiftFlags = m_ShiftFlags And Not vbShiftMask
Case "^"
.wVK = vbKeyControl
m_ShiftFlags = m_ShiftFlags And Not vbCtrlMask
Case "%"
.wVK = vbKeyMenu
m_ShiftFlags = m_ShiftFlags And Not vbAltMask
End Select
.dwFlags = KEYEVENTF_KEYUP
End With
m_EvtPtr = m_EvtPtr + 1
End Sub
Private Sub StuffBuffer(ByVal vk As Integer, Shifted As Boolean)
Dim vbShiftMask As Boolean
' Only mess with Shift key if not already pressed.
If CBool(m_ShiftFlags And vbShiftMask) = False Then
If Shifted Then
With m_Events(m_EvtPtr)
.wVK = vbKeyShift
End With
m_EvtPtr = m_EvtPtr + 1
End If
End If
' Press and release this key.
With m_Events(m_EvtPtr)
.wVK = vk
End With
m_EvtPtr = m_EvtPtr + 1
With m_Events(m_EvtPtr)
.wVK = vk
.dwFlags = KEYEVENTF_KEYUP
End With
m_EvtPtr = m_EvtPtr + 1
' Only mess with Shift key if not already pressed.
If CBool(m_ShiftFlags And vbShiftMask) = False Then
If Shifted Then
With m_Events(m_EvtPtr)
.wVK = vbKeyShift
.dwFlags = KEYEVENTF_KEYUP
End With
m_EvtPtr = m_EvtPtr + 1
End If
End If
End Sub
Private Function ByteHi(ByVal WordIn As Integer) As Byte
' Lop off low byte with divide. If less than
' zero, then account for sign bit (adding &h10000
' implicitly converts to Long before divide).
If WordIn < 0 Then
ByteHi = (WordIn + &H10000) \ &H100
Else
ByteHi = WordIn \ &H100
End If
End Function
Private Function ByteLo(ByVal WordIn As Integer) As Byte
' Mask off high byte and return low.
ByteLo = WordIn And &HFF
End Function
Private Function GetNamedKey(this As String) As Integer
Dim nRet As Integer
' Try retrieving from collection
On Error Resume Next
GetNamedKey = m_NamedKeys(UCase$(this))
On Error Resume Next
End Function
Private Sub BuildNamedKeys()
' Build collection containing all known named keys.
Set m_NamedKeys = New Collection
With m_NamedKeys
.Add vbKeyBack, "BACKSPACE"
.Add vbKeyBack, "BS"
.Add vbKeyBack, "BKSP"
.Add vbKeyPause, "BREAK"
.Add vbKeyCapital, "CAPSLOCK"
.Add vbKeyDelete, "DELETE"
.Add vbKeyDelete, "DEL"
.Add vbKeyDown, "DOWN"
.Add vbKeyEnd, "END"
.Add vbKeyReturn, "ENTER"
.Add vbKeyReturn, "~"
.Add vbKeyEscape, "ESC"
.Add vbKeyHelp, "HELP"
.Add vbKeyHome, "HOME"
.Add vbKeyInsert, "INS"
.Add vbKeyInsert, "INSERT"
.Add vbKeyLeft, "LEFT"
.Add vbKeyNumlock, "NUMLOCK"
.Add vbKeyPageDown, "PGDN"
.Add vbKeyPageUp, "PGUP"
.Add vbKeyPrint, "PRTSC"
.Add vbKeyRight, "RIGHT"
.Add vbKeyTab, "TAB"
.Add vbKeyUp, "UP"
.Add vbKeyF1, "F1"
.Add vbKeyF2, "F2"
.Add vbKeyF3, "F3"
.Add vbKeyF4, "F4"
.Add vbKeyF5, "F5"
.Add vbKeyF6, "F6"
.Add vbKeyF7, "F7"
.Add vbKeyF8, "F8"
.Add vbKeyF9, "F9"
.Add vbKeyF10, "F10"
.Add vbKeyF11, "F11"
.Add vbKeyF12, "F12"
.Add vbKeyF13, "F13"
.Add vbKeyF14, "F14"
.Add vbKeyF15, "F15"
.Add vbKeyF16, "F16"
End With
End Sub
'Et la commande de remplacement
'-------------------------------
Sub Envoyer_Une_Touche()
Call MySendKeys("{numlock}")
End Sub
'-------------------------------
"LSteph" <lecoc...@frite.fr> a écrit dans le message de groupe de discussion :
e#$Cyo9hJ...@TK2MSFTNGP05.phx.gbl...
michdenis
'Attribute VB_Name = "MSendInput"
' *********************************************************************
' Copyright ©2007 Karl E. Peterson, All Rights Reserved
' http://vb.mvps.org/
' *********************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code without prior written consent.
' *********************************************************************
Je viens de trouver la même procédure sous nom.
"michdenis" <mich...@hotmail.com> a écrit dans le message de groupe de discussion :
FCDC0CF4-F5A8-437D...@microsoft.com...
gmls...@gmail.com
;-))
Tout simple en effet!
Merci!
--
lSteph
> "LSteph" <lecocost...@frite.fr> a écrit dans le message de groupe de discussion :
> e#$Cyo9hJHA.2...@TK2MSFTNGP05.phx.gbl...
François
Ce qui se passe, c'est que c'est une macro avec 4 Userform que j'ai faites
pour le PC de mon frère, qui lui est sous Vista ...
D'où mon problème pour vous répondre, car moi, sous XP, je ne rencontre pas
aucun problème !
Et je ne pourrais le rencontrer que demain, voire dimanche ...
D'ou mon embarras pour vous répondre, surtout quand on ne peut pas
évaluer/intervenir sur la réponse ...
J'espère pouvoir vous donner des précisions vers 11 h GMT DEMAIN
Merci à tous pour votre aide
François
"François" <nos...@nospam.fr> a écrit dans le message de news:
e$mf7$8hJHA...@TK2MSFTNGP06.phx.gbl...