unit popupHint;

interface

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

type
  TArrowDirection = (adUpperLeft, adUpperRight, adBottomLeft, adBottomRight, adAuto);
  THintWin = class(TForm)
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormDeactivate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    AD: TArrowDirection;
    ctFont, ftFont: TFont;
    cText: string;
    ftList: TStringList;
    cAt, ftHeight: integer;
    fOnHiding: TNotifyEvent;
    procedure CheckForOutOfBounds(PointTo: TPoint; var ArrowDirection: TArrowDirection);
    function WrapItUp(aStr: string): TStringList;
  public
    { Public declarations }
    bgColor, borColor: TColor;
    procedure ShowHint(PointTo: TPoint; ArrowDirection: TArrowDirection;
      Caption, FullText: string; TimeOut: integer = 4000;
      CaptionFont: TFont = nil; TextFont: TFont = nil;
      BackgroundColor: TColor = clInfoBk; BorderColor: TColor = clBlack); overload;
    procedure ShowHint(PointTo: TControl; ArrowDirection: TArrowDirection;
      Caption, FullText: string; TimeOut: integer = 4000;
      CaptionFont: TFont = nil; TextFont: TFont = nil;
      BackgroundColor: TColor = clInfoBk; BorderColor: TColor = clBlack); overload;
    function ProvideLocation(PointTo: TControl): TPoint;
    Property OnHiding: TNotifyEvent read fOnHiding write fOnHiding;
  end;

var
  HintWin: THintWin;

implementation

{$R *.dfm}

uses filter, main;

procedure THintWin.FormCreate(Sender: TObject);
//var
//  ExtendedStyle: integer;
begin
  DoubleBuffered := true;
//  ExtendedStyle := GetWindowLong(Handle, GWL_EXSTYLE);
//  SetWindowLong(Handle, GWL_EXSTYLE, ExtendedStyle or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW);
//
  bgColor := clInfoBk;
  borColor := clBlack;
  ctFont := TFont.Create;
  ftFont := TFont.Create;
  ftList := TStringList.Create;
  Timer1.Interval := 4000;
end;

procedure THintWin.FormPaint(Sender: TObject);
var
  i, j: integer;
begin
  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := bgColor;
  Canvas.Pen.Color := borColor;
  Canvas.RoundRect(20, 20, Width - 20, Height - 20, 40, 40);
  Canvas.Pen.Color := $00000001;
  case AD of
    adUpperLeft: begin
                   canvas.MoveTo(0,0);
                   canvas.LineTo(20, 40);
                   canvas.LineTo(40, 20);
                   canvas.LineTo(0,0);
                   canvas.FloodFill(5, 5, $00000001, fsBorder);
                   Canvas.Pen.Color := borColor;
                   canvas.MoveTo(0,0);
                   canvas.LineTo(20, 40);
                   Canvas.Pen.Color := bgColor;
                   canvas.LineTo(40, 20);
                   Canvas.Pen.Color := borColor;
                   canvas.LineTo(0,0);
                   Canvas.Pixels[20,40] := borColor;
                 end;
    adUpperRight: begin
                    canvas.MoveTo(Width, 0);
                    canvas.LineTo(Width - 20, 40);
                    canvas.LineTo(Width - 40, 20);
                    canvas.LineTo(Width, 0);
                    canvas.FloodFill(Width - 5, 5, $00000001, fsborder);
                    Canvas.Pen.Color := borColor;
                    canvas.MoveTo(Width, 0);
                    canvas.LineTo(Width - 20, 40);
                    Canvas.Pen.Color := bgColor;
                    canvas.LineTo(Width - 40, 20);
                    Canvas.Pen.Color := borColor;
                    canvas.LineTo(Width, 0);
                    Canvas.Pixels[Width - 20,40] := borColor;
                  end;
    adBottomLeft: begin
                    canvas.MoveTo(0, Height);
                    canvas.LineTo(20, Height - 40);
                    canvas.LineTo(40, Height - 20);
                    canvas.LineTo(0, Height);
                    canvas.FloodFill(5, Height - 5, $00000001, fsborder);
                    Canvas.Pen.Color := borColor;
                    canvas.MoveTo(0, Height);
                    canvas.LineTo(20, Height - 40);
                    Canvas.Pen.Color := bgColor;
                    canvas.LineTo(40, Height - 20);
                    Canvas.Pen.Color := borColor;
                    canvas.LineTo(0, Height);
                    Canvas.Pixels[20,Height - 40] := borColor;
                  end;
    adBottomRight: begin
                     canvas.MoveTo(Width, Height);
                     canvas.LineTo(Width - 20, Height - 40);
                     canvas.LineTo(Width - 40, Height - 20);
                     canvas.LineTo(Width, Height);
                     canvas.FloodFill(Width - 5, Height -5, $00000001, fsBorder);
                     Canvas.Pen.Color := borColor;
                     canvas.MoveTo(Width, Height);
                     canvas.LineTo(Width - 20, Height - 40);
                     Canvas.Pen.Color := bgColor;
                     canvas.LineTo(Width - 40, Height - 20);
                     Canvas.Pen.Color := borColor;
                     canvas.LineTo(Width, Height);
                     Canvas.Pixels[Width - 20,Height - 40] := borColor;
                   end;
  end;
  Canvas.Font := ctFont;
  Canvas.TextOut(cAt, 30, cText);
  Canvas.Font := ftFont;
  j := 60;
  for i := 0 to ftList.Count - 1 do
    begin
      Canvas.TextOut(40, j, ftList.Strings[i]);
      Inc(j, ftHeight);
    end;
end;

procedure THintWin.ShowHint(PointTo: TPoint; ArrowDirection: TArrowDirection;
  Caption, FullText: string; TimeOut: Integer = 4000;
  CaptionFont: TFont = nil; TextFont: TFont = nil;
  BackgroundColor: TColor = clInfoBk; BorderColor: TColor = clBlack);
var
  tWidth, tHeight: integer;
begin
  If fulltext = '' then begin
   If countfilt(caption, '[nl', false) = 2 then begin
    FullText := GetFilt(Caption, 2, '[nl]', false);
    Caption := GetFilt(Caption, 1, '[nl]', false);
   end;
  end;
  AD := ArrowDirection;
  if AD = adAuto then CheckForOutOfBounds(PointTo, AD);
  case AD of
    adUpperLeft: begin
                   Left := PointTo.X;
                   Top := PointTo.y;
                 end;
    adUpperRight: begin
                    Left := PointTo.X - Width;
                    Top := PointTo.Y;
                  end;
    adBottomLeft: begin
                    Left := PointTo.X;
                    Top := PointTo.Y - Height;
                  end;
    adbottomright: begin
                     Left := PointTo.X - Width;
                     Top := PointTo.Y - Height;
                   end;
  end;
  bgColor := BackgroundColor;
  borColor := BorderColor;
  if assigned(CaptionFont) then begin
   ctFont := CaptionFont;
  end
   else
  begin
   ctFont := Font;
  end;
  if assigned(TextFont) then ftFont := TextFont else ftFont := Font;
  cText := Caption;
  Canvas.Font := ctFont;
  tWidth := Canvas.TextWidth(cText);
  tHeight := Canvas.TextHeight(cText);
  if tWidth > 213 then Width := tWidth + 80 else Width := 293;
  cAt := (Width - tWidth) div 2;
  ftList := WrapItUp(FullText);
  Canvas.Font := ftFont;
  ftHeight := Canvas.TextHeight(FullText) + 2;
  Height := tHeight + (ftHeight * ftList.Count) + 70;
  Timer1.Interval := TimeOut;
  Timer1.Enabled := true;
  if not Visible then begin
   oeMain.HintTempDisableRollup := Options.ToolWindows.AutoRollUp;
   Options.ToolWindows.AutoRollUp := false;
   Show;
  end;
  Repaint;
end;

function THintWin.WrapItUp(aStr: string): TStringList;
var
  m, n: integer;
  s, s1: string;
  strBuff, strList: TStringList;
begin
  strList := TStringList.Create;
  strBuff := TStringList.Create;
  Canvas.Font := ftFont;
  if Canvas.TextWidth(aStr) > Width - 80 then
    begin
      m := Pos(' ', aStr);
      if m > 0 then
        begin
          strBuff.Clear;
          strBuff.Delimiter := ' ';
          strBuff.DelimitedText := aStr;
          s := '';
          for n := 0 to strBuff.Count - 1 do
            begin
              s := s + strBuff[n] + ' ';
              if Canvas.TextWidth(TrimRight(s)) < Width - 80 then s1 := s
                else
                  begin
                    strList.Add(s1);
                    s := strBuff[n] + ' ';
                  end;
              if n = strBuff.Count - 1 then strList.Add(s);
            end;
        end;
    end
  else strList.Add(aStr);
  Result := strList;
end;

procedure THintWin.ShowHint(PointTo: TControl; ArrowDirection: TArrowDirection;
  Caption, FullText: string; TimeOut: integer = 4000;
  CaptionFont: TFont = nil; TextFont: TFont = nil;
  BackgroundColor: TColor = clInfoBk; BorderColor: TColor = clBlack);
var
  p: TPoint;
begin
  p := ProvideLocation(PointTo);
  ShowHint(p, ArrowDirection, Caption, FullText, TimeOut, CaptionFont, TextFont, BackgroundColor, BorderColor);
end;

procedure THintWin.CheckForOutOfBounds(PointTo: TPoint; var ArrowDirection: TArrowDirection);
var
  x, y: Integer;
  ok: boolean;
begin
  if ArrowDirection = adAuto then ArrowDirection := adUpperLeft;
  repeat
    x := PointTo.X;
    y := PointTo.Y;
    ok := false;
    case ArrowDirection of
      adUpperLeft: begin
                     x := x + Width;
                     y := y + Height;
                     if x > Screen.DesktopWidth then ArrowDirection := adUpperRight;
                     if y > Screen.DesktopHeight Then ArrowDirection := adBottomLeft;
                     ok := ArrowDirection = adUpperLeft;
                   end;
      adUpperRight: begin
                      x := x - Width;
                      y := y + Height;
                      if x < Screen.DesktopLeft then ArrowDirection := adUpperLeft;
                      if y > Screen.DesktopHeight then ArrowDirection := adBottomRight;
                      ok := ArrowDirection = adUpperRight;
                    end;
      adBottomLeft: begin // Top right
                      x := x + Width;
                      y := y - Height;
                      if x > Screen.DesktopWidth then ArrowDirection := adBottomRight;
                      if y < Screen.DesktopTop then ArrowDirection := adUpperLeft;
                      ok := ArrowDirection = adBottomLeft;
                    end;
      adBottomRight: begin // top left
                       x := x - Width;
                       y := y - Height;
                       if x < Screen.DesktopLeft then ArrowDirection := adBottomLeft;
                       if y < Screen.DesktopTop then ArrowDirection := adUpperRight;
                       ok := ArrowDirection = adBottomRight;
                     end;
    end;
  until ok;
end;

function THintWin.ProvideLocation(PointTo: TControl): TPoint;
var
  l, t: integer;
  obj: TObject;
begin
  l := 0; t := 0;
  obj := PointTo;
  Inc(l, PointTo.Width div 2);
  Inc(t, PointTo.Height div 2);
  while Assigned(obj) do
    begin
      if (obj is TControl) then
        begin
          l := l + (obj as TControl).Left;
          t := t + (obj as TControl).Top;
          if (obj is TForm) then
            begin
              Inc(t, ((obj as TForm).Height - (obj as Tform).ClientHeight));
              Inc(l, ((obj as TForm).Width - (obj as Tform).ClientWidth));
            end;
          obj := (obj as TControl).Parent;
        end;
    end;
  Result.X := l;
  Result.Y := t;
end;

procedure THintWin.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Hide;
end;

procedure THintWin.FormDeactivate(Sender: TObject);
begin
  Hide;
end;

procedure THintWin.Timer1Timer(Sender: TObject);
begin
  Hide;
end;

procedure THintWin.FormHide(Sender: TObject);
begin
  Timer1.Enabled := false;
  Options.ToolWindows.AutoRollUp := oeMain.HintTempDisableRollup;
  If assigned(fOnHiding) then begin
   fOnHiding(self);
  end;
end;

procedure THintWin.FormDestroy(Sender: TObject);
begin
  FreeAndNil(ftList);
end;

end.
