Модератор: Модераторы
Снег Север писал(а):Дорогая глупая деточка, если бы ты был способен читать документацию, хотя бы, по фрипаскалю, то узнал бы много для себя нового. Например - о приведении типов.![]()
Ибо и HWnd, и Thandle - это длинные целые числа, и ничего более. В делфи так просто можно подставлять один вместо другого, и без приведения типа - ShowWindow(FindWindow(... .
Alex2013 писал(а):Что то вроде этого ? (Кнопочка Show делает ShowWindows для "чужого окна " )
Capture05_0.7z
В архиве схема (Cap5.sha) моей "временной утилиты"на хайасме но если скачать HiAsm то можно посмотреть код "Кубиков" на паскале для FPC.. (По Ctrl-F )
Зы
Вообще то там все очень просто но мне лень перезагружать комп
(кстати сейчас тут Линукс ( живущий с 11-го мохнатого года! ) загружен - хлиаврщики уймитесь! Разные задачи разные ОС-ы! )..
self.Hide;
self.TrayIcon1.Show;
- Код: Выделить всё
program Test1;
uses
Windows,
SysUtils;
const
AppName = 'Test Pixel';
WM_PAINT = $000F;
WM_DESTROY = $0002;
function SetDownPixel(DC: HDC; X1, Y1,W,H: Integer; Color: COLORREF): COLORREF;
type TRGBArray = Array[0..1] of RGBQUAD;
PRGBArray = ^TRGBArray;
var lpbmi : PBITMAPINFO;
lpTargetBits : Pointer;
Bitmap : HBITMAP;
BB : PRGBArray;
X,Y:Integer;
dwTargetHeaderSize : DWORD;
RGB:RGBQuad;
begin
dwTargetHeaderSize := sizeof ( BITMAPINFO ) + ( W*H * sizeof( RGBQUAD ) );
GetMem (lpbmi, dwTargetHeaderSize);
lpbmi^.bmiHeader.biSize := sizeof (BITMAPINFOHEADER);
lpbmi^.bmiHeader.biWidth := w;
lpbmi^.bmiHeader.biHeight := h;
lpbmi^.bmiHeader.biPlanes := 1;
lpbmi^.bmiHeader.biBitCount := 32;
lpbmi^.bmiHeader.biCompression := BI_RGB;
lpbmi^.bmiHeader.biSizeImage := 0;
lpbmi^.bmiHeader.biXPelsPerMeter := 0;
lpbmi^.bmiHeader.biYPelsPerMeter := 0;
lpbmi^.bmiHeader.biClrUsed := 0;
lpbmi^.bmiHeader.biClrImportant := 0;
With lpbmi^ do BB:=@bmiColors;
For y:=0 to h-1 do
For x:=0 to w-1 do begin
Rgb.rgbBlue:=random(255);
Rgb.rgbGreen:=random(255);
Rgb.rgbRed:=random(255);
BB^[X+(Y*W)]:= rgb;
end;
StretchDIBits(DC, x1, y1, W, h, 0, 0,w,h,BB, lpbmi^,DIB_RGB_COLORS,SRCCOPY);
freemem(lpbmi);
end;
DataBuffer[0,0]:= DIB_RGB_COLORS;
StretchDIBits(DC, x1, y1, W, h, 0, 0, cHeight, cWidth,
@DataBuffer, bmpinfo^, DIB_RGB_COLORS, SRCCOPY);
FreeMem(bmpinfo);
end;
function WindowProc(Window: HWnd; AMessage: UINT; WParam : WPARAM;
LParam: LPARAM): LRESULT; stdcall; export;
var
dc : hdc;
ps : Tpaintstruct;
iy, ix: integer;
r : Trect;
h, w: integer;
tm_pnt: record
beg_,
end_: integer;
end;
begin
WindowProc := 0;
case AMessage of
wm_paint:
begin
dc := BeginPaint(Window, ps);
GetClientRect(Window, r);
tm_pnt.beg_ := GetTickCount();
w := r.right - r.left;
h := r.bottom - r.top;
SetDownPixel(dc,r.left,r.top,W,H,$0000FF);//!!!! "Одним махом семерых побивахом!"
// FillRect(dc,R,$FF00); // банальный FillRect почему-то не сработал разбираться лень .
tm_pnt.end_ := GetTickCount();
with tm_pnt do begin
DrawTextA(dc, pChar(IntToStr(tm_pnt.end_ - tm_pnt.beg_)), -1, r,
DT_SINGLELINE or DT_CENTER or DT_VCENTER);
end;
EndPaint(Window,ps);
Exit;
end;
wm_Destroy:
begin
PostQuitMessage(0);
Exit;
end;
end;
WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);
end;
{ Register the Window Class }
function WinRegister: Boolean;
var
WindowClass: WndClass;
begin
WindowClass.Style := cs_hRedraw or cs_vRedraw;
WindowClass.lpfnWndProc := @WindowProc;
WindowClass.cbClsExtra := 0;
WindowClass.cbWndExtra := 0;
WindowClass.hInstance := system.MainInstance;
WindowClass.hIcon := LoadIcon(0, idi_Application);
WindowClass.hCursor := LoadCursor(0, idc_Arrow);
WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH);
WindowClass.lpszMenuName := nil;
WindowClass.lpszClassName := AppName;
Result := windows.RegisterClass(WindowClass) <> 0;
end;
{ Create the Window Class }
function WinCreate: HWnd;
var
hWindow: HWnd;
begin
hWindow := CreateWindow(AppName, 'Fast draw demo',
ws_OverlappedWindow, cw_UseDefault, cw_UseDefault,
cw_UseDefault, cw_UseDefault, 0, 0, system.MainInstance, nil);
if hWindow <> 0 then begin
ShowWindow(hWindow, CmdShow);
ShowWindow(hWindow, SW_SHOW);
UpdateWindow(hWindow);
end;
Result := hWindow;
end;
var
AMessage: Msg;
hWindow: HWnd;
begin
if not WinRegister then begin
MessageBox(0, 'Register failed', nil, mb_Ok);
Exit;
end;
hWindow := WinCreate;
if longint(hWindow) = 0 then begin
MessageBox(0, 'WinCreate failed', nil, mb_Ok);
Exit;
end;
while GetMessage(AMessage, 0, 0, 0) do begin
TranslateMessage(AMessage);
DispatchMessage(AMessage);
end;
Halt(AMessage.wParam);
end.
unit Unit6;
{$mode objfpc}{$H+}
interface
uses
windows,Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, Buttons,
StdCtrls,lconvencoding;
type
{ TCaptureForm }
TCaptureForm = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
CheckBox1: TCheckBox;
Edit1: TEdit;
ListBox1: TListBox;
PaintBox1: TPaintBox;
Panel1: TPanel;
Panel2: TPanel;
Splitter1: TSplitter;
Timer1: TTimer;
// Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure CheckBox1Change(Sender: TObject);
procedure Edit1Enter(Sender: TObject);
procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormCreate(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
function CreateSnapshot ( WindowHD : HWND ):TBitmap;
private
public
const TMP:TBitmap =nil;
end;
var
CaptureForm: TCaptureForm;
Const HandleList:TList=Nil;
FHandle:HWND=0;
implementation
{$R *.lfm}
{ TCaptureForm }
{Function PrintWindow(HWND: HWND; hdcBlt: HDC; nFlags: DWORD): BOOL;
StdCall; External 'user32.dll';
}
//Авто
procedure TCaptureForm.Timer1Timer(Sender: TObject);
Begin
Timer1.Enabled:=false;
ListBox1Click(Sender);
Timer1.Enabled:=True;
end;
//Захват
procedure TCaptureForm.Button1Click(Sender: TObject);
begin
ListBox1Click(Sender);
end;
//Обновить
procedure TCaptureForm.Button2Click(Sender: TObject);
begin
//Timer1.Enabled:=false;
ListBox1.Clear;
FormCreate(Sender);
end;
//Поиск
procedure TCaptureForm.Button3Click(Sender: TObject);
var I:Integer;
begin
if edit1.text='' then exit;
If ListBox1.Count >0 then
for i:=0 to ListBox1.Count -1 do
if Pos(edit1.text,ListBox1.Items[i])=1 then
ListBox1.ItemIndex:=i;
ListBox1.Refresh;
end;
//Ok
procedure TCaptureForm.Button4Click(Sender: TObject);
begin
Timer1.Enabled:=false;
ModalResult:=mrOk;
end;
//Auto
procedure TCaptureForm.CheckBox1Change(Sender: TObject);
begin
Timer1.Enabled:=CheckBox1.Checked;
end;
// Enter мелкое удобство...
procedure TCaptureForm.Edit1Enter(Sender: TObject);
begin
Button3Click(Sender);
end;
procedure TCaptureForm.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState
);
begin
Edit1Enter(Sender);
end;
//Иницализация
procedure TCaptureForm.FormCreate(Sender: TObject);
var
FStop:boolean;
FHandle:HWND;
FClassName:string;
function ReadParam:string;
begin
SetLength(Result,512);
SetLength(Result,GetWindowText(FHandle,@Result[1],512));
SetLength(FClassName,512);
SetLength(FClassName,Windows.GetClassName(FHandle,@FClassname[1],512));
end;
begin
FStop := false;
if HandleList<>Nil then HandleList.Free;
HandleList:=TList.Create;
FHandle := GetWindow(FindWindow('tooltips_class32',''), GW_HWNDFIRST);
while not FStop and( FHandle <> 0 ) do
begin
if IsWindowVisible(FHandle) then begin
HandleList.Add(Pointer(FHandle));
ListBox1.Items.Add(cp1251toUtf8( ReadParam));
end;
FHandle := GetWindow(FHandle,GW_HWNDNEXT);
end;
ListBox1Click(Sender);
end;
procedure TCaptureForm.PaintBox1Paint(Sender: TObject);
begin
if Tmp<> nil then
StretchBlt(PaintBox1.Canvas.Handle,1,1,PaintBox1.Width,PaintBox1.Height
,Tmp.Canvas.Handle,0,0,Tmp.Width,Tmp.Height,//SRCERASE
SRCCOPY );
end;
function TCaptureForm.CreateSnapshot ( WindowHD : HWND ):TBitmap;
var
wnd:HWND;
dc:HDC;
Bmp:TBitmap;
r:TRect;
begin
Bmp:=TMP;
wnd :=WindowHD;
if wnd = 0 then
begin
dc := GetDC(0);
Bmp := TBitmap.Create;
Bmp.SetSize (Screen.Width,Screen.Height);
end
else
begin
Bmp := TBitmap.Create;
dc := GetWindowDC(wnd);
GetWindowRect(wnd,r);
Bmp.SetSize(r.Right-r.Left,r.Bottom-r.Top);
end;
BitBlt(Bmp.Canvas.Handle,0,0,Bmp.Width,Bmp.Height,DC,0,0,SRCCOPY);
Result:= bmp;
ReleaseDC(wnd,dc);
end;
//Выбор из спмска
procedure TCaptureForm.ListBox1Click(Sender: TObject);
begin
if ListBox1. ItemIndex = -1 then FHandle :=0 else begin
FHandle := HWND(HandleList[ListBox1. ItemIndex]);
If Not IsWindowVisible( HWND(HandleList[ListBox1. ItemIndex])) then exit;
end;
if tmp<>nil then tmp.Free;TMP:=CreateSnapshot(FHandle );
PaintBox1Paint(Sender);
//Repaint;
end;
end.
Сквозняк писал(а):Это те данные что в лазарусной форме берутся из Form1.handle а в winapi - вообще хрен знает откуда.
Alex2013 писал(а):(Там для вашей задачи много лишнего но не думаю что это проблема )
SetWindowLong(Handle, GWL_STYLE, WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or WS_CAPTION);
SetWindowPos (Handle, 0, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_DRAWFRAME);
{$MODE DELPHI}}
Form1.Xailo:=off;
Вернуться в Free Pascal Compiler
Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 12