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.
|
Получение информации о классе и об окне
