danhint.pas

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

{           DanHint
          Version 1.02
    Designed and developed by
            Dan Ho
       [e-mail]

  First version: 3-25-1996
  Last modified: 4-5-1996

  version 1.021
  Tom Lee ( [e-mail])
  modified for Delphi 3
  5-6-1997
}

unit Danhint;

interface

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

type
  THintDirection=(hdUpRight,hdUpLeft,hdDownRight,hdDownLeft);
  TOnSelectHintDirection=procedure(HintControl:TControl;var HintDirection:THintDirection) of object;

  TDanHint = class(TComponent)
  private
    { Private declarations }
    FHintDirection:THintDirection;
    FHintColor:TColor;
    FHintShadowColor:TColor;
    FHintFont:TFont;
    FHintPauseTime:Integer;
    FOnSelectHintDirection:TOnSelectHintDirection;
    procedure SetHintDirection(Value:THintDirection);
    procedure SetHintColor(Value:TColor);
    procedure SetHintShadowColor(Value:TColor);
    procedure SetHintFont(Value:TFont);
    procedure CMFontChanged(var Message:TMessage); message CM_FONTCHANGED;
    procedure SetHintPauseTime(Value:Integer);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;
    procedure Loaded;override;
    procedure SetNewHintFont;
  published
    { Published declarations }
    property HintDirection:THintDirection read FHintDirection write SetHintDirection default hdUpRight;
    property HintColor:TColor read FHintColor write SetHintColor default clYellow;
    property HintShadowColor:TColor read FHintShadowColor write SetHintShadowColor default clPurple;
    property HintFont:TFont read FHintFont write SetHintFont;
    property HintPauseTime:Integer read FHintPauseTime write SetHintPauseTime default 600;
    property OnSelectHintDirection:TOnSelectHintDirection read FOnSelectHintDirection write FOnSelectHintDirection;
  end;

  TNewHint = class(THintWindow)
  private
    { Private declarations }
    FDanHint:TDanHint;
    FHintDirection:THintDirection;
    procedure SelectProperHintDirection(ARect:TRect);
    procedure CheckUpRight(Spot:TPoint);
    procedure CheckUpLeft(Spot:TPoint);
    procedure CheckDownRight(Spot:TPoint);
    procedure CheckDownLeft(Spot:TPoint);
    function FindDanHint:TDanHint;
    function FindCursorControl:TControl;
  protected
    { Protected declarations }
    procedure Paint;override;
    procedure CreateParams(var Params: TCreateParams);override;
  public
    { Public declarations }
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;
    procedure ActivateHint(Rect: TRect; const AHint: string);override;
    property HintDirection:THintDirection read FHintDirection write FHintDirection default hdUpRight;
  published
    { Published declarations }
  end;

procedure Register;

implementation

const
   SHADOW_WIDTH=6;
   N_PIXELS=5;
var
   MemBmp:TBitmap;
   UpRect,DownRect:TRect;
   SelectHintDirection:THintDirection;
   ShowPos:TPoint;

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

procedure TDanHint.SetNewHintFont;
var
   I:Integer;
begin
   for I:=0 to Application.ComponentCount-1 do
      if Application.Components[I] is TNewHint then
         begin
            TNewHint(Application.Components[I]).Canvas.Font.Assign(FHintFont);
            Exit;
         end;
end;

constructor TDanHint.Create(AOwner:TComponent);
begin
   inherited Create(AOwner);
   FHintDirection:=hdUpRight;
   FHintColor:=clYellow;
   { $0080FFFF is Delphi's original setting }
   FHintShadowColor:=clPurple;
   FHintPauseTime:=600;
   Application.HintPause:=FHintPauseTime;
   FHintFont:=TFont.Create;
   FHintFont.Name:='MS Sans Serif';
   FHintFont.Size:=12;
   FHintFont.Color:=clBlue;
   FHintFont.Pitch:=fpDefault;
   FHintFont.Style:=FHintFont.Style+[fsBold,fsItalic];

   if not (csDesigning in ComponentState) then
   begin
        HintWindowClass:=TNewHint;
        Application.ShowHint:=not Application.ShowHint;
        Application.ShowHint:=not Application.ShowHint;
        { in TApplication's SetShowHint, the private
          FHintWindow is allocated according to
          HintWindowClass, so here do so actions to
          call SetShowHint and keep ShowHint property
          the same value }
        SetNewHintFont;
   end;
end;

destructor TDanHint.Destroy;
begin
   FHintFont.Free;
   inherited Destroy;
end;

procedure TDanHint.Loaded;
begin
     if not (csDesigning in ComponentState) then
     begin
          inherited Loaded;
          HintWindowClass:=TNewHint;
          Application.ShowHint:=not Application.ShowHint;
          Application.ShowHint:=not Application.ShowHint;
          { to activate to allocate a new Hint Window }
          SetNewHintFont;
     end;
end;

procedure TDanHint.SetHintDirection(Value:THintDirection);
begin
   FHintDirection:=Value;
end;

procedure TDanHint.SetHintColor(Value:TColor);
begin
   FHintColor:=Value;
end;

procedure TDanHint.SetHintShadowColor(Value:TColor);
begin
   FHintShadowColor:=Value;
end;

procedure TDanHint.SetHintFont(Value:TFont);
begin
   FHintFont.Assign(Value);
   Application.ShowHint:=not Application.ShowHint;
   Application.ShowHint:=not Application.ShowHint;
   { to activate to allocate a new Hint Window }
   SetNewHintFont;
end;

procedure TDanHint.CMFontChanged(var Message:TMessage);
begin
   inherited;
   Application.ShowHint:=not Application.ShowHint;
   Application.ShowHint:=not Application.ShowHint;
   { to activate to allocate a new Hint Window }
   SetNewHintFont;
end;

procedure TDanHint.SetHintPauseTime(Value:Integer);
begin
   if (Value<>FHintPauseTime) then
      begin
         FHintPauseTime:=Value;
         Application.HintPause:=Value;
      end;
end;

function TNewHint.FindDanHint:TDanHint;
var
   I:Integer;
begin
   Result:=nil;
   for I:=0 to Application.MainForm.ComponentCount-1 do
      if Application.MainForm.Components[I] is TDanHint then
         begin
            Result:=TDanHint(Application.MainForm.Components[I]);
            Exit;
         end;
end;

constructor TNewHint.Create(AOwner:TComponent);
begin
   inherited Create(AOwner);
   {if (Application<>nil) and (Application.MainForm<>nil) then
      FDanHint:=FindDanHint;}
   ControlStyle:=ControlStyle-[csOpaque];
   with Canvas do
   begin
     { Font.Name:='MS Sans Serif';
      Font.Size:=10;}
      {if (FDanHint<>nil) then Font.Assign(FDanHint.HintFont);}
      Brush.Style:=bsClear;
      Brush.Color:=clBackground;
      Application.HintColor:=clBackground;
   end;
   FHintDirection:=hdUpRight;
end;

destructor TNewHint.Destroy;
begin
   inherited Destroy;
end;

procedure TNewHint.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    {Style := WS_POPUP or WS_BORDER or WS_DISABLED;}
    Style := Style-WS_BORDER;
    {ExStyle:=ExStyle or WS_EX_TRANSPARENT;}
    {Add the above makes the beneath window overlap hint}
    WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
  end;
end;

procedure TNewHint.Paint;
var
  R: TRect;
  CCaption: array[0..255] of Char;
  FillRegion,ShadowRgn:HRgn;
  AP:array[0..2] of TPoint; { Points of the Arrow }
  SP:array[0..2] of TPoint; { Points of the Shadow }
  X,Y:Integer;
  AddNum:Integer; { Added num for hdDownXXX }
begin
      R := ClientRect;
      { R is for Text output }
      Inc(R.Left,5+3);
      Inc(R.Top,3);
      AddNum:=0;
      if FHintDirection>=hdDownRight then AddNum:=15;
      Inc(R.Top,AddNum);

      case HintDirection of
         hdUpRight:begin
                      AP[0]:=Point(10,Height-15);
                      AP[1]:=Point(20,Height-15);
                      AP[2]:=Point(0,Height);
                      SP[0]:=Point(12,Height-15);
                      SP[1]:=Point(25,Height-15);
                      SP[2]:=Point(12,Height);
                   end;
         hdUpLeft:begin
                     AP[0]:=Point(Width-SHADOW_WIDTH-20,Height-15);
                     AP[1]:=Point(Width-SHADOW_WIDTH-10,Height-15);
                     AP[2]:=Point(Width-SHADOW_WIDTH,Height);