Attribute VB_Name = "basKeyboard" Option Compare Binary Option Explicit ' Virtual Keys, Standard Set. Note that this enum contains many ' that are not included in KeyCodeConstants Public Enum VIRTUALKEYCODES VK_LBUTTON = vbKeyLButton VK_RBUTTON = vbKeyRButton VK_CANCEL = vbKeyCancel VK_MBUTTON = vbKeyMButton ' NOT contiguous with L & RBUTTON '#if(_WIN32_WINNT >= =&h0500) VK_XBUTTON1 = &H5 ' NOT contiguous with L & RBUTTON VK_XBUTTON2 = &H6 ' NOT contiguous with L & RBUTTON '#End If ' _WIN32_WINNT >= =&h0500 ' * =&h07 : unassigned VK_BACK = vbKeyBack VK_TAB = vbKeyTab ' * =&h0A - =&h0B : reserved VK_CLEAR = vbKeyClear VK_RETURN = vbKeyReturn VK_SHIFT = vbKeyShift VK_CONTROL = vbKeyControl VK_MENU = vbKeyMenu VK_PAUSE = vbKeyPause VK_CAPITAL = vbKeyCapital VK_KANA = &H15 VK_HANGEUL = &H15 ' old name - should be here for compatibility VK_HANGUL = &H15 VK_JUNJA = &H17 VK_FINAL = &H18 VK_HANJA = &H19 VK_KANJI = &H19 VK_ESCAPE = &H1B VK_CONVERT = &H1C VK_NONCONVERT = &H1D VK_ACCEPT = &H1E VK_MODECHANGE = &H1F VK_SPACE = vbKeySpace VK_PRIOR = vbKeyPageUp VK_NEXT = vbKeyPageDown VK_END = vbKeyEnd VK_HOME = vbKeyHome VK_LEFT = vbKeyLeft VK_UP = vbKeyUp VK_RIGHT = vbKeyRight VK_DOWN = vbKeyDown VK_SELECT = vbKeySelect VK_PRINT = vbKeyPrint VK_EXECUTE = vbKeyExecute VK_SNAPSHOT = vbKeySnapshot VK_INSERT = vbKeyInsert VK_DELETE = vbKeyDelete VK_HELP = vbKeyHelp ' VK_0 - VK_9 are the same as ASCII '0' - '9' (=&h30 - =&h39) VK_0 = vbKey0 VK_1 = vbKey1 VK_2 = vbKey2 VK_3 = vbKey3 VK_4 = vbKey4 VK_5 = vbKey5 VK_6 = vbKey6 VK_7 = vbKey7 VK_8 = vbKey8 VK_9 = vbKey9 ' * =&h40 : unassigned ' * VK_A - VK_Z are the same as ASCII 'A' - 'Z' (=&h41 - =&h5A) VK_A = vbKeyA VK_B = vbKeyB VK_C = vbKeyC VK_D = vbKeyD VK_E = vbKeyE VK_F = vbKeyF VK_G = vbKeyG VK_H = vbKeyH VK_I = vbKeyI VK_J = vbKeyJ VK_K = vbKeyK VK_L = vbKeyL VK_M = vbKeyM VK_N = vbKeyN VK_O = vbKeyO VK_P = vbKeyP VK_Q = vbKeyQ VK_R = vbKeyR VK_S = vbKeyS VK_T = vbKeyT VK_U = vbKeyU VK_V = vbKeyV VK_W = vbKeyW VK_X = vbKeyX VK_Y = vbKeyY VK_Z = vbKeyZ VK_LWIN = &H5B VK_RWIN = &H5C VK_APPS = &H5D ' * =&h5E : reserved VK_SLEEP = &H5F VK_NUMPAD0 = vbKeyNumpad0 VK_NUMPAD1 = vbKeyNumpad1 VK_NUMPAD2 = vbKeyNumpad2 VK_NUMPAD3 = vbKeyNumpad3 VK_NUMPAD4 = vbKeyNumpad4 VK_NUMPAD5 = vbKeyNumpad5 VK_NUMPAD6 = vbKeyNumpad6 VK_NUMPAD7 = vbKeyNumpad7 VK_NUMPAD8 = vbKeyNumpad8 VK_NUMPAD9 = vbKeyNumpad9 VK_MULTIPLY = vbKeyMultiply VK_ADD = vbKeyAdd VK_SEPARATOR = vbKeySeparator VK_SUBTRACT = vbKeySubtract VK_DECIMAL = vbKeyDecimal VK_DIVIDE = vbKeyDivide VK_F1 = vbKeyF1 VK_F2 = vbKeyF2 VK_F3 = vbKeyF3 VK_F4 = vbKeyF4 VK_F5 = vbKeyF5 VK_F6 = vbKeyF6 VK_F7 = vbKeyF7 VK_F8 = vbKeyF8 VK_F9 = vbKeyF9 VK_F10 = vbKeyF10 VK_F11 = vbKeyF11 VK_F12 = vbKeyF12 VK_F13 = vbKeyF13 VK_F14 = vbKeyF14 VK_F15 = vbKeyF15 VK_F16 = vbKeyF16 VK_F17 = &H80 VK_F18 = &H81 VK_F19 = &H82 VK_F20 = &H83 VK_F21 = &H84 VK_F22 = &H85 VK_F23 = &H86 VK_F24 = &H87 ' * =&h88 - =&h8F : unassigned VK_NUMLOCK = vbKeyNumlock VK_SCROLL = vbKeyScrollLock ' * NEC PC-9800 kbd definitions VK_OEM_NEC_EQUAL = &H92 ' '=' key on numpad ' * Fujitsu/OASYS kbd definitions VK_OEM_FJ_JISHO = &H92 ' 'Dictionary' key VK_OEM_FJ_MASSHOU = &H93 ' 'Unregister word' key VK_OEM_FJ_TOUROKU = &H94 ' 'Register word' key VK_OEM_FJ_LOYA = &H95 ' 'Left OYAYUBI' key VK_OEM_FJ_ROYA = &H96 ' 'Right OYAYUBI' key ' * =&h97 - =&h9F : unassigned ' * VK_L* & VK_R* - left and right Alt, Ctrl and Shift virtual keys. ' * Used only as parameters to GetAsyncKeyState() and GetKeyState(). ' * No other API or message will distinguish left and right keys in this way. VK_LSHIFT = &HA0 VK_RSHIFT = &HA1 VK_LCONTROL = &HA2 VK_RCONTROL = &HA3 VK_LMENU = &HA4 VK_RMENU = &HA5 '#if(_WIN32_WINNT >= =&h0500) VK_BROWSER_BACK = &HA6 VK_BROWSER_FORWARD = &HA7 VK_BROWSER_REFRESH = &HA8 VK_BROWSER_STOP = &HA9 VK_BROWSER_SEARCH = &HAA VK_BROWSER_FAVORITES = &HAB VK_BROWSER_HOME = &HAC VK_VOLUME_MUTE = &HAD VK_VOLUME_DOWN = &HAE VK_VOLUME_UP = &HAF VK_MEDIA_NEXT_TRACK = &HB0 VK_MEDIA_PREV_TRACK = &HB1 VK_MEDIA_STOP = &HB2 VK_MEDIA_PLAY_PAUSE = &HB3 VK_LAUNCH_MAIL = &HB4 VK_LAUNCH_MEDIA_SELECT = &HB5 VK_LAUNCH_APP1 = &HB6 VK_LAUNCH_APP2 = &HB7 '#End If ' _WIN32_WINNT >= =&h0500 ' * =&hB8 - =&hB9 : reserved VK_OEM_1 = &HBA ' ';:' for US VK_OEM_PLUS = &HBB ' '+' any country VK_OEM_COMMA = &HBC ' ',' any country VK_OEM_MINUS = &HBD ' '-' any country VK_OEM_PERIOD = &HBE ' '.' any country VK_OEM_2 = &HBF ' '/?' for US VK_OEM_3 = &HC0 ' '`~' for US ' * =&hC1 - =&hD7 : reserved ' * =&hD8 - =&hDA : unassigned VK_OEM_4 = &HDB ' '[{' for US VK_OEM_5 = &HDC ' '\|' for US VK_OEM_6 = &HDD ' ']}' for US VK_OEM_7 = &HDE ' ''"' for US VK_OEM_8 = &HDF ' * =&hE0 : reserved ' * Various extended or enhanced keyboards VK_OEM_AX = &HE1 ' 'AX' key on Japanese AX kbd VK_OEM_102 = &HE2 ' "<>" or "\|" on RT 102-key kbd. VK_ICO_HELP = &HE3 ' Help key on ICO VK_ICO_00 = &HE4 ' 00 key on ICO VK_PROCESSKEY = &HE5 VK_ICO_CLEAR = &HE6 '#if(_WIN32_WINNT >= =&h0500) VK_PACKET = &HE7 '#End If ' _WIN32_WINNT >= =&h0500 ' * =&hE8 : unassigned ' * Nokia/Ericsson definitions VK_OEM_RESET = &HE9 VK_OEM_JUMP = &HEA VK_OEM_PA1 = &HEB VK_OEM_PA2 = &HEC VK_OEM_PA3 = &HED VK_OEM_WSCTRL = &HEE VK_OEM_CUSEL = &HEF VK_OEM_ATTN = &HF0 VK_OEM_FINISH = &HF1 VK_OEM_COPY = &HF2 VK_OEM_AUTO = &HF3 VK_OEM_ENLW = &HF4 VK_OEM_BACKTAB = &HF5 VK_ATTN = &HF6 VK_CRSEL = &HF7 VK_EXSEL = &HF8 VK_EREOF = &HF9 VK_PLAY = &HFA VK_ZOOM = &HFB VK_NONAME = &HFC VK_PA1 = &HFD VK_OEM_CLEAR = &HFE ' * =&hFF : reserved End Enum Public Enum KnownCodePages CP_ACP = 0 CP_OEMCP = 1 CP_MACCP = 2 CP_SYMBOL = 42 OEM_UnitedStates = 437 Arabic_ASMO708 = 708 Arabic_DOS = 720 Greek_DOS = 737 Baltic_DOS = 775 WesternEuropean_DOS = 850 Central_European_DOS = 852 Icelandic_DOS = 861 Hebrew_DOS = 862 Cyrillic_DOS = 866 Greek_DOS_Modern = 869 Thai_Windows = 874 IBM_EBCDIC_GreekModern = 875 Japanese_ShiftJIS = 932 Chinese_Simplified_GB2312 = 936 Korean = 949 Chinese_Traditional_Big5 = 950 Unicode = 1200 Unicode_BigEndian = 1201 Central_European_Windows = 1250 Cyrillic_Windows = 1251 WesternEuropean_Windows = 1252 Greek_Windows = 1253 Turkish_Windows = 1254 Hebrew_Windows = 1255 Arabic_Windows = 1256 Baltic_Windows = 1257 Vietnamese_Windows = 1258 Korean_Johab = 1361 WesternEuropean_Mac = 10000 Japanese_Mac = 10001 Arabic_Mac = 10004 Greek_Mac = 10006 Cyrillic_Mac = 10007 Latin2_Mac = 10029 Turkish_Mac = 10081 Chinese_Traditional_CNS = 20000 Chinese_Traditional_Eten = 20002 WesternEuropean_IA5 = 20105 German_IA5 = 20106 Swedish_IA5 = 20107 Norwegian_IA5 = 20108 US_ASCII = 20127 Cyrillic_KOI8R = 20866 Cyrillic_KOI8U = 21866 WesternEuropean_ISO = 28591 Central_European_ISO = 28592 Baltic_ISO = 28594 Cyrillic_ISO = 28595 Arabic_ISO = 28596 Greek_ISO = 28597 Latin3_ISO = 28593 Hebrew_ISO_Visual = 28598 Turkish_ISO = 28599 Latin9_ISO = 28605 Europa = 29001 Hebrew_ISO_Logical = 38598 UserDefined = 50000 AutoSelect = 50001 Japanese_JIS = 50220 Japanese_JIS_Allow1byteKana = 50221 Japanese_JIS_Allow1byteKanaSOSI = 50222 Korean_ISO = 50225 Japanese_AutoSelect = 50932 Chinese_Simplified_AutoSelect = 50936 Korean_AutoSelect = 50949 Chinese_Traditional_Auto_Select = 50950 Cyrillic_Auto_Select = 51251 Greek_AutoSelect = 51253 Arabic_AutoSelect = 51256 Japanese_EUC = 51932 Chinese_Simplified_EUC = 51936 Korean_EUC = 51949 Chinese_Simplified_HZ = 52936 Unicode_UTF7 = 65000 Unicode_UTF8 = 65001 End Enum Public Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long Public Declare Function ToAsciiEx Lib "user32" (ByVal uVirtKey As Long, ByVal uScanCode As Long, lpKeyState As Byte, ByVal lpChar As Long, ByVal uFlags As Long, ByVal dwhkl As Long) As Long Public Declare Function ToUnicodeEx Lib "user32" (ByVal uVirtKey As Long, ByVal uScanCode As Long, lpKeyState As Byte, ByVal pwszBuff As Long, ByVal cchBuff As Long, ByVal wFlags As UINT, ByVal dwhkl As Long) As Long Public Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long Public Enum MB_FLAGS MB_PRECOMPOSED = &H1& ' use precomposed chars MB_COMPOSITE = &H2& ' use composite chars MB_USEGLYPHCHARS = &H4& ' use glyph chars, not ctrl chars MB_ERR_INVALID_CHARS = &H8& ' error for invalid chars End Enum Public Enum WC_FLAGS WC_DEFAULTCHECK = &H100& ' check for default char WC_COMPOSITECHECK = &H200& ' convert composite to precomposed WC_DISCARDNS = &H10& ' discard non-spacing chars WC_SEPCHARS = &H20& ' generate separate chars WC_DEFAULTCHAR = &H40& ' replace w/ default char End Enum Private Declare Function GetACP Lib "kernel32" () As Long Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As KnownCodePages, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As KnownCodePages, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long Private Const LOCALE_IDEFAULTCODEPAGE = &HB Private Const LOCALE_IDEFAULTANSICODEPAGE = &H1004 Private Declare Function GetLocaleInfoA Lib "kernel32" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long Public Function HIWORD(ByVal lDWord As Long) As Integer HIWORD = (lDWord And &HFFFF0000) \ (2 ^ 16) End Function Public Function LOWORD(ByVal lDWord As Long) As Integer LOWORD = lDWord And &HFFFF& End Function Public Function ToCharacterEx(ByVal KeyCode As KeyCodeConstants, hKL As Long) As String Dim stBuff As String Dim cch As Long Dim cpg As Long Dim rgvkc(0 To 255) As Byte stBuff = String$(10, vbNullChar) Call GetKeyboardState(rgvkc(0)) If UnicodeSystem Then cch = ToUnicodeEx(KeyCode, 0, rgvkc(0), StrPtr(stBuff), Len(stBuff), 0, hKL) If cch = -1 Then cch = 2 ToCharacterEx = Left$(stBuff, cch) Else cch = ToAsciiEx(KeyCode, 0, rgvkc(0), StrPtr(stBuff), 0, hKL) If cch = -1 Then cch = 2 cpg = CpgFromLcid(LOWORD(hKL)) stBuff = Left$(stBuff, cch) ToCharacterEx = AToW(stBuff, cpg) End If End Function '-------------------------------------- ' AToW ' ' Converts a multibyte string to a Unicode (UCS-2) string '-------------------------------------- Public Function AToW(ByVal st As String, Optional ByVal CodePage As KnownCodePages = CP_ACP, Optional lFlags As MB_FLAGS = 0) As String Dim stBuffer As String Dim cwch As Long Dim pwz As Long Dim pwzBuffer As Long ' the buffer is always 2 bytes, as Windows Unicode is always ' two bytes per character stBuffer = String$((Len(st) + 1) * 2, vbNullChar) pwz = StrPtr(st) pwzBuffer = StrPtr(stBuffer) cwch = MultiByteToWideChar(CodePage, lFlags, pwz, -1, pwzBuffer, Len(stBuffer)) If cwch = 0 Then Err.Raise vbObjectError Or 1000, , "MultiByteToWideChar call failed with Error: " & Err.LastDllError Else AToW = Left$(stBuffer, cwch - 1) End If End Function '-------------------------------------- ' WToA ' ' Converts a Unicode (UCS-2) string to a multibyte string '-------------------------------------- Public Function WToA(ByVal st As String, Optional ByVal CodePage As KnownCodePages = CP_ACP, Optional lFlags As WC_FLAGS = 0) As String Dim stBuffer As String Dim cbch As Long Dim cwch As Long Dim pwz As Long Dim pwzBuffer As Long Dim lpUsedDefaultChar As Long ' Set the buffer size according to the codepage stBuffer = String$((Len(st) * cbch) + 1, vbNullChar) pwz = StrPtr(st) cwch = WideCharToMultiByte(CodePage, lFlags, pwz, -1, 0&, 0&, ByVal 0&, ByVal 0&) pwzBuffer = StrPtr(stBuffer) cwch = WideCharToMultiByte(CodePage, lFlags, pwz, -1, pwzBuffer, Len(stBuffer), ByVal 0&, ByVal 0&) If cwch = 0 Then Err.Raise vbObjectError Or 1000, , "WideCharToMultiByte call failed with Error: " & Err.LastDllError Else WToA = Left$(stBuffer, cwch - 1) End If End Function '---------------------------------------------------------------------------------------- ' CpgFromLcid '---------------------------------------------------------------------------------------- Public Function CpgFromLcid(lcid As Long) As Long Dim cwc As Long Dim stBuffer As String stBuffer = String$(10, vbNullChar) cwc = GetLocaleInfoA(lcid, LOCALE_IDEFAULTANSICODEPAGE, stBuffer, Len(stBuffer)) If cwc = 0 Then cwc = GetLocaleInfoA(lcid, LOCALE_IDEFAULTCODEPAGE, stBuffer, Len(stBuffer)) End If If cwc > 0 Then CpgFromLcid = Val(Left$(stBuffer, cwc - 1)) Else CpgFromLcid = CP_ACP End If End Function