VPF::WinHotkeyCtrl и Delphi - Форум программистов

ShiFT

Дата 19.10.2005, 08:31 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 4
Регистрация: 19.10.2005
Где: Екатеринбург

Репутация: нет
Всего: нет

http://rsdn.ru/article/controls/WinHotkeyCtrl.xml
Случайно никто не переделывал под Delphi версию для WinAPI?

у меня вылетает с ошибкой runtime error 216
вот и хотел узнать может у когото получилось

_hunter

Дата 19.10.2005, 10:58 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 8564
Регистрация: 24.6.2003
Где: Europe::Ukraine:: Kiev

Репутация: 9
Всего: 98

переделывать -- не переделывал, но то, что ошибка 216 говорит о том, что ошибка у тебя в 29 строке...

--------------------

Tempora mutantur, et nos mutamur in illis...

ShiFT

Дата 19.10.2005, 11:33 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 4
Регистрация: 19.10.2005
Где: Екатеринбург

Репутация: нет
Всего: нет

Код


// WinHotkey.dpr
program WinHotkey;
uses Windows, Messages, CommCtrl, WinHotkeyCtrl, vkCodes;
{$R WindowsXP.res}
const
  ClsName : PChar  = 'classTestWinHotKeyCtrl';
  appCapt : PChar  = '';
  idcEdit          = 1;
var
  pWnd  : HWND;
  pMsg  : TMsg;
  pCls  : TWndClassEx;
  pEdit : HWND;

function WndProc( wnd: HWnd; msg, wParam: wParam; lParam: lParam): LongInt; stdcall;
begin
  Result := 0;
  case msg of
    wm_quit,
    wm_destroy : begin
      PostQuitMessage( 0);
      Exit;
    end;
  end;
  Result := DefWindowProc( wnd, msg, wparam, lparam);
end;

begin
  with pCls do begin
    cbSize        := sizeof( pCls);
    style         := cs_hredraw or cs_vredraw;
    lpfnWndProc   := @WndProc;
    cbClsExtra    := 0;
    cbWndExtra    := 0;
    hInstance     := HInstance;
    hIcon         := LoadIcon (0, idi_Application);
    hCursor       := LoadCursor( 0, idc_arrow);
    hbrBackground := COLOR_BTNFACE +1;
    lpszMenuName  := nil;
    lpszClassName := ClsName;
  end;
  RegisterClassEx( pCls);

  InitCommonControls();
  pWnd := CreateWindowEx( WS_EX_TOOLWINDOW, ClsName, '', $E0000, 400, 50, 415, 200, $0, 0, hInstance, nil);
  if pWnd = 0 then Halt;

  pEdit := CreateWindowEx( $0, 'edit', '', WS_BORDER or WS_VISIBLE or WS_CHILD, 2,  2, 250, 18, pWnd, idcEdit, hInstance, nil);
  InitWinHotkeyCtrls();
  SubClassWinHotkeyCtrl( pEdit);

  SendMessage( pEdit, wm_setfont, GetStockObject( 12), 0);
  ShowWindow( pWnd, 1);

  while GetMessage( pMsg, 0, 0, 0) do begin
    TranslateMessage( pMsg);
    DispatchMessage( pMsg);
  end;
end.

Код


// vkCodes.pas
unit vkCodes;
interface
uses Windows;
var
  s_pszKeys : array[0..255] of string = (
//...... Много много сторчек с обозначениями Клавишь
  );

function GetKeyName( vkCode: integer): string;
function HotkeyToString( vkCode, fModifiers: Integer; var pBuffer: string): boolean;
function HotkeyToString2(dwHk: DWORD; var pBuffer: string): boolean;

implementation

function GetKeyName( vkCode: integer): string;
begin
  result := '';
  if vkCode > 255 then Exit;
  vkCode := vkCode and $ff;
  result := s_pszKeys[ vkCode];
end;

function HotkeyToString( vkCode, fModifiers: Integer; var pBuffer: string): boolean;
var
  s : string;
begin
  s := '';
  if fModifiers and 8 = 8 then s := 'Win + ' + s;
  if fModifiers and 4 = 4 then s := 'Shift + ' + s;
  if fModifiers and 2 = 2 then s := 'Ctrl + ' + s;
  if fModifiers and 1 = 1 then s := 'Alt + ' + s;
  pBuffer := s + GetKeyName(vkCode);
  result := pBuffer <> '';
end;

function HotkeyToString2(dwHk: DWORD; var pBuffer: string): boolean;
begin
  result := HotkeyToString( LOBYTE( LOWORD( dwHk)), HIBYTE( LOWORD( dwHk)), pBuffer);
end;

end.

Код


// WinHotkeyCtrl.pas
unit WinHotkeyCtrl;
interface
uses Windows, Messages, vkCodes;
const
  WM_KEY           = (WM_USER + 444);
  WH_KEYBOARD_LL   = 13;
type
  PKBDLLHOOKSTRUCT = ^KBDLLHOOKSTRUCT;
  KBDLLHOOKSTRUCT  = record
    vkCode         : DWORD;
    scanCode       : DWORD;
    flags          : DWORD;
    time           : DWORD;
    dwExtraInfo    : ^Integer;
  end;
var
  _wpEditProc      : TFNWndProc = nil;
  _hhookKb         : HHOOK      = 0;
  _hwndWhc         : HWND       = 0;

function  _WinHotkeyCtrlProc( hwnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
function  MAKEWHCDATA(vkCode, fModSet, fModRel, fIsPressed: DWORD): DWORD;
function  InitWinHotkeyCtrls(): boolean;
function  SubClassWinHotkeyCtrl( hwndWhc: HWND): boolean;
function  _LowLevelKeyboardProc( nCode: integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
function  _UninstallKbHook(): boolean;
function  _InstallKbHook( hwndWhc: HWND): boolean;
procedure _SetWhcText( hwndWhc: HWND; dwHk: DWORD);
function  GetWinHotkey( hwndWhc: HWND): DWORD;
procedure SetWinHotkey(hwndWhc: HWND; dwHk: DWORD);

implementation

function MAKEWHCDATA(vkCode, fModSet, fModRel, fIsPressed: DWORD): DWORD;
begin
  result := DWORD(
    (DWORD( BYTE( vkCode     and $ff))       ) or
    (DWORD( BYTE( fModSet    and $ff)) shl  8) or
    (DWORD( BYTE( fModRel    and $ff)) shl 16) or
    (DWORD( BYTE( fIsPressed and $ff)) shl 24)
  );
end;

function InitWinHotkeyCtrls(): boolean;
var
  wcex: WNDCLASSEX;
begin
  result := false;
  wcex.cbSize := sizeof( WNDCLASSEX);
  if not GetClassInfoEx( GetModuleHandle( nil), 'edit', wcex) then
    exit;
  _wpEditProc := wcex.lpfnWndProc;
  result := (_wpEditProc <> nil);
end;

function SubClassWinHotkeyCtrl( hwndWhc: HWND): boolean;
begin
  result := false;
  if hwndWhc = 0 then Exit;
  if _wpEditProc = nil then
    if not InitWinHotkeyCtrls() then
      exit;
  if SetWindowLong( hwndWhc, GWL_WNDPROC, Integer( TFNWndProc( @_WinHotkeyCtrlProc))) = 0 then begin
    MessageBox( 0, 'Error', 'Error', 0);
    halt;
  end;
  SetWinHotkey( hwndWhc, MAKEWHCDATA(0, 0, 0, 0));
  result := true;
end;

function _LowLevelKeyboardProc( nCode: integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
  if (nCode = HC_ACTION) and ((wParam = WM_KEYDOWN) or (wParam = WM_SYSKEYDOWN) or (wParam = WM_KEYUP) or (wParam = WM_SYSKEYUP)) then begin
    PostMessage( _hwndWhc, WM_KEY, PKBDLLHOOKSTRUCT( lParam).vkCode, (wParam and 1));
  end;
  result := 1;
end;

function _UninstallKbHook(): boolean;
var
  fOk : boolean;
begin
  fOk := false;
  if (_hhookKb <> 0) then begin
    fOk := UnhookWindowsHookEx( _hhookKb);
    _hhookKb := 0;
  end;
  _hwndWhc := 0;
  result := fOk;
end;

function _InstallKbHook( hwndWhc: HWND): boolean;
begin
  if _hhookKb <> 0 then
    _UninstallKbHook();
  _hwndWhc := hwndWhc;
  _hhookKb := SetWindowsHookEx( WH_KEYBOARD_LL, _LowLevelKeyboardProc, GetModuleHandle( nil), 0);
  result := (_hhookKb <> 0);
end;

procedure _SetWhcText( hwndWhc: HWND; dwHk: DWORD);
var
  pszText: string;
begin
  if HotKeyToString2( dwHk, pszText) then begin
    if pszText = '' then
      SetWindowText( hwndWhc, 'none')
    else
      SetWindowText( hwndWhc, PChar( pszText))
  end else
    SetWindowText( hwndWhc, 'none');
end;

function GetWinHotkey( hwndWhc: HWND): DWORD;
begin
  result := LOWORD( GetWindowLong( hwndWhc, GWL_USERDATA));
end;

procedure SetWinHotkey(hwndWhc: HWND; dwHk: DWORD);
begin
  SetWindowLong( hwndWhc, GWL_USERDATA, dwHk);
  _SetWhcText( hwndWhc, dwHk);
end;

function _WinHotkeyCtrlProc( hwnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
var
  dwWhcData : DWORD;
  vkCode    : DWORD;
  fModSet   : DWORD;
  fModRel   : DWORD;
  fIsPressed: Boolean;
  fMod      : DWORD;
  fRedraw   : boolean;
begin
  case uMsg of
    WM_KEY: begin
      dwWhcData  := DWORD( GetWindowLong( hwnd, GWL_USERDATA));
      vkCode     := LOBYTE( LOWORD( dwWhcData));
      fModSet    := HIBYTE( LOWORD( dwWhcData));
      fModRel    := LOBYTE( HIWORD( dwWhcData));
      fIsPressed := Boolean( HIBYTE( HIWORD( dwWhcData)));
      fMod       := 0;
      fRedraw    := TRUE;
      case wParam of
        VK_LWIN,
        VK_RWIN:     fMod := MOD_WIN;
        VK_CONTROL,
        VK_LCONTROL,
        VK_RCONTROL: fMod := MOD_CONTROL;
        VK_MENU,
        VK_LMENU,
        VK_RMENU:    fMod := MOD_ALT;
        VK_SHIFT,
        VK_LSHIFT,
        VK_RSHIFT:   fMod := MOD_SHIFT;
      end;
      if fMod > 0 then begin
        if lParam = 0 then begin
          if ( not fIsPressed and (vkCode > 0)) then begin
            fModSet := 0;
            fModRel := 0;
            vkCode  := 0;
          end;
          fModRel := fModRel and not fMod;
        end else begin
          fModRel := fModRel or fMod;
        end;
        if (fIsPressed or (vkCode = 0)) then begin
          if lParam = 0 then begin
            if (fModSet and fMod) = 0 then begin
              fModSet := fModSet or fMod;
            end else
              fRedraw := FALSE;
          end else fModSet := fModSet and not fMod;
        end;
      end else begin
        if (wParam = VK_DELETE) and (fModSet = MOD_CONTROL or MOD_ALT) then begin
          // skip "Ctrl + Alt + Del"
          fModSet := 0;
          fModRel := 0;
          vkCode  := 0;
          fIsPressed := FALSE;
        end else if (wParam = vkCode and lParam) then begin
          fIsPressed := FALSE;
          fRedraw    := FALSE;
        end else begin
          if (not fIsPressed) and (lParam = 0) then begin
            if fModRel and fModSet > 0 then begin
              fModRel := 0;
              fModSet := 0;
            end;
            vkCode     := DWORD( wParam);
            fIsPressed := TRUE;
          end;
        end;
      end;
      dwWhcData := MAKEWHCDATA(vkCode, fModSet, fModRel, DWORD( fIsPressed));
      SetWindowLong(hwnd, GWL_USERDATA, Integer( dwWhcData));
      if fRedraw then _SetWhcText( hwnd, dwWhcData);
    end;
    WM_SETFOCUS : _InstallKbHook( hwnd);
    WM_KILLFOCUS: _UninstallKbHook();
  end;
  result := CallWindowProc( _wpEditProc, hwnd, uMsg, wParam, lParam);
end;

end.

_hunter

Дата 19.10.2005, 12:23 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 8564
Регистрация: 24.6.2003
Где: Europe::Ukraine:: Kiev

Репутация: 9
Всего: 98

код -- это уже хорошо. а где именно ошибка?

--------------------

Tempora mutantur, et nos mutamur in illis...

ShiFT

Дата 19.10.2005, 12:39 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 4
Регистрация: 19.10.2005
Где: Екатеринбург

Репутация: нет
Всего: нет

ХЗ. Ничего не показывает.
Только после запуска Вылетает Ошибка в программе и завершается. из под Делфии тоже самое.
после дебага понял что былетает ошибка после выхода из _WinHotkeyCtrlProc.

и ещё процедура SetWinHotkey почемуто неработает. smile

Albinos_x

Дата 19.10.2005, 15:17 (ссылка)

(нет голосов)

Загрузка ...

Evil Skynet

Профиль
Группа: Комодератор
Сообщений: 3288
Регистрация: 28.5.2004
Где: X-6120400 Y-1 4624650

Репутация: 3
Всего: 108

216 ошибка если я не ошибаюсь - это ошибка доступа к памяти... а пошаговая отладка чего говорит?

--------------------

"Кто владеет информацией, тот владеет миром"
Уинстон Черчилль

ShiFT

Дата 20.10.2005, 05:19 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 4
Регистрация: 19.10.2005
Где: Екатеринбург

Репутация: нет
Всего: нет

нашел методом исключения.

она возникает после включения этой строчки:

Код

SetWindowLong( hwndWhc, GWL_WNDPROC, LongInt( @_WinHotkeyCtrlProc));

а по поводу GWL_WNDPROC из MSDN.

GWL_WNDPROC
Sets a new address for the window procedure.
Windows NT/2000/XP: You cannot change this attribute if the window does not belong to the same process as the calling thread.

но у меня ведь в том же процессе, в том же треде.

Как можно решить эту проблему????

Это сообщение отредактировал(а) ShiFT - 20.10.2005, 05:43

_hunter

Дата 20.10.2005, 14:16 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 8564
Регистрация: 24.6.2003
Где: Europe::Ukraine:: Kiev

Репутация: 9
Всего: 98

"после" в окнах -- понятие очень интересное... в твоем случае это может быть и на вызове _WinHotkeyCtrlProc

Это сообщение отредактировал(а) Girder - 20.10.2005, 19:02

--------------------

Tempora mutantur, et nos mutamur in illis...

Girder

Дата 20.10.2005, 19:04 (ссылка)

(нет голосов)

Загрузка ...

Лентяй 2

Профиль
Группа: Участник Клуба
Сообщений: 1993
Регистрация: 12.5.2004

Репутация: 25
Всего: 155

stdcall

--------------------

Как слышим, так и пишим.
Истина где-то там...

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: WinAPI и системное программирование \| Следующая тема »