gradient.pas

详细说明:毕业论文中关于小型宾馆管理系统的详细设计毕 业论文中关于小型宾馆...一个酒店管理系统VB+Access [学生学籍管理系统(VB+Acess).zip] - !这个是刚刚编的毕业设计,可能

unit Gradient;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Registry;

type
  TGradDirection = (gdUpDown, gdLeftRight) ;

  TGradient = class(TGraphicControl)
  private
    FBackColor : TColor ;
    FFrontColor : TColor;
    FDirection : TGradDirection ;
    FSwapDirection : Boolean ;
    FBC: array[0..255] of Longint;       { precalculated Brush.Colors }
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message wm_EraseBkgnd;
    procedure SetFrontColor(v : TColor) ;
    procedure SetBackColor(v : TColor);
    procedure SetDirection(v : TGradDirection) ;
    procedure LoadColors ;
    procedure SetSwapDirection(v : Boolean) ;
  protected
    procedure Paint; override;
  public
    constructor Create(AComponent: TComponent); override;
    procedure Loaded; override;
  published
    property ColorStart : TColor read FBackColor write SetBackColor
                                    default clBlack;
    property ColorEnd : TColor read FFrontColor write SetFrontColor
                                    default clBlue;
    property Direction : TGradDirection read FDirection write SetDirection
                                    default gdUpDown ;
    property Swap : Boolean read FSwapDirection write SetSwapDirection
                                    default False;
  end;

procedure Register;

implementation

constructor TGradient.Create(AComponent: TComponent);
begin
  Align := alClient;
  FBackColor := clBlack ;
  FFrontColor := clBlue ;
  FDirection := gdUpDown ;
  LoadColors ;
  inherited Create(AComponent);
end;

procedure TGradient.LoadColors ;
var
  X: Integer;
  SColor, EColor : TColor;
  DiffR, DiffG, DiffB : Currency;
  LastR, LastG, LastB : Currency;
  SC, EC : String;
  MySR, MySG, MySB : Integer;
  MyER, MyEG, MyEB : Integer;

  procedure FindColours(Str : String; var OutR : Integer; var OutG : Integer; var OutB : Integer);
  var
     Count : Integer;
     Ch : String;
  begin
     Count := 0;
     OutR := 0;
     OutG := 0;
     OutB := 0;

     repeat
        Count := Count + 1;
        Ch := Copy(Str, Count, 1);
        if (Ch <> ' ') and (Ch <> '') then
           OutR := (OutR * 10) + StrToInt(Ch);
     until (Ch = ' ') or (Ch = '');
     repeat
        Count := Count + 1;
        Ch := Copy(Str, Count, 1);
        if (Ch <> ' ') and (Ch <> '') then
           OutG := (OutG * 10) + StrToInt(Ch);
     until (Ch = ' ') or (Ch = '');
     repeat
        Count := Count + 1;
        Ch := Copy(Str, Count, 1);
        if (Ch <> ' ') and (Ch <> '') then
           OutB := (OutB * 10) + StrToInt(Ch);
     until (Ch = ' ') or (Ch = '');
  end;

  procedure GetFromReg(const Col : String; var R_G_B : String);
  begin
     with TRegistry.Create do
     try
        RootKey := HKEY_CURRENT_USER;
        OpenKey('Control Panel\Colors', False);
        R_G_B := ReadString(Col);
     finally
        Free;
     end;
  end;

  procedure SortOut(SelCol : TColor; var CRed : Integer;
                                     var CGreen : Integer;
                                     var CBlue : Integer);
  var
     RegRGB : String;
  begin
     if SelCol = clBackground then               GetFromReg('Background', RegRGB)
     else if SelCol = clActiveCaption then       GetFromReg('ActiveTitle', RegRGB)
     else if SelCol = clInactiveCaption then     GetFromReg('InactiveTitle', RegRGB)
     else if SelCol = clMenu then                GetFromReg('Menu', RegRGB)
     else if SelCol = clWindow then              GetFromReg('Window', RegRGB)
     else if SelCol = clWindowFrame then         GetFromReg('WindowFrame', RegRGB)
     else if SelCol = clMenuText then            GetFromReg('MenuText', RegRGB)
     else if SelCol = clWindowText then          GetFromReg('WindowText', RegRGB)
     else if SelCol = clCaptionText then         GetFromReg('TitleText', RegRGB)
     else if SelCol = clActiveBorder then        GetFromReg('ActiveBorder', RegRGB)
     else if SelCol = clInactiveBorder then      GetFromReg('InactiveBorder', RegRGB)
     else if SelCol = clAppWorkSpace then        GetFromReg('AppWorkspace', RegRGB)
     else if SelCol = clHighlight then           GetFromReg('Highlight', RegRGB)
     else if SelCol = clHighlightText then       GetFromReg('HighlightText', RegRGB)
     else if SelCol = clBtnFace then             GetFromReg('ButtonFace', RegRGB)
     else if SelCol = clBtnShadow then           GetFromReg('ButtonShadow', RegRGB)
     else if SelCol = clGrayText then            GetFromReg('GrayText', RegRGB)
     else if SelCol = clBtnText then             GetFromReg('ButtonText', RegRGB)
     else if SelCol = clInactiveCaptionText then GetFromReg('InactiveTitleText', RegRGB)
     else if SelCol = clBtnHighlight then        GetFromReg('ButtonHilight', RegRGB)
     else if SelCol = cl3DDkShadow then          GetFromReg('ButtonDkShadow', RegRGB)
     else if SelCol = cl3DLight then             GetFromReg('ButtonLight', RegRGB)
     else if SelCol = clInfoText then            GetFromReg('InfoText', RegRGB)
     else if SelCol = clInfoBk then              GetFromReg('InfoWindow', RegRGB); 

     if RegRGB <> '' then
        FindColours(RegRGB, CRed, CGreen, CBlue)
     else begin
        CRed := GetRValue(SelCol);
        CGreen := GetGValue(SelCol);
        CBlue := GetBValue(SelCol);
     end
  end;

begin
   SortOut(FFrontColor, MySR, MySG, MySB);
   SortOut(FBackColor, MyER, MyEG, MyEB);

   if FSwapDirection then begin
      SColor := RGB(MySR, MySG, MySB); // set the colours in reverse
      EColor := RGB(MyER, MyEG, MyEB);
   end
   else begin
      EColor := RGB(MySR, MySG, MySB); // set the colours normally
      SColor := RGB(MyER, MyEG, MyEB);
   end;

   DiffR := (GetRValue(SColor) - GetRValue(EColor)) / 255.0; // work out the difference between
   DiffG := (GetGValue(SColor) - GetGValue(EColor)) / 255.0; // each R G and B pair and divide
   DiffB := (GetBValue(SColor) - GetBValue(EColor)) / 255.0; // into 255 increments

   FBC[0] := SColor; // fix the start colour
   LastR := GetRValue(SColor); // remember the last colours used
   LastG := GetGValue(SColor); // i.e. the start colour
   LastB := GetBValue(SColor);

   for X := 1 to 254 do begin
      LastR := LastR - DiffR; // keep incrementing the colour stored
      LastG := LastG - DiffG;
      LastB := LastB - DiffB;
      FBC[x] := RGB( Trunc(LastR), Trunc(LastG), Trunc(LastB) );
   end;
   FBC[255] := EColor; // fix the end colour
end ;

procedure TGradient.SetSwapDirection(v : Boolean) ;
begin
   FSwapDirection := v; // set the direction to reverse or normal
   LoadColors ;
   Paint;
end;

procedure TGradient.SetBackColor(v : TColor) ;
begin
   FBackColor := v ;
   LoadColors ;
   Paint ;
end ;

procedure TGradient.SetFrontColor(v : TColor) ;
begin
   FFrontColor := v;
   LoadColors ;
   Paint ;
end;

procedure TGradient.SetDirection(v : TGradDirection) ;
begin
   FDirection:= v ; // this is to set left-right or up-down
   LoadColors ;
   Paint ;
end ;

procedure TGradient.Loaded;
begin
   inherited Loaded;
end;

procedure TGradient.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
   Message.Result := 1;   { do not allow Windows to erase it since it }
end;                      { is going to completely redraw itself anyway.}

procedure TGradient.Paint;
var
  TempRect   : TRect   ;
  TempStepV  : Single  ;
  ColorCode  : Integer ;
  TempTop    : Integer ;
  TempHeight : Integer ;
begin
  if FDirection = gdLeftRight then begin // do left to right
     TempStepV := Width / 255;                     { Height of each color band }
     TempHeight := Trunc(TempStepV + 1);            { adjust up to ensure overlap }
     with Canvas do begin
        TempTop := 0;
        ColorCode := 0;
        TempRect.Top := 0;
        TempRect.Bottom := Height;
        for ColorCode := 0 to 255 do begin
           Brush.Color := FBC[ColorCode];
           TempRect.Left  := TempTop;
           TempRect.Right := TempTop + TempHeight;
           FillRect(TempRect);
           TempTop := Trunc(TempStepV * ColorCode);
        end;
     end;
  end
  else begin //  or do top to bottom
     TempStepV := height / 255;
     TempHeight := Trunc(TempStepV + 1);
     with Canvas do begin
        TempTop := 0;
        ColorCode := 0;
        TempRect.Left := 0;
        TempRect.Right := Width;
        for ColorCode := 0 to 255 do begin
           Brush.Color := FBC[ColorCode];
           TempRect.Top := TempTop;
           TempRect.Bottom := TempTop + TempHeight;
           FillRect(TempRect);
           TempTop := Trunc(TempStepV * ColorCode);
        end;
     end;
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TGradient]);
end;

end.