about.pas

用于开发税务票据管理的软件

unit About;

interface

uses Windows, Messages,SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
  Buttons, Dialogs, TimerRX, JPEG, {HarmFade,} ExtCtrls;

const
  ANIMATION_STEPS: Cardinal = 16;

  EE_CONTROL: TShiftState = [ssCtrl, ssAlt];
  EASTER_EGG = 'ALIBUG';

// NOTE: The following lot of defines are used for the colours of
// the scrolling background.  If a USE_* define is kept, that colour
// will be changed from 0 up to 255, meaning it changes gradually in a
// gradient fashion.  However, if you want to experiment with other
// effects, when you comment out one of the USE_* defines, the
// constant will be used instead.

// When a START_* constant is used, the colour will _not_ change
// in the for loop.  This gives the effect of tinting the drawing
// so that the overall colours are different.  Handy if you want
// to gradient-fill from, say, a blue to a yellow.  Try fiddling
// about with the different options!

{$define USE_RED}
{$define USE_GREEN}
{$define USE_BLUE}

{$ifndef USE_RED}
const START_RED: Byte = 128;
{$endif}

{$ifndef USE_GREEN}
const START_GREEN: Byte = 128;
{$endif}

{$ifndef USE_BLUE}
const START_BLUE: Byte = 128;
{$endif}

const
  START_FONT_COLOUR: TColor = clYellow;
  START_FONT_SIZE: Byte = 10;
  START_FONT_NAME: String = 'Tahoma';

  TRANSPARENT_COLOUR: TColor = clBlack;

type
  TfrmAboutBox = class(TForm)
    pnlMain: TPanel;
    imgProgramIcon: TImage;
    lblProductName: TLabel;
    lblVersion: TLabel;
    btnOK: TButton;
    pbxScroll: TPaintBox;
//    hfdFancy: THarmFade;
    procedure pbxScrollPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ScrollTimerTimer(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormActivate(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
  private
    { Private declarations }
    Bitmap: TBitmap;
    Buffer: TBitmap;
    CurrentLine: Cardinal;
    FDrawing: Boolean;
    ImageBmp: TBitmap;
    ScrollLines: TStringList;
    tmrScroll: TRXTimer;
    Anim: Byte;
    BmpTextHeight: Byte;

    EECount: Cardinal;
    sEgg: String;

    procedure DrawBackdrop(var Bmp: TBitmap);
    procedure ScrollText;
  protected
    { Protected declarations }
    procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
  public
    { Public declarations }
    class function Execute: TModalResult;
  end;

var
  frmAboutBox: TfrmAboutBox;

implementation

{$R *.DFM}

procedure TfrmAboutBox.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
begin
  if FDrawing then
    Msg.Result := 1
  else
    inherited;
end;

class function TfrmAboutBox.Execute: TModalResult;
var
  frmAboutBox: TfrmAboutBox;
begin
  frmAboutBox := TfrmAboutBox.Create(Application);
  try
    Result := frmAboutBox.ShowModal;
  finally
    frmAboutBox.Free;
  end;
end;

procedure TfrmAboutBox.pbxScrollPaint(Sender: TObject);
begin
  pbxScroll.Canvas.Draw(0,0, ImageBmp);
end;

procedure TfrmAboutBox.FormCreate(Sender: TObject);
begin
  ScrollLines := TStringList.Create;

  // MODIFY THIS TO YOUR OWN MESSAGE.
  // Use blank strings to signify empty lines
  with ScrollLines do
  begin
    Add('Chess 2000, written by');
    Add('Alistair Keys');
    Add('');
    Add('Hello to everyone');
    Add('at Dundee University, and');
    Add('everyone in the world');
    Add('');
    Add('This program was written');
    Add('using Borland Delphi 3');
    Add('Try it!');
    Add('');
    Add('');
    Add('Visit my web site');
    Add('for more stuff:');
    Add('www.dundee.ac.uk/~arkeys');
    Add('');
    Add('I was inspired to');
    Add('to write this program');
    Add('after playing another');
    Add('(inferior) chess game.');
    Add('I thought, I can');
    Add('program, so why not');
    Add('put that game to shame?');
    Add('');
    Add('I learned Delphi from');
    Add('resources on the net.');
    Add('Thank you to everybody');
    Add('whose code was released');
    Add('freely.  Open-source is');
    Add('the best!  Perhaps some');
    Add('people will learn things');
    Add('from this game... that''s');
    Add('the plan.');
    Add('');
    Add('');
    Add('That''s it');
    Add('');
    Add('');
    Add('No, really');
    Add('');
    Add('');
    Add('');
    Add('');
  end;

  eeCount := 1;
  sEgg    := EASTER_EGG;

  ImageBmp := TBitmap.Create;
  with ImageBmp do
  begin
    PixelFormat := pf24bit;
    Width := pbxScroll.Width;
    Height := pbxScroll.Height;
  end;

  DrawBackdrop(ImageBmp);

  Bitmap := TBitmap.Create;
  with Bitmap do
  begin
    PixelFormat := pf24bit;
    Width := pbxScroll.Width;
    Height := pbxScroll.Height;

    // Set up the bitmap for transparent drawing
    Canvas.Font.Color := START_FONT_COLOUR;
    Canvas.Font.Size := START_FONT_SIZE;
    Canvas.Font.Name := START_FONT_NAME;
    Canvas.Font.Style := Bitmap.Canvas.Font.Style + [fsBold];
    Canvas.Brush.Color := TRANSPARENT_COLOUR;
  end;

  BmpTextHeight := Bitmap.Canvas.TextHeight('Wg');

  Buffer := TBitmap.Create;
  with Buffer do
  begin
    PixelFormat := pf24bit;
    Width := pbxScroll.Width;
    Height := pbxScroll.Height;
  end;

  CurrentLine := 0;
  Anim := 0;
  tmrScroll := TRXTimer.Create(Self);
  with tmrScroll do
  begin
    OnTimer := ScrollTimerTimer;
    Interval := 1000 div ANIMATION_STEPS;
    Enabled := False;
  end;
end;

procedure TfrmAboutBox.FormDestroy(Sender: TObject);
begin
  tmrScroll.Enabled := False;
  tmrScroll.Free;
  ScrollLines.Free;
  Bitmap.Free;
  Buffer.Free;
  ImageBmp.Free;
end;

procedure TfrmAboutBox.ScrollTimerTimer(Sender: TObject);
begin
  ScrollText;
end;

procedure TfrmAboutBox.DrawBackdrop(var Bmp: TBitmap);
var
  I: Byte;
  W: Real;
  W2: Integer;
begin
  W := Bmp.Width / 256;
  W2 := Round(W + 0.5);

  for i := 0 to 255 do
  begin
    Bmp.Canvas.Brush.Color := RGB( {$ifdef USE_RED}   i {$else} START_RED   {$endif},
                                   {$ifdef USE_GREEN} i {$else} START_GREEN {$endif},
                                   {$ifdef USE_BLUE}  i {$else} START_BLUE  {$endif} );

    Bmp.Canvas.FillRect(Bounds( Round(i * W),
                                0,
                                W2,
                                Bmp.Height));
  end;
end;

procedure TfrmAboutBox.ScrollText;
var
  i: Integer;
  Top: Cardinal;
begin
  try
    Bitmap.Canvas.FillRect(Bitmap.Canvas.ClipRect);
    Bitmap.Transparent := True;
    Bitmap.TransparentColor := TRANSPARENT_COLOUR;

    // Decide where to draw the current text line from the bottom
    Top := pbxScroll.Height - Bitmap.Canvas.TextHeight( ScrollLines[CurrentLine] );
    if ScrollLines[CurrentLine] = '' then
    begin
      Dec(Top, BmpTextHeight);
      Inc(Top, (ANIMATION_STEPS - Anim+1) * ( Round(BmpTextHeight/ANIMATION_STEPS)));
    end
    else
      Inc(Top, (ANIMATION_STEPS - Anim+1) * ( Round(Bitmap.Canvas.TextHeight( ScrollLines[CurrentLine])/ANIMATION_STEPS)));

    for i := CurrentLine downto CurrentLine - 4 do
      if i < 0 then Break
    else
    begin
      Bitmap.Canvas.TextOut( 0, Top, ScrollLines[i] );
      if ScrollLines[i] = '' then
        Dec(Top, BmpTextHeight)
      else
        Dec(Top, Bitmap.Canvas.TextHeight( ScrollLines[i] ));
    end;

    Buffer.Canvas.Draw(0,0, ImageBmp);
    Buffer.Canvas.Draw(0,0, Bitmap);

    pbxScroll.Canvas.Draw(0,0, Buffer);
  finally
    Anim := (Anim + 1) mod ANIMATION_STEPS;
    if Anim = 0 then
      CurrentLine := (CurrentLine + 1) mod ScrollLines.Count;
//    Canvas.TextOut(0,0, Format('curr: %d, anim: %d', [CurrentLine, Anim]));
  end;
end;

procedure TfrmAboutBox.FormClose(Sender: TObject;
  var Action: TCloseAction);
//var
//  Tick: LongInt;
begin
  FDrawing := True;
  tmrScroll.Enabled := False;
{  hfdFancy.PicFrom.Bitmap.Assign(GetFormImage);
  hfdFancy.Show;
  pnlMain.Hide;
  btnOK.Hide;
//  hfdFancy.Reset;
  hfdFancy.Blend;

  Tick := GetTickCount;
  repeat
    Application.ProcessMessages;
  until GetTickCount - Tick > 1000;

  FDrawing := False;
 }
//  hfdFancy.Hide;
//  tmrScroll.Enabled := True;
//  pnlInfo.Show;
//  btnOK.Show;
end;

procedure TfrmAboutBox.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  {are the proper control keys down?}
  if Shift = EE_CONTROL then
  begin
    {was the proper key pressed?}
    if Key = Ord(sEGG[eeCount]) then
    begin
      {was this the last keystroke in the sequence?}
      if eeCount = Length(sEGG) then
      begin
        {Easter egg activation code goes here, e.g.,}
         ShowMessage('Thank you - I hug and kiss you all!');
         eeCount := 1; {failure - reset the count}
      end
      else
        Inc(eeCount); {success - increment the count}
    end
    else
    begin
      eeCount := 1; {failure - reset the count}
    end;
  end;
end;

procedure TfrmAboutBox.FormActivate(Sender: TObject);
begin
  tmrScroll.Enabled := True;
end;

procedure TfrmAboutBox.FormDeactivate(Sender: TObject);
begin
  tmrScroll.Enabled := False;
end;

end.