JackJohnsons
asked on
Delphi 7: After many BitBlts to bitmap it doesn't change anymore
Hello experts
I wrote a function to find a color on the screen, it uses bitblt then directly accesses the bitmap in memory. it works fine, but when I call the function in a burst (for i := 0 to 10000 i.e.) the bitmap "hangs". When the screen changes the bitmap doesnt change anymore =/ It's certainly not the way of accessing the bitmap because when I draw the bitmap to another canvas, it reflects the old screen.
Anyone who got an idea why?
I wrote a function to find a color on the screen, it uses bitblt then directly accesses the bitmap in memory. it works fine, but when I call the function in a burst (for i := 0 to 10000 i.e.) the bitmap "hangs". When the screen changes the bitmap doesnt change anymore =/ It's certainly not the way of accessing the bitmap because when I draw the bitmap to another canvas, it reflects the old screen.
Anyone who got an idea why?
unit ColourFinder;
{$O+}
interface
uses Windows, Variants, Graphics, Sysutils, Forms;
type
TRGB24 = packed Record
b,g,r: Byte;
end;
TRGB24Array = Array [0..MaxInt div SizeOf(TRGB24)-1] of TRGB24;
PRGB24Array = ^TRGB24Array;
var
SBMP : TBitmap; //Search bitmap
Scanlines: Array of PRGB24Array; //scanlines
I: Integer; //for for loop for getting the scanlines
function FindColor(var x, y: Integer; color, xs, ys, xe, ye: Integer; ClientDC : HDC): Boolean;
implementation
function FindColor(var x, y: Integer; color, xs, ys, xe, ye: Integer; ClientDC : HDC): Boolean;
var
xx, yy: Integer;
R, G, B: Byte;
begin
R:= color;
G:= color shr 8;
B:= color shr 16;
BitBlt(SBMP.Canvas.Handle, xs, ys, xe - xs, ye - ys, ClientDC, xs, ys, SRCCOPY);
for yy:= ys to ye do
for xx:= xs to xe do
if(Scanlines[yy][xx].R = R)then if(Scanlines[yy][xx].G = G)then if(Scanlines[yy][xx].B = B)then
begin
x:= xx;
y:= yy;
Result:= True;
exit;
end;
Result:= False;
x:= -1;
y:= -1;
end;
initialization
SBMP := TBitmap.Create; //Create the search bitmap
SBMP.Width:= Screen.Width;
SBMP.Height:= Screen.Height;
SetLength(Scanlines, SBMP.Height);
SBMP.PixelFormat:= pf24bit;
for I:= 0 to SBMP.Height - 1 do
Scanlines[i]:= SBMP.ScanLine[i];
ClientDC := GetDC(0);
end.
BTw:
you read the screen content with ClientDC := GetDC(0); inside a unit I guess, this i executed only at program start up,
do something like
procedure TForm1.ReadScreen(sender: TObject);
begin
// copy the BMP
ClientDC := GetDC(0);
// run the function
FindColor(.....)
end;
set the OnTimer.Event to the Function ReadSCreen(....)
you read the screen content with ClientDC := GetDC(0); inside a unit I guess, this i executed only at program start up,
do something like
procedure TForm1.ReadScreen(sender: TObject);
begin
// copy the BMP
ClientDC := GetDC(0);
// run the function
FindColor(.....)
end;
set the OnTimer.Event to the Function ReadSCreen(....)
ASKER
The loop I use is a simple for loop, for i := 0 to 10000 do FindColor(...
I can't use a TTimer unfortunately, needs to be a real for loop :-(
I can't use a TTimer unfortunately, needs to be a real for loop :-(
after how many loops you get the hang up?
can you post the copde with your loop ?
can you post the copde with your loop ?
ASKER
the code is really easy, and it is approx after 1
for i := 0 to 10000 do
FindColor(x, y, 255 {red}, 0, 50, 50 GetDC(0));
writeln(inttostr(x));
writeln(inttostr(y));
sleep(5000); //in this time change screen
for i := 0 to 10000 do
FindColor(x, y, 255 {red}, 0, 50, 50 GetDC(0));
writeln(inttostr(x));
writeln(inttostr(y));
**** the MainForm **** (test with ~ 100 loops)
unit ColourFinderForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ColourFinder, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
SBMP : TBitmap; //Search bitmap
I : Integer; //for for loop for getting the scanlines
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
SBMP := TBitmap.Create; //Create the search bitmap only once !!!!
SBMP.Width:= Screen.Width;
SBMP.Height:= Screen.Height;
SBMP.PixelFormat:= pf24bit;
{
ClientDC := GetDC(0);
}
end;
procedure TForm1.Button1Click(Sender
var i,x,y : Integer;
begin
for i := 0 to 1000 do
begin
FindColor(SBMP, x, y, 255 {red}, 0, 0, 10, 10, GetDC(0));
Edit1.Text :=IntToStr(i)+ ':' + IntToStr(x) + ':' + IntToStr(y);
sleep(350);
self.Repaint;
end;
end;
end.
unit ColourFinderForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ColourFinder, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
SBMP : TBitmap; //Search bitmap
I : Integer; //for for loop for getting the scanlines
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
SBMP := TBitmap.Create; //Create the search bitmap only once !!!!
SBMP.Width:= Screen.Width;
SBMP.Height:= Screen.Height;
SBMP.PixelFormat:= pf24bit;
{
ClientDC := GetDC(0);
}
end;
procedure TForm1.Button1Click(Sender
var i,x,y : Integer;
begin
for i := 0 to 1000 do
begin
FindColor(SBMP, x, y, 255 {red}, 0, 0, 10, 10, GetDC(0));
Edit1.Text :=IntToStr(i)+ ':' + IntToStr(x) + ':' + IntToStr(y);
sleep(350);
self.Repaint;
end;
end;
end.
****** the new unit *******
unit ColourFinder;
{$O+}
interface
uses Windows, Variants, Graphics, Sysutils, Forms;
type
TRGB24 = packed Record
b,g,r: Byte;
end;
TRGB24Array = Array [0..MaxInt div SizeOf(TRGB24)-1] of TRGB24;
PRGB24Array = ^TRGB24Array;
function FindColor(sBMP: TBitMap; var x, y: Integer; color, xs, ys, xe, ye: Integer; ClientDC : HDC): Boolean;
implementation
function FindColor(sBMP: TBitMap; var x, y: Integer; color, xs, ys, xe, ye: Integer; ClientDC : HDC): Boolean;
var
xx, yy, i : Integer;
R, G, B: Byte;
Scanlines : Array of PRGB24Array; //scanlines
begin
SetLength(Scanlines, SBMP.Height);
for I:= 0 to SBMP.Height - 1 do
Scanlines[i]:= SBMP.ScanLine[i];
R:= color;
G:= color shr 8;
B:= color shr 16;
BitBlt(SBMP.Canvas.Handle, xs, ys, xe - xs, ye - ys, ClientDC, xs, ys, SRCCOPY);
for yy:= ys to ye do
for xx:= xs to xe do
if(Scanlines[yy][xx].R = R)then if(Scanlines[yy][xx].G = G)then if(Scanlines[yy][xx].B = B)then
begin
x:= xx;
y:= yy;
Result:= True;
exit;
end;
Result:= False;
x:= -1;
y:= -1;
end;
initialization
end.
is your problem solved ?
best
best
ASKER
It didn't fix my problem :(
can you complete thsi code 90 % finished ?
unit Unit_screenfunctions;
{************************
* http://www.experts-exchange.com/Programming/Editors_IDEs/Delphi/Q_23631004.html?cid=238#a22298541
************************}
interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
procedure ScreenShot(MyDC: TBitMap);
procedure GetColorValue(xpos, ypos: Integer; var R,g,b, mean : integer; Bit : TBitMap);
function FindColor(x_min,x_max,y_min,y_max,r,g,b, Bit : TBitMap) : boolean;
implementation
procedure ScreenShot(MyDC: TBitMap);
var
c: TCanvas;
r: TRect;
begin
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
try
r := Rect(0, 0, Screen.Width, Screen.Height);
MyDC.Width := Screen.Width;
MyDC.Height := Screen.Height;
MyDC.Canvas.CopyRect(r, c, r);
finally
ReleaseDC(0, c.Handle);
c.Free;
end;
end;
function FindColor(x_min,x_max,y_min,y_max,r,g,b, Bit : TBitMap) : boolean;
var i,j : Integer;
mean : Integer;
begin
for i:= x_min to x_max do
for j:=y_min to y-max do
begin
//
GetColorValue(i,j,r,g,b,mean
end;
end;
{*************************************************************************************
* CThis Returns the r,g,b value for a given x_pos, y_pos inside a Bitmap
*
*
*************************************************************************************}
procedure GetColorValue(xpos, ypos: Integer; var R,g,b, mean : integer; Bit : TBitMap);
type
PixArray = Array [1..3] of Byte;
var
p : ^PixArray;
h,w : Integer;
begin
Bit.PixelFormat := pf24bit;
if (ypos <= Bit.Height-1) and (xpos <= Bit.Width-1) then
begin
p:= Bit.ScanLine[ypos];
For w:=0 to xpos do
begin
mean := ( (round(p^[1]) + round(p^[2]) + round(p^[3])) div 3);
r := p^[1];
g := p^[2];
b := p^[3];
Inc(p);
end;
end;
end;
end.
the main form code ...
unit Unit_screenEE;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, Unit_screenfunctions;
type
TForm1 = class(TForm)
CaputureScreenButton: TButton;
Image1: TImage;
Edit1: TEdit;
Edit2: TEdit;
CheckColorButton: TButton;
Edit3: TEdit;
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure CaputureScreenButtonClick(Sender: TObject);
procedure CheckColorButtonClick(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
SBMP : TBitmap;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
SBMP := TBitmap.Create; //Create the search bitmap only once !!!!
SBMP.Width:= Screen.Width;
SBMP.Height:= Screen.Height;
SBMP.PixelFormat:= pf24bit;
end;
procedure TForm1.CaputureScreenButtonClick(Sender: TObject);
begin
ScreenShot(SBMP);
Image1.Picture.Bitmap.assign(SBMP);
end;
procedure TForm1.CheckColorButtonClick(Sender: TObject);
var x,y : Integer;
r,g,b, mean : Integer;
begin
x:= StrToInt (Edit1.text);
y:= StrToInt (Edit2.text);
GetColorValue(x,y, r,g,b,mean,SBMP);
Edit3.Text := IntToStr(r)+':'+ IntToStr(g)+':'+ IntToStr(b)+':'+IntToStr(mean);
end;
end.
here is the complete project ...
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Instead of a loop use a TTimer and scan the desktiop at fixed intervalls