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
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
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
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
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
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
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" a écrit dans le message de groupe de di scussion :
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
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" <lecocost...@frite.fr> a écrit dans le message de groupe de di scussion :
e#$Cyo9hJHA.2...@TK2MSFTNGP05.phx.gbl...
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
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" a écrit dans le message de groupe de di scussion :
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
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
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
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