Verrouiller le pavé numérique par vba ...

Le
François
Bonjour à tous,

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
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
LSteph
Le #18594251
Bonsoir,

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 :
Bonjour à tous,

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





michdenis
Le #18598231
'Declaration API
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" e$mf7$
Bonjour à tous,

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
michdenis
Le #18598471
Désolé, les procédures publiée étaient pour Caplock

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"
'Declaration API
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" e$mf7$
Bonjour à tous,

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
michdenis
Le #18600071
Sous vista, pour des raisons de sécurité, la commande Sendkeys
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" e#$
Bonsoir,

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 :
Bonjour à tous,

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





michdenis
Le #18600381
L'auteur de la procédure publiée est de :

'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"
Désolé, les procédures publiée étaient pour Caplock

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"
'Declaration API
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" e$mf7$
Bonjour à tous,

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
gmlsteph
Le #18601481
Bonjour MD,

;-))
Tout simple en effet!

Merci!

--
lSteph

On 6 fév, 14:52, "michdenis"
Sous vista, pour des raisons de sécurité, la commande Sendkeys
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 tagINP UT {
      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, *PI NPUT;
      dwPadding As Currency         '   8 extra bytes, be cause 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_Eve nts(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 capitalizatio n
      ' into account.  HiByte will contain the shift state, and L oByte
      ' 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 pa renthesis,
      ' 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 begi nning.
      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 br aces,
      ' representing a named keystroke.  We need to dig out the a ctual
      ' 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 begi nning.
      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 repe at 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 vbShiftMa sk
            Case "^"
               .wVK = vbKeyControl
               m_ShiftFlags = m_ShiftFlags Or vbCtrlMas k
            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 vbSh iftMask
            Case "^"
               .wVK = vbKeyControl
               m_ShiftFlags = m_ShiftFlags And Not vbCt rlMask
            Case "%"
               .wVK = vbKeyMenu
               m_ShiftFlags = m_ShiftFlags And Not vbAl tMask
         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" e#$
Bonsoir,

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 p b avant
Exemple
Sendkeys "{HOME}, 1
fonctionne
tandis qu'avec CAPSLOCK NUMLOCK ou SCROLLLOCK
ça marche pas.

--
lSteph

François a écrit :> Bonjour à tous,

> Sur le site de Daniel Josserand, j'ai trouvé une macro pour activer l e
> verrouillage numérique à l'ouverture d'Excel.
> Je voudrais lancer une procédure de ce type à la fin d'une macro (q ui
> 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


François
Le #18606501
Bonjour te merci à tous,

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" e$mf7$
Bonjour à tous,

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





Publicité
Poster une réponse
Anonyme