Hint под XP Vista

Ama · #1 20.10.2008, 13:49

Здрасте!!!!
Вот представляю на показ созданный мною компонент TVistaHint.
Конечно, я понимаю что таких компонентов "море", но прошу заценить.
Отзывы, которые очень жду, прошу писать на аську: 412636666.
Вот код:

Код:

unit MyHintWindow;

interface

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

const DefColFrom: TColor = $00FFFFFF;
      DefColTo: TColor = $00F0E5E5;

type
  THintStyle = (hsXP, hsVista);
  TShowHintType = (stNone, st_LtoR, st_RtoL, st_UtoD, st_DtoU, st_Centr, st_Blend);

type
  TVistaHint = class(TComponent)
  private
    FHintStyle: THintStyle;
    FColorFrom, FColorTo: TColor;
    FShowingTime: Cardinal;
    FHintPause, FHintHidePause: Cardinal;
    FShowHintType: TShowHintType;
    FDefaultColors: boolean;
    FirstChanged: boolean;
    FFont: TFont;
    procedure SetHintPause(const Value: Cardinal);
    procedure SetHintHidePause(const Value: Cardinal);
    procedure SetHintStyle(const Value: THintStyle);
    procedure SetColorFrom(const Value: TColor);
    procedure SetColorTo(const Value: TColor);
    procedure SetDefaultColors(const Value: boolean);
    procedure SetFont(const Value: TFont);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ColorsToVistaStyle;
    procedure ColorsToXPStyle;
  published
     property HintStyle: THintStyle read FHintStyle write SetHintStyle;
     property ColorFrom: TColor read FColorFrom write SetColorFrom;
     property ColorTo: TColor read FColorTo write SetColorTo;
     property ShowType: TShowHintType read FShowHintType write FShowHintType;
     property ShowingTime: Cardinal read FShowingTime write FShowingTime;
     property HintPause: Cardinal read FHintPause write SetHintPause;
     property HintHidePause: Cardinal read FHintHidePause write SetHintHidePause;
     property DefaultColors: boolean read FDefaultColors write SetDefaultColors;
     property Font: TFont read FFont write SetFont;
  end;

type
  TMyHintWindow = class(THintWindow)
  private
    { Private declarations }
    FHint: TVistaHint;
    FBitmap: TBitmap;
    FRegion: THandle;
    procedure FreeRegion;
  protected
    { Protected declarations }
    procedure CreateParams (var Params: TCreateParams); override;
    procedure Paint; override;
    procedure Erase(var Message: TMessage); message WM_ERASEBKGND;
  public
    { Public declarations }
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     procedure ActivateHint(Rect: TRect; const AHint: String); Override;
  end;

procedure Register;

implementation

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

{ TMyHintWindow }

constructor TMyHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBitmap := TBitmap.Create;
  FBitmap.PixelFormat := pf24bit;
end;

procedure TMyHintWindow.CreateParams(var Params: TCreateParams);
const
  CS_DROPSHADOW = $20000;
begin
  inherited;
  Params.Style := Params.Style - WS_BORDER;
  Params.WindowClass.Style := Params.WindowClass.style or CS_DROPSHADOW;
end;

procedure TMyHintWindow.ActivateHint(Rect: TRect; const AHint: String);
var
  i: Integer;
  aniType: Cardinal;
begin
  FHint:= nil;
  with Application.MainForm do
  begin
    for I:= 0 to ComponentCount - 1 do
      if Components[i] is TVistaHint then
      begin
        FHint := TVistaHint(Components[i]);
        Break;
      end;
  end;
  if not Assigned(FHint) then Exit;

  Caption := AHint;
  Canvas.Font := Screen.HintFont;
  FBitmap.Canvas.Font := Screen.HintFont;
  DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect, DT_CALCRECT  or DT_NOPREFIX);
  case FHint.FHintStyle of
    hsVista:
      begin
        Width := (Rect.Right - Rect.Left) + 16;
        Height := (Rect.Bottom - Rect.Top) + 10;
      end;
    hsXP:
      begin
        Width := (Rect.Right - Rect.Left) + 10;
        Height := (Rect.Bottom - Rect.Top) + 6;
      end;
  end;
  FBitmap.Width := Width;
  FBitmap.Height := Height;
  Left := Rect.Left;
  Top := Rect.Top;
  FreeRegion;
  case FHint.FShowHintType of
   st_LtoR: aniType:= AW_HOR_POSITIVE;
   st_RtoL: aniType:= AW_HOR_NEGATIVE;
   st_UtoD: aniType:= AW_VER_POSITIVE;
   st_DtoU: aniType:= AW_VER_NEGATIVE;
   st_Centr: aniType:= AW_CENTER;
   st_Blend: aniType:= AW_BLEND;
   else aniType:= AW_ACTIVATE;
  end;
  if FHint.FHintStyle = hsVista then
  begin
    with Rect do
      FRegion := CreateRoundRectRgn(1, 1, Width, Height, 3, 3);
    if FRegion <> 0 then
      SetWindowRgn(Handle, FRegion, True);
  end;
  AnimateWindowProc(Handle, FHint.FShowingTime, aniType);
  SetWindowPos(Handle, HWND_TOPMOST, Left, Top, 0, 0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
end;

destructor TMyHintWindow.Destroy;
begin
  FBitmap.Free;
  FreeRegion;
  inherited;
end;

procedure TMyHintWindow.Erase(var Message: TMessage);
begin
  Message.Result := 0;
end;

procedure TMyHintWindow.FreeRegion;
begin
  if FRegion <> 0 then
  begin
    SetWindowRgn(Handle, 0, True);
    DeleteObject(FRegion);
    FRegion := 0;
  end;
end;

procedure DrawGradientVertical(Canvas: TCanvas; Rect: TRect; FromColor, ToColor: TColor);
var
  i, Y: Integer;
  R, G, B: Byte;
begin
   i := 0;
   for Y := Rect.Top to Rect.Bottom - 1 do
   begin
      R := GetRValue(FromColor) + Ceil(((GetRValue(ToColor) - GetRValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
      G := GetGValue(FromColor) + Ceil(((GetGValue(ToColor) - GetGValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
      B := GetBValue(FromColor) + Ceil(((GetBValue(ToColor) - GetBValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
      Canvas.Pen.Color := RGB(R, G, B);
      Canvas.MoveTo(Rect.Left, Y);
      Canvas.LineTo(Rect.Right, Y);
      Inc(i);
   end;
end;

procedure TMyHintWindow.Paint;
var
  CaptionRect: TRect;
begin
  if not Assigned(FHint) then exit;
  case FHint.FHintStyle of
    hsVista:
      begin
        DrawGradientVertical(FBitmap.Canvas, GetClientRect, FHint.FColorFrom,
                                                            FHint.FColorTo);
        with FBitmap.Canvas do
        begin
          {Font.Color := clGray;}
          Font:= FHint.FFont;
          Brush.Style := bsClear;
          Pen.Color := RGB(118, 118, 118);
          RoundRect(1, 1, Width - 1, Height - 1, 6, 6);
          RoundRect(1, 1, Width - 1, Height - 1, 3, 3);
        end;
        CaptionRect := Rect(8, 5, Width, Height);
      end;
    hsXP:
      begin
        with FBitmap.Canvas do
        begin
          {Font.Color := clBlack;}
          Font:= FHint.FFont;
          Brush.Style := bsSolid;
          Brush.Color := FHint.FColorFrom;
          Pen.Color := RGB(0, 0, 0);
          Rectangle(0, 0, Width, Height);
        end;
        CaptionRect := Rect(5, 3, Width, Height);
      end;
  end;
  DrawText(FBitmap.Canvas.Handle, PChar(Caption), Length(Caption), CaptionRect, DT_WORDBREAK or DT_NOPREFIX);
  BitBlt(Canvas.Handle, 0, 0, Width, Height, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;

{ TVistaHint }

procedure TVistaHint.ColorsToVistaStyle;
begin
 FHintStyle:= hsVista;
 FColorFrom:= DefColFrom;
 FColorTo:= DefColTo;
end;

procedure TVistaHint.ColorsToXPStyle;
begin
 FHintStyle:= hsXP;
 FColorFrom:= clInfoBk;
end;

constructor TVistaHint.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FColorFrom:= DefColFrom;
  FColorTo:= DefColTo;
  FHintStyle:= hsVista;
  FShowHintType:= st_Blend;
  FShowingTime:= 300;
  FHintPause:= 500;
  FHintHidePause:= 5000;
  FDefaultColors:= false;
  FFont:= TFont.Create;
  FirstChanged:= false;
  if not (csDesigning in ComponentState) then
  begin
    with Application do
    begin
      HintWindowClass := TMyHintWindow;
      HintPause := FHintPause;
      HintHidePause := FHintHidePause;
    end;
  end;
end;

destructor TVistaHint.Destroy;
begin
  FFont.Free;
  inherited;
end;

procedure TVistaHint.SetColorFrom(const Value: TColor);
begin
  if not FDefaultColors then
    FColorFrom := Value;
  FirstChanged:= true;
end;

procedure TVistaHint.SetColorTo(const Value: TColor);
begin
  if not FDefaultColors then
    FColorTo := Value;
  FirstChanged:= true;
end;

procedure TVistaHint.SetDefaultColors(const Value: boolean);
begin
  FDefaultColors := Value;
  if Value then
   case FHintStyle of
    hsXP: ColorsToXPStyle;
    hsVista: ColorsToVistaStyle;
   end;
end;

procedure TVistaHint.SetFont(const Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TVistaHint.SetHintHidePause(const Value: Cardinal);
begin
  FHintHidePause := Value;
  if not (csDesigning in ComponentState) then
    with Application do  HintHidePause := FHintHidePause;
end;

procedure TVistaHint.SetHintPause(const Value: Cardinal);
begin
  FHintPause := Value;
  if not (csDesigning in ComponentState) then
    with Application do  HintPause := FHintPause;
end;

procedure TVistaHint.SetHintStyle(const Value: THintStyle);
begin
  FHintStyle := Value;
  if not FirstChanged then
   case Value of
    hsXP: FColorFrom:= clInfoBk;
    hsVista: FColorFrom:= DefColFrom
   end;
end;

end.

Rat · #2 20.10.2008, 14:54

А маленький Example можно?

Ama · #3 20.10.2008, 16:32

Цитата:

Сообщение от Rat

А маленький Example можно?

Лучше тебе испробовать этот компонент самому, так есть настройки вида появления окна Hintа, цфет фона, шрифт, время, короче прикольно

Rat · #4 21.10.2008, 07:19

Затестил. При изменении размера шрифта, рамка остается старых размеров и не видно ничего...

Ama · #5 21.10.2008, 14:27

Цитата:

Сообщение от Rat

Затестил. При изменении размера шрифта, рамка остается старых размеров и не видно ничего...

Благодору за тест, здесь исходник с исправлением:

Код:

unit MyHintWindow;

interface

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

const DefColFrom: TColor = $00FFFFFF;
      DefColTo: TColor = $00F0E5E5;

type
  THintStyle = (hsXP, hsVista);
  TShowHintType = (stNone, st_LtoR, st_RtoL, st_UtoD, st_DtoU, st_Centr, st_Blend);

type
  TVistaHint = class(TComponent)
  private
    FHintStyle: THintStyle;
    FColorFrom, FColorTo: TColor;
    FShowingTime: Cardinal;
    FHintPause, FHintHidePause: Cardinal;
    FShowHintType: TShowHintType;
    FDefaultColors: boolean;
    FirstChanged: boolean;
    FFont: TFont;
    procedure SetHintPause(const Value: Cardinal);
    procedure SetHintHidePause(const Value: Cardinal);
    procedure SetHintStyle(const Value: THintStyle);
    procedure SetColorFrom(const Value: TColor);
    procedure SetColorTo(const Value: TColor);
    procedure SetDefaultColors(const Value: boolean);
    procedure SetFont(const Value: TFont);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ColorsToVistaStyle;
    procedure ColorsToXPStyle;
  published
     property HintStyle: THintStyle read FHintStyle write SetHintStyle;
     property ColorFrom: TColor read FColorFrom write SetColorFrom;
     property ColorTo: TColor read FColorTo write SetColorTo;
     property ShowType: TShowHintType read FShowHintType write FShowHintType;
     property ShowingTime: Cardinal read FShowingTime write FShowingTime;
     property HintPause: Cardinal read FHintPause write SetHintPause;
     property HintHidePause: Cardinal read FHintHidePause write SetHintHidePause;
     property DefaultColors: boolean read FDefaultColors write SetDefaultColors;
     property Font: TFont read FFont write SetFont;
  end;

type
  TMyHintWindow = class(THintWindow)
  private
    { Private declarations }
    FHint: TVistaHint;
    FBitmap: TBitmap;
    FRegion: THandle;
    procedure FreeRegion;
  protected
    { Protected declarations }
    procedure CreateParams (var Params: TCreateParams); override;
    procedure Paint; override;
    procedure Erase(var Message: TMessage); message WM_ERASEBKGND;
  public
    { Public declarations }
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     procedure ActivateHint(Rect: TRect; const AHint: String); Override;
  end;

procedure Register;

implementation

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

{ TMyHintWindow }

constructor TMyHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBitmap := TBitmap.Create;
  FBitmap.PixelFormat := pf24bit;
end;

procedure TMyHintWindow.CreateParams(var Params: TCreateParams);
const
  CS_DROPSHADOW = $20000;
begin
  inherited;
  Params.Style := Params.Style - WS_BORDER;
  Params.WindowClass.Style := Params.WindowClass.style or CS_DROPSHADOW;
end;

procedure TMyHintWindow.ActivateHint(Rect: TRect; const AHint: String);
var
  i: Integer;
  aniType: Cardinal;
begin
  FHint:= nil;
  with Application.MainForm do
  begin
    for I:= 0 to ComponentCount - 1 do
      if Components[i] is TVistaHint then
      begin
        FHint := TVistaHint(Components[i]);
        Break;
      end;
  end;
  if not Assigned(FHint) then Exit;

  Caption := AHint;
{  Canvas.Font := Screen.HintFont;
  FBitmap.Canvas.Font := Screen.HintFont;}
  Canvas.Font := FHint.FFont;
  FBitmap.Canvas.Font := FHint.FFont;
  DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect, DT_CALCRECT  or DT_NOPREFIX);
  case FHint.FHintStyle of
    hsVista:
      begin
        Width := (Rect.Right - Rect.Left) + 16;
        Height := (Rect.Bottom - Rect.Top) + 10;
      end;
    hsXP:
      begin
        Width := (Rect.Right - Rect.Left) + 10;
        Height := (Rect.Bottom - Rect.Top) + 6;
      end;
  end;
  FBitmap.Width := Width;
  FBitmap.Height := Height;
  Left := Rect.Left;
  Top := Rect.Top;
  FreeRegion;
  case FHint.FShowHintType of
   st_LtoR: aniType:= AW_HOR_POSITIVE;
   st_RtoL: aniType:= AW_HOR_NEGATIVE;
   st_UtoD: aniType:= AW_VER_POSITIVE;
   st_DtoU: aniType:= AW_VER_NEGATIVE;
   st_Centr: aniType:= AW_CENTER;
   st_Blend: aniType:= AW_BLEND;
   else aniType:= AW_ACTIVATE;
  end;
  if FHint.FHintStyle = hsVista then
  begin
    with Rect do
      FRegion := CreateRoundRectRgn(1, 1, Width, Height, 3, 3);
    if FRegion <> 0 then
      SetWindowRgn(Handle, FRegion, True);
  end;
  AnimateWindowProc(Handle, FHint.FShowingTime, aniType);
  SetWindowPos(Handle, HWND_TOPMOST, Left, Top, 0, 0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
end;

destructor TMyHintWindow.Destroy;
begin
  FBitmap.Free;
  FreeRegion;
  inherited;
end;

procedure TMyHintWindow.Erase(var Message: TMessage);
begin
  Message.Result := 0;
end;

procedure TMyHintWindow.FreeRegion;
begin
  if FRegion <> 0 then
  begin
    SetWindowRgn(Handle, 0, True);
    DeleteObject(FRegion);
    FRegion := 0;
  end;
end;

procedure DrawGradientVertical(Canvas: TCanvas; Rect: TRect; FromColor, ToColor: TColor);
var
  i, Y: Integer;
  R, G, B: Byte;
begin
   i := 0;
   for Y := Rect.Top to Rect.Bottom - 1 do
   begin
      R := GetRValue(FromColor) + Ceil(((GetRValue(ToColor) - GetRValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
      G := GetGValue(FromColor) + Ceil(((GetGValue(ToColor) - GetGValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
      B := GetBValue(FromColor) + Ceil(((GetBValue(ToColor) - GetBValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
      Canvas.Pen.Color := RGB(R, G, B);
      Canvas.MoveTo(Rect.Left, Y);
      Canvas.LineTo(Rect.Right, Y);
      Inc(i);
   end;
end;

procedure TMyHintWindow.Paint;
var
  CaptionRect: TRect;
begin
  if not Assigned(FHint) then exit;
  case FHint.FHintStyle of
    hsVista:
      begin
        DrawGradientVertical(FBitmap.Canvas, GetClientRect, FHint.FColorFrom,
                                                            FHint.FColorTo);
        with FBitmap.Canvas do
        begin
          {Font.Color := clGray;}
          Font:= FHint.FFont;
          Brush.Style := bsClear;
          Pen.Color := RGB(118, 118, 118);
          RoundRect(1, 1, Width - 1, Height - 1, 6, 6);
          RoundRect(1, 1, Width - 1, Height - 1, 3, 3);
        end;
        CaptionRect := Rect(8, 5, Width, Height);
      end;
    hsXP:
      begin
        with FBitmap.Canvas do
        begin
          {Font.Color := clBlack;}
          Font:= FHint.FFont;
          Brush.Style := bsSolid;
          Brush.Color := FHint.FColorFrom;
          Pen.Color := RGB(0, 0, 0);
          Rectangle(0, 0, Width, Height);
        end;
        CaptionRect := Rect(5, 3, Width, Height);
      end;
  end;
  DrawText(FBitmap.Canvas.Handle, PChar(Caption), Length(Caption), CaptionRect, DT_WORDBREAK or DT_NOPREFIX);
  BitBlt(Canvas.Handle, 0, 0, Width, Height, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;

{ TVistaHint }

procedure TVistaHint.ColorsToVistaStyle;
begin
 FHintStyle:= hsVista;
 FColorFrom:= DefColFrom;
 FColorTo:= DefColTo;
end;

procedure TVistaHint.ColorsToXPStyle;
begin
 FHintStyle:= hsXP;
 FColorFrom:= clInfoBk;
end;

constructor TVistaHint.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FColorFrom:= DefColFrom;
  FColorTo:= DefColTo;
  FHintStyle:= hsVista;
  FShowHintType:= st_Blend;
  FShowingTime:= 300;
  FHintPause:= 500;
  FHintHidePause:= 5000;
  FDefaultColors:= false;
  FFont:= TFont.Create;
  FirstChanged:= false;
  if not (csDesigning in ComponentState) then
  begin
    with Application do
    begin
      HintWindowClass := TMyHintWindow;
      HintPause := FHintPause;
      HintHidePause := FHintHidePause;
    end;
  end;
end;

destructor TVistaHint.Destroy;
begin
  FFont.Free;
  inherited;
end;

procedure TVistaHint.SetColorFrom(const Value: TColor);
begin
  if not FDefaultColors then
    FColorFrom := Value;
  FirstChanged:= true;
end;

procedure TVistaHint.SetColorTo(const Value: TColor);
begin
  if not FDefaultColors then
    FColorTo := Value;
  FirstChanged:= true;
end;

procedure TVistaHint.SetDefaultColors(const Value: boolean);
begin
  FDefaultColors := Value;
  if Value then
   case FHintStyle of
    hsXP: ColorsToXPStyle;
    hsVista: ColorsToVistaStyle;
   end;
end;

procedure TVistaHint.SetFont(const Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TVistaHint.SetHintHidePause(const Value: Cardinal);
begin
  FHintHidePause := Value;
  if not (csDesigning in ComponentState) then
    with Application do  HintHidePause := FHintHidePause;
end;

procedure TVistaHint.SetHintPause(const Value: Cardinal);
begin
  FHintPause := Value;
  if not (csDesigning in ComponentState) then
    with Application do  HintPause := FHintPause;
end;

procedure TVistaHint.SetHintStyle(const Value: THintStyle);
begin
  FHintStyle := Value;
  if not FirstChanged then
   case Value of
    hsXP: FColorFrom:= clInfoBk;
    hsVista: FColorFrom:= DefColFrom
   end;
end;

end.

Rat · #6 21.10.2008, 15:14

Ну и еще. Я не знаю, глюк это или нет, но если на форме несколько элементов у которых включен Hint, то эффект у хинта появляется только у первого элемента. На остальных оно показывается без эффектов.

Ama · #7 23.10.2008, 09:55

У меня все работает нормально

Zorkov Igor · #8 28.07.2009, 21:54

Созданный Rouse http://rouse.drkb.ru/components.php#fwhint, содранный мной у Rouse'а, содранный тобой у меня http://www.delphisources.ru/pages/so...int-style.html

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	RSS лента	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Новости сайта Новости форума	Ссылки и Баннеры Donate О сайте Реклама Контакты