Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

Курс видеоуроков КРЭКЕРСТВО + ПРОГРАММИРОВАНИЕ 2017
(актуальность: апрель 2017)
Свежие инструменты, новые видеоуроки!

  • 400+ видеоуроков
  • 800 инструментов
  • 100+ свежих книг и статей

УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Получение информации о классе и об окне



 unit InternF;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, ExtCtrls, Buttons;
 
 type
   TFormInternal = class(TForm)
     Panel1: TPanel;
     SpeedChoose: TSpeedButton;
     LabelTarget: TLabel;
     Splitter1: TSplitter;
     MemoClass: TMemo;
     MemoWin: TMemo;
     CheckDrag: TCheckBox;
     procedure FormCreate(Sender: TObject);
     procedure FormResize(Sender: TObject);
     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
       Y: Integer);
     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
     procedure SpeedChooseMouseDown(Sender: TObject;
       Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
   public
     procedure UpdateData (hWnd: THandle);
     function GetClassStyles (Style: Cardinal): string;
     function GetWinStyles (Style: Cardinal): string;
     function GetWinExStyles (Style: Cardinal): string;
   private
     Capture: Boolean;
   end;
 
 var
   FormInternal: TFormInternal;
 
 implementation
 
 {$R *.DFM}
 
 function TFormInternal.GetClassStyles (Style: Cardinal): string;
 begin
   Result := '';
   if (cs_bytealignclient and style) = cs_bytealignclient then
     Result := Result + 'ByteAlignClient ';
   if (cs_bytealignwindow and style) = cs_bytealignwindow then
     Result := Result + 'cs_bytealignwindow';
   if (cs_classdc and style) = cs_classdc then
     Result := Result + 'ClassDC ';
   if (cs_dblclks and style) = cs_dblclks then
     Result := Result + 'DblClks ';
   if (cs_globalclass and style) = cs_globalclass then
     Result := Result + 'GlobalClass ';
   if (cs_hredraw and style) = cs_hredraw then
     Result := Result + 'HRedraw ';
   if (cs_noclose and style) = cs_noclose then
     Result := Result + 'NoClose ';
   if (cs_owndc and style) = cs_owndc then
     Result := Result + 'OwnDc ';
   if (cs_parentdc and style) = cs_parentdc then
     Result := Result + 'ParentDc ';
   if (cs_savebits and style) = cs_savebits then
     Result := Result + 'SaveBits ';
   if (cs_vredraw and style) = cs_vredraw then
     Result := Result + 'VRedraw ';
 end;
 
 function TFormInternal.GetWinStyles (Style: Cardinal): string;
 begin
   // show the kind of window
   if (ws_child and style) = ws_child then
     Result := 'Child '
   else if (ws_popup and style) = ws_popup then
     Result := 'Popup '
   else
     Result := 'Overlapped ';
   // borders
   if (ws_border and style) = ws_border then
     Result := Result + 'Border ';
   if (ws_caption and style) = ws_caption then
     Result := Result + 'Caption ';
   if (ws_thickframe and style) = ws_thickframe then
     Result := Result + 'ThickFrame ';
   if (ws_dlgframe and style) = ws_dlgframe then
     Result := Result + 'DlgFrame ';
   // border buttons
   if (ws_maximizebox and style) = ws_maximizebox then
     Result := Result + 'MaximizeBox ';
   if (ws_minimizebox and style) = ws_minimizebox then
     Result := Result + 'MinimizeBox ';
   if (ws_sysmenu and style) = ws_sysmenu then
     Result := Result + 'SysMenu ';
   // scrollbars
   if (ws_hscroll and style) = ws_hscroll then
     Result := Result + 'HScroll ';
   if (ws_vscroll and style) = ws_vscroll then
     Result := Result + 'VScroll ';
   // clipping
   if (ws_clipchildren and style) = ws_clipchildren then
     Result := Result + 'ClipChildren ';
   if (ws_clipsiblings and style) = ws_clipsiblings then
     Result := Result + 'ClipSiblings ';
   // initial status information
   if (ws_disabled and style) = ws_disabled then
     Result := Result + 'Disabled ';
   if (ws_group and style) = ws_group then
     Result := Result + 'Group ';
   if (ws_maximize and style) = ws_maximize then
     Result := Result + 'Maximize ';
   if (ws_minimize and style) = ws_minimize then
     Result := Result + 'Minimize ';
   if (ws_tabstop and style) = ws_tabstop then
     Result := Result + 'TabStop ';
   if (ws_visible and style) = ws_visible then
     Result := Result + 'Visible ';
   // note: controls styles are not supported
 end;
 
 function TFormInternal.GetWinExStyles (style: Cardinal): string;
 begin
   Result := '';
   // add the extended styles
   if (ws_ex_acceptfiles and style) = ws_ex_acceptfiles then
     Result := Result + 'AcceptFiles ';
   if (ws_ex_appwindow and style) = ws_ex_appwindow then
     Result := Result + 'AppWindow ';
   if (ws_ex_mdichild and style) = ws_ex_mdichild then
     Result := Result + 'MdiChild ';
   if (ws_ex_noparentnotify and style) = ws_ex_noparentnotify then
     Result := Result + 'NoParentNotify ';
   if (ws_ex_contexthelp and style) = ws_ex_contexthelp then
     Result := Result + 'ContextHelp ';
   if (ws_ex_controlparent and style) = ws_ex_controlparent then
     Result := Result + 'ControlParent ';
   if (ws_ex_topmost and style) = ws_ex_topmost then
     Result := Result + 'TopMost ';
   if (ws_ex_transparent and style) = ws_ex_transparent then
     Result := Result + 'Transparent ';
 
   // border - edge styles
   if (ws_ex_clientedge and style) = ws_ex_clientedge then
     Result := Result + 'ClientEdge ';
   if (ws_ex_staticedge and style) = ws_ex_staticedge then
     Result := Result + 'StaticEdge ';
   if (ws_ex_dlgmodalframe and style) = ws_ex_dlgmodalframe then
     Result := Result + 'DlgModalFrame ';
   if (ws_ex_windowedge and style) = ws_ex_windowedge then
     Result := Result + 'WindowEdge ';
   if (ws_ex_palettewindow and style) = ws_ex_palettewindow then
     Result := Result + 'PaletteWindow ';
   if (ws_ex_toolwindow and style) = ws_ex_toolwindow then
     Result := Result + 'ToolWindow ';
 
   // left/right input mode and scrollbars
   if (ws_ex_left and style) = ws_ex_left then
     Result := Result + 'Left ';
   if (ws_ex_leftscrollbar and style) = ws_ex_leftscrollbar then
     Result := Result + 'LeftScrollBar ';
   if (ws_ex_ltrreading and style) = ws_ex_ltrreading then
     Result := Result + 'LtrReading ';
   if (ws_ex_right and style) = ws_ex_right then
     Result := Result + 'Right ';
   if (ws_ex_rightscrollbar and style) = ws_ex_rightscrollbar then
     Result := Result + 'RightScrollBar ';
   if (ws_ex_rtlreading and style) = ws_ex_rtlreading then
     Result := Result + 'RtlReading ';
 end;
 
 function GetCursorName (hCur: THandle): string;
 var
   I: Integer;
 begin
   // default: handle value
   Result := IntToHex (hCur, 16);
   // looks for Delphi cursor
   for I := crHelp to crArrow do
     if Screen.Cursors [I] = hCur then
       Result := CursorToString (I);
 end;
 
 procedure TFormInternal.FormCreate (Sender: TObject);
 begin
   UpdateData (Handle);
 end;
 
 procedure TFormInternal.UpdateData (hWnd: THandle);
 var
   WndClassName, Title: string;
   WndClass: TWndClass;
   hInst, hwndParent: THandle;
 begin
   MemoClass.Lines.BeginUpdate;
   MemoWin.Lines.BeginUpdate;
   try
     SetLength (Title, 100);
     // retrieve the WNDCLASS name
     SetLength (WndClassName, 100);
     hInst := GetWindowLong (hWnd, GWL_HINSTANCE);
     GetClassName (hWnd, PChar (WndClassName), 100);
     GetClassInfo (hInst, PChar (WndClassName), WndClass);
     // show class information
     with WndClass, MemoClass.Lines do
     begin
       Clear;
       Add ('Class Name: ' + WndClassName);
       Add ('Window Procedure: ' + IntToHex (Cardinal (lpfnWndProc), 8));
       Add ('Class Extra Bytes: ' + IntToStr (cbClsExtra));
       Add ('Window Extra Bytes: ' + IntToStr (cbWndExtra));
       Add ('Instance Handle: ' + IntToHex (hInstance, 8));
       GetModuleFileName (hInstance, PChar (Title), 100);
       Add ('Module Name: ' + Title);
       Add ('Icon Handle: ' + IntToHex (hIcon, 8));
       Add ('Cursor: ' + GetCursorName (hCursor));
       Add ('Brush handle: ' + IntToHex (hbrBackground, 8));
       if lpszMenuName <> nil then
         if HiWord (Cardinal(lpszMenuName)) <> 0 then
           Add ('Menu name: ' + PChar (lpszMenuName))
         else
           Add ('Menu ID: ' + IntToStr (LoWord (lpszMenuName)));
       Add (#13);
       Add ('Class styles:');
       Add (GetClassStyles (Style));
     end;
 
     // show window data
     with MemoWin.Lines do
     begin
       Clear;
       GetWindowText (hWnd, PChar (Title), 100);
       Add ('Window Handle: ' + IntToHex (hWnd, 8));
       Add ('  Title: "' + PChar (Title) + '"');
       Add ('Window Procedure: ' + IntToHex (GetWindowLong (hWnd, GWL_WNDPROC), 8));
       Add ('Instance Handle: ' + IntToHex (GetWindowLong (hWnd, GWL_HINSTANCE), 8));
       hwndParent := GetWindowLong (hWnd, GWL_HWNDPARENT);
       Add ('Parent/Owner Window: ' + IntToHex (hwndParent, 8));
       if hwndParent <> 0 then
       begin
         GetWindowText (hwndParent, PChar (Title), 100);
         Add ('  Par/Own Title: "' + PChar (Title) + '"');
       end;
       hwndParent := GetParent (hWnd);
       Add ('Real Parent Window: ' + IntToHex (hwndParent, 8));
       if hwndParent <> 0 then
       begin
         GetWindowText (hwndParent, PChar (Title), 100);
         Add ('  Parent Title: "' + PChar (Title) + '"');
       end;
       if GetParent (hWnd) <> 0 then
         Add ('Child ID: ' + IntToHex (GetWindowLong (hWnd, GWL_ID), 8))
       else
         Add ('Menu Handle: ' + IntToHex (GetWindowLong (hWnd, GWL_ID), 8));
       Add ('User Data: ' + IntToHex (GetWindowLong (hWnd, GWL_USERDATA), 8));
       Add (#13);
       Add ('Window Styles: ' +
         GetWinStyles (GetWindowLong (hWnd, GWL_STYLE)));
       Add (#13);
       Add ('Extended Styles: ' +
         GetWinExStyles (GetWindowLong (hWnd, GWL_EXSTYLE)));
     end;
   finally
     MemoClass.Lines.EndUpdate;
     MemoWin.Lines.EndUpdate;
   end;
 end;
 
 procedure TFormInternal.FormResize(Sender: TObject);
 begin
   // split the area equally
   MemoClass.Width := ClientWidth div 2;
 end;
 
 procedure TFormInternal.FormMouseMove(Sender: TObject;
   Shift: TShiftState; X, Y: Integer);
 var
   hWnd: THandle;
   Title: string;
   Pt: TPoint;
 begin
   if Capture then
   begin
     Pt := Point (X, Y);
     Pt := ClientToScreen (Pt);
     hWnd := WindowFromPoint (Pt);
     if hWnd = 0 then
       Exit;
     SetLength (Title, 100);
     GetWindowText (hWnd, PChar (Title), 100);
     LabelTarget.Caption :=
       'Window: ' + IntToHex (hWnd, 8) +
       ' - "' + string (PChar (Title)) + '"';
     if CheckDrag.Checked then
       UpdateData (hWnd);
   end;
 end;
 
 procedure TFormInternal.FormMouseUp(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 var
   hWnd: THandle;
   Pt: TPoint;
 begin
   if Capture then
   begin
     Pt := Point (X, Y);
     Pt := ClientToScreen (Pt);
     hWnd := WindowFromPoint (Pt);
     if hWnd <> 0 then
       UpdateData (hWnd);
     MouseCapture := False;
     Capture := False;
     // release the speed button
     SpeedChoose.Perform (
       wm_LButtonUp, mk_LButton, 0);
   end;
 end;
 
 procedure TFormInternal.SpeedChooseMouseDown(Sender: TObject;
   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
 begin
   MouseCapture := True;
   Capture := True;
 end;
 
 end.

Загрузить исходный код проекта




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS