Piszę program, który wykorzystuje fragment ekranu. Chodzi o to, że wskazuje sie współrzędne tego fragmentu i zwraca się obraz tego fragmentu ekranu w bitmapie.
Kiedyś napisałem dwie wersje funkcji. Różnią sie prezentowaniem kursora myszki. Jedna to taka, gdzie tylko bierze położenie wskaźnika myszy i rysuje krzyżak. Krzyżak jest zawsze bez względu na wygląd kursora myszki. Zmienne Grub, Dlug, Ends to parametry krzyżaka, które ustawia się w formularzu.
function CaptureScreen(XXX1,YYY1,XXX2,YYY2:LongInt): TBitmap;
var XXXXX,YYYYY:LongInt;
R,G,B:Byte;
RGBindex:LongInt;
Grub,Dlug,Ends:Integer;
begin
DC := GetDC(GetDesktopWindow);
try
ABitmap.Width := XXX2;
ABitmap.Height := YYY2;
ABitmap.Canvas.Pen.Color:=FormMain.ScreenColor;
ABitmap.Canvas.Brush.Color:=FormMain.ScreenColor;
ABitmap.Canvas.Rectangle(0,0,ABitmap.Width,ABitmap.Height);
BitBlt(ABitmap.Canvas.Handle,00,00,XXX2,YYY2,DC,XXX1,YYY1,SRCCOPY);
If IsMouse Then
Begin
Grub:=FormMain.GrubEdit.Value;
Dlug:=FormMain.DlugEdit.Value;
Ends:=FormMain.EndsEdit.Value;
XXXXX:=Mouse.CursorPos.x-XXX1;
YYYYY:=Mouse.CursorPos.y-YYY1;
RGBindex:=ABitmap.Canvas.Pixels[XXXXX,YYYYY];
R:=((StringToColor('$0000'+Copy(IntToHex(RGBindex,6),5,2)+'')) div 1);
G:=((StringToColor('$00'+Copy(IntToHex(RGBindex,6),3,2)+'00')) div 256);
B:=((StringToColor('$'+Copy(IntToHex(RGBindex,6),1,2)+'0000')) div 65536);
ABitmap.Canvas.Pen.Color:=RGB(R,G,B);
ABitmap.Canvas.Brush.Color:=RGB(R,G,B);
ABitmap.Canvas.Rectangle(XXXXX-Dlug-Grub-Ends,YYYYY-Grub,XXXXX+Dlug+1+Grub+Ends,YYYYY+1+Grub);
ABitmap.Canvas.Rectangle(XXXXX-Grub,YYYYY-Dlug-Grub-Ends,XXXXX+1+Grub,YYYYY+Dlug+1+Grub+Ends);
If Ends=(-1) Then
Begin
ABitmap.Canvas.Rectangle(0,YYYYY-Grub,ABitmap.Width,YYYYY+1+Grub);
ABitmap.Canvas.Rectangle(XXXXX-Grub,0,XXXXX+1+Grub,ABitmap.Height);
End;
ABitmap.Canvas.Pen.Color:=RGB(255-R,255-G,255-B);
ABitmap.Canvas.Brush.Color:=RGB(255-R,255-G,255-B);
ABitmap.Canvas.Rectangle(XXXXX-Dlug-Grub,YYYYY-Grub,XXXXX+Dlug+1+Grub,YYYYY+1+Grub);
ABitmap.Canvas.Rectangle(XXXXX-Grub,YYYYY-Dlug-Grub,XXXXX+1+Grub,YYYYY+Dlug+1+Grub);
If Dlug=(-1) Then
Begin
ABitmap.Canvas.Rectangle(0,YYYYY-Grub,ABitmap.Width,YYYYY+1+Grub);
ABitmap.Canvas.Rectangle(XXXXX-Grub,0,XXXXX+1+Grub,ABitmap.Height);
End;
End;
finally
ReleaseDC(GetDesktopWindow, DC);
end;
Result := ABitmap;
end;
Druga wersja pobiera kształt myszki i w obrazku powinien być on odwzorowany, podobnie jak w Lupie Microsoft:
function CaptureScreen(XXX1,YYY1,XXX2,YYY2:LongInt): TBitmap;
var
PunktX,PunktY:LongInt;
begin
DC := GetDC(GetDesktopWindow);
try
ABitmap.Width := XXX2;
ABitmap.Height := YYY2;
ABitmap.Canvas.Pen.Color:=FormMain.ScreenColor;
ABitmap.Canvas.Brush.Color:=FormMain.ScreenColor;
ABitmap.Canvas.Rectangle(0,0,ABitmap.Width,ABitmap.Height);
BitBlt(ABitmap.Canvas.Handle,00,00,XXX2,YYY2,DC,XXX1,YYY1,SRCCOPY);
try
CursorInfo.cbSize := SizeOf(CursorInfo);
GetCursorInfo(CursorInfo);
MyCursor.Handle := CursorInfo.hCursor;
//***************************
GetIconInfo(CursorInfo.hCursor, IconInfo);
//***************************
PunktX:=IconInfo.xHotspot;
PunktY:=IconInfo.yHotspot;
ABitmap.Canvas.Draw((Mouse.CursorPos.x-PunktX-XXX1),(Mouse.CursorPos.y-PunktY-YYY1), MyCursor);
MyCursor.ReleaseHandle;
finally
end;
finally
ReleaseDC(GetDesktopWindow, DC);
end;
Result := ABitmap;
end;
O ile z tą pierwszą wersją wszystko gra, z tą drugą wersją jest problem.
Chodzi o to, że po pewnym czasie (kilka minut) pojawia się komunikat "Out of system resources".
Nie wiem, o co chodzi, ale domyślam się, że chodzi tu o to, że z każdym wywołaniem funkcji jest rezerwowany obszar pamięci, który nie jest zwalniany i w końcu cała pamięć zostaje zarezerwowana wiele razy. Co ciekawe, jak usunę (zamienię w komentarz) linijkę pomiędzy liniami "**********" to problem znika (nie wiem, czy znika, czy tylko wyraźnie przedłuża sie czas do wyczerpania zasobów), ale wtedy nie jest odczytany punk wskazujący w kursorze i na obrazku kursor jest przesunięty w stosunku do oryginału.
Dokładnie rzecz biorąc, pokazuje się komunikat na poniższym obrazku
Co muszę zrobić, żeby ta druga wersja działała bezproblemowo.
A może jest jakiś lepszy sposób, żeby zrzucić ekran lub jego fragment z kursorem myszki?