求屏幕取色源代码 (300分)

用户通过点击屏幕上任何一点，即可得到该点的TColor值
代码最好简单。

up

???

什麼意思？

ok

...

sd

什么意思？

t=提？

真牛叉

我自己做过一个 可以发给你

{ 抓取屏幕颜色 }
{ 该程序的目地是为了抓取屏幕的颜色 }
{ 完成时间:2002-12-11 正好是我的结婚两周年纪念日 }
{ 为了减小体积,大部分是用WinApi写成的,参考了HubDog的系统钩子日志部分 }
{ 版权所有 风临左岸工作室 制作:RHL(风临左岸) }


program GetColor;

uses
Windows,
SysUtils,
Messages;

{$R *.res}
const
MyWindowStyleword=(WS_DLGFRAME or ws_popup);
Cr_Blackword=$000000;
Cr_Redword=$0000FF;
Cr_Greenword=$00FF00;
Cr_Blueword=$FF0000;
SC_DragMove = $F012;
WindowWidth=400;
WindowHeight=40;
{请勿删除此注释}
SoftInfo:string='Design By RHL 76517@21cn.com 95211.delphibbs.com';
var
hHook:Cardinal;
hwnd1:Cardinal;
DC:Longint;
MyHdc,HBrush:Cardinal;
RectRepaint:Trect;
ScreenWidth,ScreenHeight:integer;
{ 回调函数 }
function AppWindowProc(
hWnd:HWND; uMsg:UINT;
wParam:WPARAM; lParam:LPARAM):LRESULT; stdcall;
begin
Result := 0;
case uMsg of
WM_DESTROY:begin
PostQuitMessage(0);
Exit;
end;
wm_moving:begin
if PRECT(lParam)^.right>=ScreenWidth then
begin
PRECT(lParam)^.Right:=ScreenWidth;
PRECT(lParam)^.Left:=ScreenWidth-WindowWidth;
if PRECT(lParam)^.top<=0 then
begin
PRECT(lParam)^.top:=0;
PRECT(lParam)^.Bottom:=WindowHeight;
end;
if PRECT(lParam)^.Bottom>=ScreenHeight then
begin
PRECT(lParam)^.top:=ScreenHeight-WindowHeight;
PRECT(lParam)^.Bottom:=ScreenHeight;
end;
end
else if PRECT(lParam)^.left<=0 then
begin
PRECT(lParam)^.Left:=0;
PRECT(lParam)^.Right:=WindowWidth;
if PRECT(lParam)^.top<=0 then
begin
PRECT(lParam)^.top:=0;
PRECT(lParam)^.Bottom:=WindowHeight;
end;
if PRECT(lParam)^.Bottom>=ScreenHeight then
begin
PRECT(lParam)^.Bottom:=ScreenHeight;
PRECT(lParam)^.top:=ScreenHeight-WindowHeight;
end;
end
else if PRECT(lParam)^.top<=0 then
begin
PRECT(lParam)^.top:=0;
PRECT(lParam)^.Bottom:=WindowHeight;
if PRECT(lParam)^.right>=ScreenWidth then
begin
PRECT(lParam)^.Right:=ScreenWidth;
PRECT(lParam)^.Left:=ScreenWidth-WindowWidth;
end;
if PRECT(lParam)^.left<=0 then
begin
PRECT(lParam)^.Right:=WindowWidth;
PRECT(lParam)^.Left:=0;
end;
end
else if PRECT(lParam)^.Bottom>=600 then
begin
PRECT(lParam)^.top:=ScreenHeight-WindowHeight;
PRECT(lParam)^.Bottom:=ScreenHeight;
if PRECT(lParam)^.right>=ScreenWidth then
begin
PRECT(lParam)^.Right:=ScreenWidth;
PRECT(lParam)^.Left:=ScreenWidth-WindowWidth;
end;
if PRECT(lParam)^.left<=0 then
begin
PRECT(lParam)^.Left:=0;
PRECT(lParam)^.right:=WindowWidth;
end;
end;
end;
end;
Result:=DefWindowProc(hWnd, uMsg, wParam, lParam);
end;

{指定当前的钩子函数}
function HookProc(iCode:Integer;wParam:wParam;lParam:lParam):LRESULT;stdcall;
var
MyEventMsg:EVENTMSG;
MouseX,MouseY:Longint;
ColorHex,TempStr:string;
begin
Result:=0;
if (iCode < 0) then
result:=CallNextHookEx(hHook,iCode,wParam,lParam)
else if iCode = HC_ACTION then
begin
if pEVENTMSG(lParam)^.message=WM_MOUSEMOVE then
begin
MyEventMsg:=pEVENTMSG(lParam)^;
MouseX:=MyEventMsg.paramL;
MouseY:=MyEventMsg.paramH;
SetTextColor(MyHdc,Cr_black);
fillrect(myhdc,RectRepaint,HBrush);
ColorHex:=inttohex(getpixel(DC,MouseX,MouseY),6);
TempStr:='CurrentColor:'+ColorHex;
textOut(MyHdc,0,0,Pchar(TempStr),19);
SetTextColor(MyHdc,Cr_Red);
TempStr:='R:'+copy(ColorHex,5,2)+' ';
textOut(MyHdc,140,0,Pchar(tempstr),4);
SetTextColor(MyHdc,Cr_Green);
TempStr:='G:'+copy(ColorHex,3,2)+' ';
textOut(MyHdc,175,0,Pchar(tempstr),4);
SetTextColor(MyHdc,Cr_Blue);
TempStr:='B:'+copy(ColorHex,1,2)+' ';
textOut(MyHdc,210,0,Pchar(tempstr),4);
textOut(MyHdc,0,17,Pchar(SoftInfo),48);
DrawIcon(MyHdc,WindowWidth-40,0,loadicon(Hinstance,'MainIcon'));
end;
end;
end;

var
wc: TWndClass;
MSG: TMsg;
begin
{ 程序从这里开始执行}
wc.style := CS_VREDRAW or CS_HREDRAW;
wc.lpfnWndProc := @AppWindowProc;
wc.cbClsExtra :=0;
wc.cbWndExtra :=0;
wc.hInstance := HInstance;
wc.hIcon := LoadIcon(Hinstance,Pchar('CloseSign'));
wc.hCursor := LoadCursor(0, IDC_ARROW);
wc.hbrBackground := (Color_infoBk+1);
wc.lpszMenuName := nil;
wc.lpszClassName := 'My App';
if RegisterClass(wc)=0 then Exit;
hWnd1 := CreateWindow(
wc.lpszClassName, 'Color Hunt',
mywindowstyle,
0, 0,
windowWidth, WindowHeight,
0, 0, HInstance, nil);
if hWnd1=0 then Exit;
ShowWindow(hWnd1,SW_SHOWDEFAULT);
Setwindowpos(hwnd1,HWND_TOPMOST,20,20,0,0,SWP_NOMOVE or SWP_NOSIZE);
//HMyFont:=createfont(8,0,0,0,0,0,0,0,GB2312_CHARSET,0,0,0,0,'宋体');
RectRepaint.Left:=0;
RectRepaint.Top:=0;
RectRepaint.Right:=260;
RectRepaint.Bottom:=40;
DC:=CreateDc('DISPLAY',nil,nil,nil);
Hbrush:=CreateSolidBrush(getsyscolor(Color_infoBk));
selectobject(dc,Hbrush);
ScreenWidth:=GetDeviceCaps(DC,HORZRES);
ScreenHeight:=GetDeviceCaps(DC,VERTRES);
MyHdc:=GetDC(Hwnd1);
setbkcolor(myhdc,getsyscolor(Color_infoBk));
DrawIcon(MyHdc,WindowWidth-40,0,loadicon(Hinstance,'MainIcon'));
hHook:=SetwindowsHookEx(WH_JOURNALRECORD,HookProc,HInstance,0);
while GetMessage(MSG, 0, 0, 0) do begin
TranslateMessage(MSG);
DispatchMessage(MSG);
if msg.message=WM_LBUTTONDOWN then
begin
ScreenToClient(hwnd1,msg.pt);
if ((msg.pt.X >windowwidth-40) and (msg.pt.X<windowwidth) and (msg.pt.y>0) and (msg.pt.Y<32)) then
begin
ClientToScreen(hwnd1,msg.pt);
sendmessage(hwnd1,WM_DESTROY,0,0);
break;
end else
begin
ReleaseCapture;
SendMessage(hwnd1,wm_syscommand,sc_dragmove,0);
end;
ClientToScreen(hwnd1,msg.pt);
end;
end;
UnHookWindowsHookEx(hHook);
DeleteDc(DC);
Deletedc(myHdc);
Deleteobject(Hbrush);
Halt(MSG.wParam);
end.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;

type
TForm1 = class(TForm)
Timer1: TTimer;
labHandle: TLabel;
labclassname: TLabel;
labParent: TLabel;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Bevel1: TBevel;
labColor: TLabel;
Label5: TLabel;
labDelphiColor: TLabel;
Label6: TLabel;
labHtmlColor: TLabel;
Shape1: TShape;
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

function ColorToHTMLHex(Color: TColor): string;
begin
Result := IntToHex(ColorToRGB(Color),6);
Result := Copy(Result,5,2)+Copy(Result,3,2)+Copy(Result,1,2);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
p:TPoint;
h:HWND;
s:array [0..255] of char;
DC: HDC;
clr: COLORREF;
begin

GetCursorPos(p);

//Get Class Name
h:=WindowFromPoint(p);
GetClassName(h,s,255);
labHandle.Caption:=format('0x%x',[h]);
labclassname.Caption:=s;
h:=GetParent(h);
GetClassName(h,s,255);
labParent.Caption:=s;

//Get Color
DC := GetDC(HWND(nil));
clr := GetPixel(DC, p.x, p.y);
labColor.Caption := format('R:%d G:%d B:%d',[GetRValue(clr),GetGValue(clr),GetBValue(clr)]);
labDelphiColor.Caption := format('%d ($%x)',[clr,clr]);
labHtmlColor.Caption := '#'+ColorToHTMLHex(clr);
Shape1.Brush.Color := clr;

end;


procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0,SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE);
end;

end.

kenny.hu
我的邮箱是adnil.zhou@hdtworld.com，请！

zw84611，能把dfm文件也给我吗？

另外，有如下要求
支持win98,win2000和winxp

鼠标在移动的时候也可以得到当前点的颜色，
按鼠标左键的时候选定颜色，按鼠标右键的时候取消选色，就跟Frontpage中的
自定义颜色一样。

DFM文件：
------------------------
object Form1: TForm1
Left = 192
Top = 107
Width = 389
Height = 185
Caption = 'Form1'
Color = clBtnFace
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = '宋体'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 12
object labHandle: TLabel
Left = 96
Top = 8
Width = 54
Height = 12
Caption = 'labHandle'
end
object labclassname: TLabel
Left = 96
Top = 32
Width = 72
Height = 12
Caption = 'labclassname'
end
object labParent: TLabel
Left = 96
Top = 56
Width = 54
Height = 12
Caption = 'labParent'
end
object Label1: TLabel
Left = 16
Top = 8
Width = 60
Height = 12
Caption = '窗口句柄：'
end
object Label2: TLabel
Left = 16
Top = 32
Width = 36
Height = 12
Caption = '类名：'
end
object Label3: TLabel
Left = 16
Top = 56
Width = 48
Height = 12
Caption = '父类名：'
end
object Label4: TLabel
Left = 16
Top = 88
Width = 66
Height = 12
Caption = '颜色(RGB)：'
end
object Bevel1: TBevel
Left = 16
Top = 76
Width = 353
Height = 9
Shape = bsTopLine
end
object labColor: TLabel
Left = 96
Top = 88
Width = 48
Height = 12
Caption = 'labColor'
end
object Label5: TLabel
Left = 16
Top = 112
Width = 120
Height = 12
Caption = 'Delphi颜色(TColor)：'
end
object labDelphiColor: TLabel
Left = 152
Top = 112
Width = 48
Height = 12
Caption = 'labColor'
end
object Label6: TLabel
Left = 16
Top = 134
Width = 60
Height = 12
Caption = 'HTML颜色：'
end
object labHtmlColor: TLabel
Left = 94
Top = 134
Width = 48
Height = 12
Caption = 'labColor'
end
object Shape1: TShape
Left = 304
Top = 82
Width = 65
Height = 17
end
object Timer1: TTimer
Interval = 100
OnTimer = Timer1Timer
Left = 208
Top = 16
end
end

测试了一下，zw84611的效果还不错，开始取词和停止去词只要设置Timer的Enable属性就行了，
但是现在就是无法通过左键单击来固定当前的颜色并停止去词，能再指教一二吗？

可以不用Timer，而用全局鼠标钩子。
通过 if (wParam = WM_MOUSEMOVE) then 判断鼠标位置
通过 if (wParam = WM_LBUTTONDOWN) then 判断左键单击
参考：http://service.lonetear.com/delphi/dispdoc.asp?id=1300

全局鼠标钩子怎么使用？ 能像上面一样给出具体的代码吗？

我下载了那个参考的东东，但是它需要一个dll，怪麻烦的。

写个简单的.呵呵....

form1的windowstate为:wsMaximized
建个TIMAGE.
name为image1
align为alClient

procedure TForm1.FormShow(Sender: TObject);
var
zcanvas : TCanvas;
zRect : TRect;
zbmp: tbitmap;
begin
zbmp := TBitmap.Create;
dc := GetWindowDC(0);
zcanvas := TCanvas.Create;
zcanvas.Handle := dc;
zRect := Rect(0, 0, Screen.Width, Screen.Height);
zbmp.Width := zRect.Right;
zbmp.Height := zRect.Bottom;

zbmp.Canvas.CopyRect(zRect, zcanvas, zRect);
zcanvas.Handle := 0;
zcanvas.Free;
image1.Picture.Bitmap := zbmp;

procedure TForm2.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Self.color := image1.Canvas.Pixels[X,Y]; //抓到了...呵呵...
end;
自己再完善一下吧.

关注