Автор: ViktorA
Дата сообщения: 25.01.2007 16:35
Помогите советом плиз.
Есть задачка: MS Excel 97, кропотливо выстроен вид анкеты, предназначенной для последующего сканирования, распознавания, необходимо обработать события нажатия клавиш так, чтобы в текущую ячейку попал 1 й символ и курсор перешел в следующую ячейку, дошел до крайности, не смог решить проще, никак не пойму как обработать event нажатия клавиши е сли нет объекта управления, нашел код управления через API:
'***************************************************************************
'* *
'* MODULE NAME: CHECK KEYBOARD BUFFER *
'* *
'* AUTHOR & DATE: STEPHEN BULLEN, Stephen@oaltd.co.uk *
'* *
'* DESCRIPTION: This module contains an example of using Windows API *
'* calls to check the state of the message buffer. The *
'* example includes a check for "Key down" events, which *
'* are used to stop a loop. The module contains functions*
'* for both 16-bit and 32-bit versions of Windows. *
'* *
'***************************************************************************
Option Base 1
Option Explicit
'********************************************************************
'* DECLARE WINDOWS 16-BIT API CALLS *
'********************************************************************
'Type to hold the x and y coordinates of the mouse pointer
Type POINTAPI16
x As Integer
y As Integer
End Type
'Type to hold the Windows message information
Type MSG16
hWnd As Integer 'the window handle of the app
message As Integer 'the type of message (e.g. keydown, keyup etc)
wParam As Integer 'stores the key code
lParam As Long '?
time As Long 'time when message posted
pt As POINTAPI16 'coordinate of mouse pointer when messahe posted
End Type
'Find the window handle for this instance of Excel
Declare Function FindWindow16 Lib "User" Alias "FindWindow" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Integer
'Look in the message buffer for a message
Declare Function PeekMessage16 Lib "User" Alias "PeekMessage" (lpMsg As MSG16, _
ByVal hWnd As Integer, ByVal wMsgFilterMin As Integer, ByVal wMsgFilterMax As Integer, _
ByVal wRemoveMsg As Integer) As Integer
'Translate the message from a virtual key code to a ASCII code
Declare Function TranslateMessage16 Lib "User" Alias "TranslateMessage" (lpMsg As MSG16) As Integer
'********************************************************************
'* DECLARE WINDOWS 32-BIT API CALLS *
'********************************************************************
'Type to hold the x and y coordinates of the mouse pointer
Type POINTAPI32
x As Long
y As Long
End Type
'Type to hold the Windows message information
Type MSG32
hWnd As Long 'the window handle of the app
message As Long 'the type of message (e.g. keydown, keyup etc)
wParam As Long 'stores the key code
lParam As Long '?
time As Long 'time when message posted
pt As POINTAPI32 'coordinate of mouse pointer when messahe posted
End Type
'Find the window handle for this instance of Excel
Declare Function FindWindow32 Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
'Look in the message buffer for a message
Declare Function PeekMessage32 Lib "USER32" Alias "PeekMessageA" (lpMsg As MSG32, _
ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
'Translate the message from a virtual key code to a ASCII code
Declare Function TranslateMessage32 Lib "USER32" Alias "TranslateMessage" (lpMsg As MSG32) As Long
'********************************************************************
'* Demo procedure to test the keyboard checking function *
'********************************************************************
Sub procTestKey()
Dim iCount As Integer
Dim sKey As String
Application.DisplayStatusBar = True
iCount = 0
While sKey <> ""
'Just loop until a key is pressed
Do
'iCount = iCount + 1
'Application.StatusBar = "Loop: " & iCount & " Press any key to stop."
Application.StatusBar = "Режим ввода данных, для окончания нажмите Esc."
'******************************************
'* INSERT YOUR CODE HERE *
'******************************************
'Call the appropriate routine to check the keyboard buffer
If InStr(1, Application.OperatingSystem, "32") = 0 Then
sKey = funCheckKey16
Else
sKey = funCheckKey32
End If
Loop Until sKey <> ""
'Display the key pressed
'MsgBox "You pressed: " & sKey
If sKey <> "" And sKey <> "" And sKey <> "&" And sKey <> "'" And sKey <> "(" And sKey <> "%" And sKey <> "" And sKey <> "" Then 'Esc BackSpase 4Arrows CapsLock Shift
ActiveCell.Value = sKey
ActiveCell.Offset(0, 1).Select
End If
If sKey = "" Then 'BackSpase
ActiveCell.Value = " "
ActiveCell.Offset(0, -1).Select
ActiveCell.Value = " "
End If
If sKey = "&" Then 'ArrowUp &
ActiveCell.Offset(-1, 0).Select
End If
If sKey = "'" Then 'ArrowRight '
ActiveCell.Offset(0, 1).Select
End If
If sKey = "(" Then 'ArrowDown (
ActiveCell.Offset(1, 0).Select
End If
If sKey = "%" Then 'ArrowLeft %
ActiveCell.Offset(0, -1).Select
End If
Wend
Application.StatusBar = False
End Sub
'***************************************************************************
'* *
'* FUNCTION NAME: CHECK KEYBOARD BUFFER - 16 BIT *
'* AUTHOR & DATE: STEPHEN BULLEN, 9 APRIL 1996 *
'* *
'* DESCRIPTION: This function uses Windows API calls to check if there *
'* are any 'Key down' messages for the application. If *
'* there are some, it returns the key pressed as a string *
'* *
'***************************************************************************
Function funCheckKey16() As String
'Dimension variables
Dim msgMessage As MSG16
Dim iHwnd As Integer
Dim i As Integer
'Dimension Windows API constants
Const WM_CHAR As Integer = &H102
Const WM_KEYDOWN As Integer = &H100
Const PM_REMOVE As Integer = &H1
Const PM_NOYIELD As Integer = &H2
'Default to no key pressed
funCheckKey16 = ""
'Get the window handle of this application
iHwnd = FindWindow16("XLMAIN", Application.Caption)
'See if there are any "Key down" messages
i = PeekMessage16(msgMessage, iHwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE + PM_NOYIELD)
'If so ...
If i <> 0 Then
'... translate the virtual key code to a character code ...
i = TranslateMessage16(msgMessage)
'... and get the character code message
i = PeekMessage16(msgMessage, iHwnd, WM_CHAR, WM_CHAR, PM_REMOVE + PM_NOYIELD)
'Return the character of the key pressed
funCheckKey16 = Chr(msgMessage.wParam)
End If
End Function
'***************************************************************************
'* *
'* FUNCTION NAME: CHECK KEYBOARD BUFFER - 32 BIT *
'* AUTHOR & DATE: STEPHEN BULLEN, 9 APRIL 1996 *
'* *
'* DESCRIPTION: This function uses Windows API calls to check if there *
'* are any 'Key down' messages for the application. If *
'* there are some, it returns the key pressed as a string *
'* *
'***************************************************************************
Function funCheckKey32() As String
'Dimension variables
Dim msgMessage As MSG32
Dim iHwnd As Long
Dim i As Long
'Dimension Windows API constants
Const WM_CHAR As Long = &H102
Const WM_KEYDOWN As Long = &H100
Const PM_REMOVE As Long = &H1
Const PM_NOYIELD As Long = &H2
'Default to no key pressed
funCheckKey32 = ""
'Get the window handle of this application
iHwnd = FindWindow32("XLMAIN", Application.Caption)
'See if there are any "Key down" messages
i = PeekMessage32(msgMessage, iHwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE + PM_NOYIELD)
'If so ...
If i <> 0 Then
'... translate the virtual key code to a character code ...
i = TranslateMessage32(msgMessage)
'... and get the character code message
i = PeekMessage32(msgMessage, iHwnd, WM_CHAR, WM_CHAR, PM_REMOVE + PM_NOYIELD)
'Return the character of the key pressed
funCheckKey32 = Chr(msgMessage.wParam)
End If
End Function
___________________________
работает конечно, но блин неужели нельзя проще?
