COMPOSANT : TDBPCOLORPIKKER

{
################################################################################
# DBPCOLORPIKKER                                                             #
################################################################################
#                                                                               #
# VERSION        : 1.3                                                          #
# FICHIERS      : dbpColorPikker.pas,.dcu,.dcr,.bmp,ReadMe.htm                 #
# AUTEUR        : Julio P. (Diabloporc)                                     #
# CREATION      : 31 dec 2004                                                   #
# MODIFIEE      : 02 dec 2004                                                   #
# SITE WEB      : http://diabloporc.free.fr                                 #
# MAIL          : juliobox@free.fr                                           #
# LEGAL      : Free sous Licence GNU/GPL                                    #
# INFOS      : Retrouvez moi sur www.delphifr.com : "JulioDelphi"            #
#                                                                               #
################################################################################
}
unit dbpcolorpikker;

interface

uses
  controls, windows, SysUtils, Classes, graphics, extctrls, stdctrls;

type
  TdbpInterval = 10..60000;

  TdbpColorPikker = class(TComponent)
  private
    FAbout: string;
    FBValue: Word;
    FCanvas: TCanvas;
    FColor: TColor;
    FColorInverted: TColor;
    FEnabled: Boolean;
    FFontColor: TColor;
    FGValue: Word;
    FHexa: Cardinal;
    FHexaString: string;
    FLabelHexa: TLabel;
    FLabelRGB: TLabel;
    FRGBString: string;
    FRValue: Word;
    FShape: TShape;
    FTimer: TTimer;
    FTimerEvent: TNotifyEvent;
    FTimerInterval: TdbpInterval;
    FUseInvertedFont: Boolean;
    procedure SetAbout(const s: string);
    procedure SetEnabled(Value: Boolean);
    procedure SetInterval(Value: TdbpInterval);
  protected
    procedure ActTimer(Sender: TObject);
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property BlueValue: Word read FBValue;
    property Color: TColor read FColor;
    property ColorInverted: TColor read FColorInverted;
    property GreenValue: Word read FGValue;
    property HexaString: string read FHexaString;
    property HexaValue: Cardinal read FHexa;
    property RedValue: Word read FRValue;
    property RGBString: string read FRGBString;
  published
    property About: string read FAbout write SetAbout;
    property DefaultFontColor: TColor read FFontColor write FFontColor;
    property Enabled: Boolean read FEnabled write SetEnabled default False;
    property Interval: TdbpInterval read FTimerInterval write SetInterval default 10;
    property LabelHexa: TLabel read FLabelHexa write FLabelHexa;
    property LabelRGB: TLabel read FLabelRGB write FLabelRGB;
    property OnTimer: TNotifyEvent read FTimerEvent write FTimerEvent;
    property Shape: TShape read FShape write FShape;
    property UseInvertedFont: Boolean read FUseInvertedFont write
      FUseInvertedFont default false;
  end;

procedure Register;

implementation

{
******************************* TdbpColorPikker ********************************
}

constructor TdbpColorPikker.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fCanvas := TCanvas.Create;
  fCanvas.Handle := GetWindowDC(GetDesktopWindow);
  fAbout := 'v1.3 par Julio P. (diabloporc)';
  fEnabled := False;
  fColor := clBlack;
  fRValue := 0;
  fGValue := 0;
  fBValue := 0;
  fHexa := 0;
  fTimerInterval := 10;
  fRGBString := 'RGB(0,0,0)';
  fHexaString := '#000000';
  fUseInvertedFont := false;
  fFontColor := clBlack;

  fTimer := TTimer.Create(self);
  fTimer.Enabled := fEnabled;
  fTimer.Interval := fTimerInterval;
  fTimer.OnTimer := ActTimer;
end;

destructor TdbpColorPikker.Destroy;
begin
  fTimer.free;
  fCanvas.Free;
  inherited destroy;
end;

procedure TdbpColorPikker.ActTimer(Sender: TObject);
begin
  if (csDesigning in ComponentState) then
    exit;
  fColor := fCanvas.Pixels[Mouse.CursorPos.X, Mouse.CursorPos.Y];
  fColorInverted := $00FFFFFF - fColor;
  fRValue := GetRValue(fColor);
  fGValue := GetGValue(fColor);
  fBValue := GetBValue(fColor);
  fHexa := StrToInt(format('$%s%s%s', [IntToHex(GetRValue(fColor), 2),
    IntToHex(GetGValue(fColor), 2), IntToHex(GetBValue(fColor), 2)]));
  fRGBString := format('RGB(%d,%d,%d)', [fRValue, fGValue, FBValue]);
  {fHExaString := format('#%s%s%s', [IntToHex(GetRValue(fColor), 2),
    IntToHex(GetGValue(fColor), 2), IntToHex(GetBValue(fColor), 2)]);}

  FHexaString := Format('#%.2x%.2x%.2x', [FRValue, FGValue, FBValue]);

  if assigned(FShape) then
    FShape.Brush.Color := fColor;

  if FUseInvertedFont then
  begin
    if Assigned(FLabelRGB) then
      fLabelRgb.Font.Color := fColorInverted;
    if Assigned(FLabelHexa) then
      FLabelHexa.Font.Color := FColorInverted;
  end
  else
  begin
    if Assigned(FLabelRgb) then
      FLabelRGB.Font.Color := fFontColor;
    if Assigned(FLabelHexa) then
      FLabelHexa.Font.Color := FFontColor;
  end;

  if assigned(fLabelRGB) then
    fLabelRGB.caption := fRGBString;

  if assigned(fLabelHexa) then
    fLabelHexa.caption := fHexaString;

  if Assigned(FTimerEvent) then
    FTimerEvent(Self);
end;

procedure TdbpColorPikker.Notification(AComponent: TComponent; Operation:
  TOperation);
begin
  if Operation = opRemove then
  begin
    if aComponent = FShape then
      FShape := nil;

    if aComponent = fLabelRGB then
      fLabelRGB := nil;

    if aComponent = fLabelHexa then
      fLabelHexa := nil;
  end;
end;

procedure TdbpColorPikker.SetAbout(const s: string);
begin
  //
end;

procedure TdbpColorPikker.SetEnabled(Value: Boolean);
begin
  if Value = fEnabled then
    exit;
  fEnabled := value;
  fTimer.Enabled := Value;
end;

procedure TdbpColorPikker.SetInterval(Value: TdbpInterval);
begin
  fTimer.interval := value;
  fTimerInterval := Value;
end;

procedure Register;
begin
  RegisterComponents('Diabloporc', [TdbpColorPikker]);
end;

end.

Télécharger le zip

31 décembre 2004 17:56:33 :

c'est un composant non visible !!

02 janvier 2005 01:08:48 :

correction de delphiprog mises a jour, merci a toi :)

02 janvier 2005 01:23:10 :

:)