jackkat
09-07-2007, 02:14 AM
After seeing all the great implementations of HSL coloring, but not finding a function to search for HSL colors, I decided to try to create a pugin that searches for HSL colors, with tolerance. This is my first time working with delphi, so very little of this code is actually mine, I wrote the myRGBtoHSL part (thanks to freddy for the colorfinding template and testplugin for the overall template)
Here is the code:
//SCAR Plugin. Created for SCAR Divi by Kaitnieks & Freddy1990
// currently you can't call SCAR functions from plugin
library hslSearch;
uses
FastShareMem,
SysUtils,
Classes,
Windows,
Graphics;
{$R *.res}
type
TNumbers = record
n1, n2: Integer;
end;
TRGB32 = packed record
B, G, R, A: Byte;
end;
TRGB32Array = packed array[0..MaxInt div SizeOf(TRGB32) - 1] of TRGB32;
PRGB32Array = ^TRGB32Array;
//---------------------------------------
// Functions to be called from SCAR
//demonstration of procedure
procedure myRGBtoHSL(R,G,B:extended; var H,S,L:extended);
var
highest,lowest:extended;
begin
if (r=g) and (g=b) then
begin
h := 0;
s := 0;
l := r;
end else
begin
if (r>=g) and (r>=b) then
begin
highest := r;
if (g>=b) then
begin
lowest := b;
h := 60*((g-b)/(highest-lowest));
end else
begin
lowest := g;
h := 60*((g-b)/(highest-lowest))+360;
end;
end else if (g>=b) and (g>=r) then
begin
highest := g;
if (r>=b) then
begin
lowest := b;
end else
begin
lowest := r;
end;
h := 60*((b-r)/(highest-lowest))+120;
end else
begin
highest := b;
if r>=g then
begin
lowest := g;
end else
begin
lowest := r;
end;
h := 60*((r-g)/(highest-lowest))+240;
end;
l := (highest+lowest)/2;
if (l <= 1/2) then
begin
s := (highest-lowest)/(2*l);
end else
begin
s := (highest-lowest)/(2-2*l);
end;
end;
end;
function FindHSLColorTol(var x, y: Integer; h,s,l,htol,stol,ltol:extended; xs, ys, xe, ye: Integer; Window: Hwnd): Boolean;
var
Bmp: TBitmap; // Bitmap of the client
tmpDC: HDC; // Device context of the client's window handle
Size: TRect; // Rect(angle) of the client's window
cx, cy: Integer; // For-loop vars
Line: PRGB32Array; // The scanline
testh,tests,testl:extended;
begin
Result := False; // In case the color isn't found => Result = False
x := -1; // In case the color isn't found => x = -1
y := -1; // In case the color isn't found => y = -1
Bmp := TBitmap.Create; // We create our bitmap instance
tmpDC := GetWindowDC(window); // We get the device context of the client's window handle
GetWindowRect(Window, Size); // We get the rect(angle) of the client's window
Bmp.Width := Size.Right - Size.Left; // We set the width of our bitmap
Bmp.Height := Size.Bottom - Size.Top; // We set the height of our bitmap
BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, tmpDC, 0, 0, SRCCOPY);
// ^^^ We copy the client's canvas onto the bitmap
Bmp.PixelFormat := pf32bit; // We set the bitmap to 32bits
DeleteDC(tmpDC); // We delete the device context to avoid memory leakage
for cy := ys to ye do // Loop for the rows of pixels (y)
begin
if cy >= Bmp.Height then Break; // Break the loop if you reach the end of the bitmap
Line := Bmp.ScanLine[cy]; // We retrieve the scanline (line of pixels) from the bitmap for the current y
for cx := xs to xe do // Loop for the colums of pixels (x)
begin
if cx >= Bmp.Width then Break; // Break the loop if you reach the end of the bitmap
myRGBtoHSL(Line[cx].R/256,Line[cx].G/256,Line[cx].B/256,testH,testS,testL);
if (abs(testH-H) <= Htol) and (abs(tests-s) <= stol) and (abs(testl-l) <= ltol) then
begin // If the color is similar (or for tol 0 the same) then...
Result := True; // Result of the function
x := cx; // Returned x-value
y := cy; // Returned y-value
Line := nil; // Free the scanline to avoid memory leaks
Bmp.Free; // Free the bitmap to avoid memory leaks
Exit; // Exit the function
end;
end;
end;
Line := nil; // Free the scanline to avoid memory leaks
Bmp.Free; // Free the bitmap to avoid memory leaks
end;
//********************************
// Change this accordingly to your function count
function GetFunctionCount(): Integer; stdcall; export;
begin
Result := 2;
end;
//*******************************
// Change this accordingly to your function definitions
function GetFunctionInfo(x: Integer; var ProcAddr: Pointer; var ProcDef: PChar): Integer; stdcall;
begin
case x of
0:
begin
ProcAddr := @myRGBtoHSL;
StrPCopy(ProcDef, 'procedure myRGBtoHSL(R,G,B,H,S,L:extended);');
end;
1:
begin
ProcAddr := @FindHSLColorTol;
StrPCopy(ProcDef, 'function FindHSLColorTol(var x, y: Integer; h,s,l,htol,stol,ltol:extended; xs, ys, xe, ye: Integer; Window: Hwnd): Boolean;');
end;
else
x := -1;
end;
Result := x;
end;
//********************************
// Change this accordingly to your type count
function GetTypeCount(): Integer; stdcall; export;
begin
Result := 1;
end;
//*******************************
// Types you want to add
function GetTypeInfo(x: Integer; var sType, sTypeDef: string): Integer; stdcall;
begin
case x of
0:
begin
sType := 'TNumbers';
sTypeDef := 'record n1, n2: Integer; end;';
end;
else
x := -1;
end;
Result := x;
end;
//***************************
// Don't change below this
exports GetFunctionCount;
exports GetFunctionInfo;
exports GetTypeCount;
exports GetTypeInfo;
end.
and I use this script to test it.
program hslSearchTest;
var x,y :integer;
var h,s,l:extended;
begin
myRGBtoHSL(0.5,0.5,0.5,H,S,L);
writeln('H:'+floattostr(h)+' S:'+floattostr(s)+' L:'+floattostr(l));
if FindHSLColorTol( x, y, 16, 100, 50, 1, 0, 0, MSX1, MSY1, MSX2, MSY2, GetClientWindowHandle) then
begin
writeln('X:'+inttostr(x)+' Y:'+inttostr(y));
end else
begin
writeln('Not found.');
end;
end.
The problem is, it doesn't work.
I get this error for the myRGBtoHSL call:
[Runtime Error] : Exception: Access violation at address 017D7796 in module 'hslSearch.dll'. Write of address 00000000 in line 5 in script C:\Program Files\SCAR 3.11\Scripts\RGB HSL\findHSLColortest.scar
And, when i comment that out, I get this for the FingHSLColorTol:
[Runtime Error] : Exception: in line 7 in script C:\Program Files\SCAR 3.11\Scripts\RGB HSL\findHSLColortest.scar
Does anyone know what is going wrong?
Any help would be greatly appreciated, this function should be very useful if it is fast enough.
~Jackkat
Here is the code:
//SCAR Plugin. Created for SCAR Divi by Kaitnieks & Freddy1990
// currently you can't call SCAR functions from plugin
library hslSearch;
uses
FastShareMem,
SysUtils,
Classes,
Windows,
Graphics;
{$R *.res}
type
TNumbers = record
n1, n2: Integer;
end;
TRGB32 = packed record
B, G, R, A: Byte;
end;
TRGB32Array = packed array[0..MaxInt div SizeOf(TRGB32) - 1] of TRGB32;
PRGB32Array = ^TRGB32Array;
//---------------------------------------
// Functions to be called from SCAR
//demonstration of procedure
procedure myRGBtoHSL(R,G,B:extended; var H,S,L:extended);
var
highest,lowest:extended;
begin
if (r=g) and (g=b) then
begin
h := 0;
s := 0;
l := r;
end else
begin
if (r>=g) and (r>=b) then
begin
highest := r;
if (g>=b) then
begin
lowest := b;
h := 60*((g-b)/(highest-lowest));
end else
begin
lowest := g;
h := 60*((g-b)/(highest-lowest))+360;
end;
end else if (g>=b) and (g>=r) then
begin
highest := g;
if (r>=b) then
begin
lowest := b;
end else
begin
lowest := r;
end;
h := 60*((b-r)/(highest-lowest))+120;
end else
begin
highest := b;
if r>=g then
begin
lowest := g;
end else
begin
lowest := r;
end;
h := 60*((r-g)/(highest-lowest))+240;
end;
l := (highest+lowest)/2;
if (l <= 1/2) then
begin
s := (highest-lowest)/(2*l);
end else
begin
s := (highest-lowest)/(2-2*l);
end;
end;
end;
function FindHSLColorTol(var x, y: Integer; h,s,l,htol,stol,ltol:extended; xs, ys, xe, ye: Integer; Window: Hwnd): Boolean;
var
Bmp: TBitmap; // Bitmap of the client
tmpDC: HDC; // Device context of the client's window handle
Size: TRect; // Rect(angle) of the client's window
cx, cy: Integer; // For-loop vars
Line: PRGB32Array; // The scanline
testh,tests,testl:extended;
begin
Result := False; // In case the color isn't found => Result = False
x := -1; // In case the color isn't found => x = -1
y := -1; // In case the color isn't found => y = -1
Bmp := TBitmap.Create; // We create our bitmap instance
tmpDC := GetWindowDC(window); // We get the device context of the client's window handle
GetWindowRect(Window, Size); // We get the rect(angle) of the client's window
Bmp.Width := Size.Right - Size.Left; // We set the width of our bitmap
Bmp.Height := Size.Bottom - Size.Top; // We set the height of our bitmap
BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, tmpDC, 0, 0, SRCCOPY);
// ^^^ We copy the client's canvas onto the bitmap
Bmp.PixelFormat := pf32bit; // We set the bitmap to 32bits
DeleteDC(tmpDC); // We delete the device context to avoid memory leakage
for cy := ys to ye do // Loop for the rows of pixels (y)
begin
if cy >= Bmp.Height then Break; // Break the loop if you reach the end of the bitmap
Line := Bmp.ScanLine[cy]; // We retrieve the scanline (line of pixels) from the bitmap for the current y
for cx := xs to xe do // Loop for the colums of pixels (x)
begin
if cx >= Bmp.Width then Break; // Break the loop if you reach the end of the bitmap
myRGBtoHSL(Line[cx].R/256,Line[cx].G/256,Line[cx].B/256,testH,testS,testL);
if (abs(testH-H) <= Htol) and (abs(tests-s) <= stol) and (abs(testl-l) <= ltol) then
begin // If the color is similar (or for tol 0 the same) then...
Result := True; // Result of the function
x := cx; // Returned x-value
y := cy; // Returned y-value
Line := nil; // Free the scanline to avoid memory leaks
Bmp.Free; // Free the bitmap to avoid memory leaks
Exit; // Exit the function
end;
end;
end;
Line := nil; // Free the scanline to avoid memory leaks
Bmp.Free; // Free the bitmap to avoid memory leaks
end;
//********************************
// Change this accordingly to your function count
function GetFunctionCount(): Integer; stdcall; export;
begin
Result := 2;
end;
//*******************************
// Change this accordingly to your function definitions
function GetFunctionInfo(x: Integer; var ProcAddr: Pointer; var ProcDef: PChar): Integer; stdcall;
begin
case x of
0:
begin
ProcAddr := @myRGBtoHSL;
StrPCopy(ProcDef, 'procedure myRGBtoHSL(R,G,B,H,S,L:extended);');
end;
1:
begin
ProcAddr := @FindHSLColorTol;
StrPCopy(ProcDef, 'function FindHSLColorTol(var x, y: Integer; h,s,l,htol,stol,ltol:extended; xs, ys, xe, ye: Integer; Window: Hwnd): Boolean;');
end;
else
x := -1;
end;
Result := x;
end;
//********************************
// Change this accordingly to your type count
function GetTypeCount(): Integer; stdcall; export;
begin
Result := 1;
end;
//*******************************
// Types you want to add
function GetTypeInfo(x: Integer; var sType, sTypeDef: string): Integer; stdcall;
begin
case x of
0:
begin
sType := 'TNumbers';
sTypeDef := 'record n1, n2: Integer; end;';
end;
else
x := -1;
end;
Result := x;
end;
//***************************
// Don't change below this
exports GetFunctionCount;
exports GetFunctionInfo;
exports GetTypeCount;
exports GetTypeInfo;
end.
and I use this script to test it.
program hslSearchTest;
var x,y :integer;
var h,s,l:extended;
begin
myRGBtoHSL(0.5,0.5,0.5,H,S,L);
writeln('H:'+floattostr(h)+' S:'+floattostr(s)+' L:'+floattostr(l));
if FindHSLColorTol( x, y, 16, 100, 50, 1, 0, 0, MSX1, MSY1, MSX2, MSY2, GetClientWindowHandle) then
begin
writeln('X:'+inttostr(x)+' Y:'+inttostr(y));
end else
begin
writeln('Not found.');
end;
end.
The problem is, it doesn't work.
I get this error for the myRGBtoHSL call:
[Runtime Error] : Exception: Access violation at address 017D7796 in module 'hslSearch.dll'. Write of address 00000000 in line 5 in script C:\Program Files\SCAR 3.11\Scripts\RGB HSL\findHSLColortest.scar
And, when i comment that out, I get this for the FingHSLColorTol:
[Runtime Error] : Exception: in line 7 in script C:\Program Files\SCAR 3.11\Scripts\RGB HSL\findHSLColortest.scar
Does anyone know what is going wrong?
Any help would be greatly appreciated, this function should be very useful if it is fast enough.
~Jackkat