unit UnitFrmTooltip;

{
    Purpose:
        Experimental homegrown Tooltip replacement

}
interface

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

  UnitClipQueue, UnitTWideChar;

type
  TFrmTooltip = class(TForm)
    lblHeader: TLabel;

    lblSpacer: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
        maxwidth : Cardinal;
        maxheight : cardinal;
        LastPoint : TPoint;
        rbody : TRect;
        wcbody : TWideChar;
        //myshowing : boolean;
         Fshowing: boolean;

        procedure SetPosition( pos : TPoint );
        procedure DoHeader(h : HDC; rect : Trect);
        procedure DoShow;

  public
    { Public declarations }

        procedure SetMaxWidth(max : cardinal);
        procedure ShowTooltip(s : ansistring; Pos : TPoint; UseHelpString : boolean = true;header : string = ''); overload;
        procedure ShowTooltip(ci : TClipItem; Pos : TPoint; header : string = ''; usehelpstring : boolean = true); overload;
        procedure ShowTooltip(inwc : TWideChar; Pos : TPoint; UseHelpString : boolean = true; header : string = ''); overload;
        procedure ShowTooltip(pic : TPicture; Pos : TPoint; header : string = ''); overload;
        procedure CloseTooltip;


        function IsHit(Pos : TPoint) : boolean;
  end;

var
  FrmTooltip: TFrmTooltip;

implementation

{$R *.dfm}
uses UnitMisc;

const HELP_STRING = 'shift+click to preview  |  right-click for item menu';
const TEXT_FORMAT =  DT_LEFT or DT_VCENTER or DT_NOCLIP or DT_WORDBREAK;
const WND_MARGIN = 10;

procedure TFrmTooltip.CloseTooltip;
begin
    ShowWindow(Handle, SW_HIDE);
    self.fshowing := false;
end;

procedure TFrmTooltip.DoHeader(h : HDC; rect : Trect);
var
    Vertex : array[0..1] of TTriVertex;
    grect : TGradientRect;
    rHead : TRect;
    procedure SetColor(var v : TTriVertex; c : TColor; x,y : integer);
    var clr : TColor;
    begin
        v.x :=x;
        v.y :=y;
        clr := ColorToRGB(c);
        v.Red := GetRValue(clr) shl 8;
        v.Green := GetGValue(clr) shl 8;
        v.Blue := GetBValue(clr) shl 8;
    end;
begin

    lblHeader.Font.Color := clCaptionText;
    rhead := rect;

    SetColor(vertex[0], clactiveCaption, rhead.Left, rhead.top);
    SetColor(vertex[1], clGradientactiveCaption, rhead.Right, rhead.bottom);

    grect.UpperLeft := 0;
    grect.LowerRight := 1;


    Windows.GradientFill(
        h,
        @Vertex[0],
        2,
        @grect,
        1,
        GRADIENT_FILL_RECT_H
    );
end;

procedure TFrmTooltip.DoShow;
begin
    self.Invalidate;
    SetWindowPos(Handle, HWND_TOPMOST, self.Left, self.Top, self.Width, self.Height,
      SWP_NOACTIVATE);
    ShowWindow(Handle, SW_SHOWNOACTIVATE);
    self.fShowing := true;
end;

procedure TFrmTooltip.FormCreate(Sender: TObject);

begin
    SetWindowLong(
        Handle,
     GWL_STYLE,
     GetWindowLong( Handle, GWL_STYLE ) and not WS_CAPTION
    ) ;
    ClientHeight := Height;

    maxwidth := 300;
    maxheight := 200;
    lblSpacer.Caption := ' ';
    self.Font.Color := clWindowText;
    wcbody := TWideChar.create;
    rbody.Left := 0;
    rbody.right := maxwidth;
    rbody.Top := 0;
    rbody.bottom := maxheight;
    FShowing := false;
end;

procedure TFrmTooltip.FormPaint(Sender: TObject);
begin
    //self.Brush.Color := clWindow;
    //self.font.Color := clWindowText;
    self.Color := clWindow;

    DoHeader(self.Canvas.handle, lblheader.BoundsRect);
    //DoHeader(self.Canvas.Handle, rbody);


    {dec(rbody.right, rbody.left);
    dec(rbody.Bottom, rbody.top);
    rbody.Left := 0;
    rbody.top := 0;}
    self.font.Color := clWindowText;
    DrawTextW(self.Canvas.Handle,wcbody.Memory,-1,rbody, TEXT_FORMAT);



end;


function TFrmTooltip.IsHit(Pos: TPoint): boolean;
var r : TRect;
begin
    Windows.SetLastError(ERROR_SUCCESS);

    r := self.GetClientRect;

    inc(r.left, LastPoint.x);
    inc(r.Right, LastPoint.X);
    inc(r.Top, lastpoint.Y);
    inc(r.Bottom, Lastpoint.y);
    result := Windows.PtInRect(r, Pos);
end;

procedure TFrmTooltip.SetMaxWidth(max: cardinal);
begin
    self.maxwidth := max;
end;

procedure TFrmTooltip.SetPosition(pos : TPoint);
var r : TRect;
    wd : integer;
begin
    LastPoint := pos;

    r.Top := 0;
    r.Left := 0;
    r.Right := self.Width;
    r.Bottom := lblHeader.Height + lblSpacer.Height + rbody.Bottom-rbody.top;

    if self.MaxWidth <> 0 then begin
        if (r.right - r.left) > self.MaxWidth then
            r.right := r.left + self.MaxWidth;
    end;

    if (r.Bottom - r.Top) > self.maxHeight then begin
        r.bottom := r.top + self.MaxHeight;
    end;

    inc(r.Top, Pos.y );
    inc(r.Bottom, Pos.Y );
    inc(r.Left, Pos.X );
    inc(r.right, Pos.X );


    if r.Right > screen.DesktopWidth then begin
       wd := screen.DesktopWidth - r.right;
       inc(r.left, wd);
       inc(r.Right, wd);
    end;

    if r.Bottom > screen.DesktopHeight then begin
        wd := screen.DesktopHeight - r.bottom;
        inc(r.top, wd);
        inc(r.Bottom, wd);
    end;


    self.top := r.top;
    self.Left := r.Left;
    self.ClientWidth := r.Right - r.left;
    self.ClientHeight := r.bottom - r.Top;

end;


procedure TFrmTooltip.ShowTooltip(ci: TClipItem; Pos: TPoint; header: string = ''; usehelpstring : boolean = true);
begin
    wcbody.clear;

    if ci.GetFormat <> CF_UNICODETEXT then begin
        wcbody.append(ci.GetAsText);
    end else begin
        wcbody.append(ci.GetHandle, ci.GetDataSize);
    end;

    self.ShowTooltip(nil,pos,usehelpstring,header);
end;

procedure TFrmTooltip.ShowTooltip(s: ansistring; Pos: TPoint; UseHelpString: boolean;
  header: string);
begin
    wcbody.clear;
    wcbody.append(s);
    ShowTooltip(nil,pos,UseHelpString,header);
end;

procedure TFrmTooltip.ShowTooltip(pic: TPicture; Pos: TPoint; header: string);
begin

end;

procedure TFrmTooltip.ShowTooltip(inwc: TWideChar; Pos: TPoint;
  UseHelpString: boolean; header: string);



    function MeasureText(p : pointer; size : cardinal; wordbreak : boolean = true) : TRect; overload;
    var tf : cardinal;
        name : string;
        f, oldf : HFONT;
        h : HGDIOBJ;
        lf : TLogFont;
    begin

        name := self.Font.Name;

        //GetObject(self.Font.Handle, sizeof(lf), @lf);
        //f := CreateFontIndirect(lf);
        oldf := Windows.SelectObject(self.Canvas.Handle, self.Font.Handle);


        result := Rect(0, 0, Self.MaxWidth, self.MaxHeight);
        tf := DT_CALCRECT or TEXT_FORMAT;
        if not wordbreak then tf := tf or DT_CENTER or  DT_SINGLELINE and (not DT_WORDBREAK) ;

        DrawTextW(
            self.Canvas.Handle, p, -1,
            result,
            tf
        );

        //inc(result.Right, 15);  // don't understand, but the "close" measurement
        // is off by a little bit
        // but is off even worse when a font is not selected

        h := SelectObject(self.Canvas.Handle, oldf);
        DeleteObject(h);
    end;

    function MeasureText(widetext : TWideChar; text : string = ''; wordbreak : boolean = true) : TRect; overload;
    var dofree : boolean;
    begin
        dofree := false;
        if widetext = nil then begin
            widetext := TWideChar.Create;
            widetext.Append(text+#0);
            dofree := true;
        end;

        result := MeasureText(widetext.memory, widetext.size, wordbreak);

        //self.AlterSizePosition(result, Pos);
        //inc(result.left,4); dec(result.right,4);
        //inc(result.top,4); dec(result.bottom,4);

        //inc(result.left,4);inc(result.right,2);
        if dofree then begin
            widetext.clear;
            MyFree(widetext);
        end;
    end;


    procedure MeasureBodyText;
    var wc2 : TWideChar;
        ms : TMemoryStream;
        ms2 : TMemorySTream;
        s : string;
        line : Trect;
        b : array[0..52] of word;
        last : word;
        i : integer;
    begin

        rbody := MeasureText(wcbody);
        {
        wc2 := TWideChar.Create;
        ms := wcbody.GetMemoryStream;
        if rbody.Right > self.maxwidth then begin
            ms2 := TMemoryStream.Create;
            ms.Seek(0,soFromBeginning);

            repeat
                i := ms.Read(b,Sizeof(b[0]));
                last := b[0];

                if i <> 0 then begin
                    wc2.GetMemoryStream.Write(b[0],i);
                    ms2.Write(b[0],i);

                    b[0] := 0;
                    wc2.GetMemoryStream.Write(b[0],i); // null terminate
                    line := MeasureText(wc2.memory, wc2.GetMemoryStream.size,false);
                    wc2.GetMemoryStream.SetSize(wc2.GetMemoryStream.Size - sizeof(b[0]));

                    // write and react when the line is too big
                    if ((line.right-line.left) > self.MaxWidth) then begin

                        // remove the last character
                        wc2.GetMemoryStream.SetSize(wc2.GetMemoryStream.Size - sizeof(b[0]));
                        ms2.SetSize(ms2.Size - sizeof(b[0]));

                        // add a space
                        b[0] := ord(#13);
                        b[1] := ord(#10);
                        wc2.GetMemoryStream.Write(b[0], sizeof(b[0]) * 2);
                        ms2.Write(b[0],sizeof(b[0]) * 2);

                        // re-add the last character on the new line
                        wc2.Clear;
                        b[0] := last;
                        ms2.Write(b[0],sizeof(b[0]));
                        wc2.GetMemoryStream.Write(b[0],sizeof(b[0]));

                    end;
                end;
            until i = 0;

            wcbody.Clear;
            wcbody.GetMemoryStream.Write(ms2.Memory^, ms2.size);
            rbody := MeasureText(wcbody,'',true);
            ms2.Clear;
            myfree(ms2);
        end;
        wc2.Clear;
        myfree(wc2);  }
    end;

    procedure MeasureBodyText2;
    var wc2 : TWideChar;
        ms : TMemoryStream;
        ms2 : TMemorySTream;
        line : Trect;
        b : array[0..52] of word;
        i : integer;
        appendnewline : boolean;
    const    RESERVED_CHARS = 5;
    begin

        rbody := MeasureText(wcbody);
        {wc2 := TWideChar.Create;
        ms := wcbody.GetMemoryStream;
        appendnewline := false;
        if rbody.Right > self.maxwidth then begin
            ms2 := TMemoryStream.Create;
            ms.Seek(0,soFromBeginning);

            i := sizeof(b);
            repeat
                // read a buffer
                // and append it
                i := ms.Read(b, i);
                if i <> 0 then begin
                    ms2.Write(b[0],i);
                    ms2.write(b[0], sizeof(b[0]));  // nullterm
                end;

                line := MeasureText(ms2.memory, ms2.size, false);
                // keep appending until it's too long
                // then shrink it until it fits and add a newline
                if ((line.right-line.left) > self.MaxWidth) then begin
                    // undo the last reads/writes
                    // reread the same amount minus 1
                    ms.Seek(i*-1,soFromCurrent);
                    ms2.Seek(i*-1,soFromCurrent);
                    ms2.Size := ms2.size - i;
                    
                    i := abs(i) - (1 * sizeof(b[0]));
                    appendnewline := true;

                    
                end else begin
                    i := sizeof(b);
                    if appendnewline then begin
                        // too long line fixed, append a new line
                        //
                        b[0] := ord(#13);
                        b[1] := ord(#10);
                        ms2.Write(b, sizeof(b[0]) * 2);
                        appendnewline := false;
                    end;
                end;

            until i = 0;

            // include a nullterm and at lest 4 empty spots
            // for when DT_MODIFYSTRING is used
            for i  := 0 to (RESERVED_CHARS - 1) do begin
                b[i] := 0;
            end;
            ms2.Write(b, RESERVED_CHARS);

            wcbody.Clear;
            wcbody.GetMemoryStream.Write(ms2.Memory^, ms2.size);
            rbody := MeasureText(wcbody,'',true);
            ms2.Clear;
            myfree(ms2);
        end;
        wc2.Clear;
        myfree(wc2);
        }
    end;


begin
    if UseHelpString  then
        lblHeader.Caption := HELP_STRING;
    if header <> '' then
        lblHeader.Caption := header;

    //lblBody.Caption := PWideChar(inwc.memory);
    rbody := rect(0,0,maxwidth,maxheight);

    if inwc <> nil then begin
        wcbody.clear;
        wcbody.Append(inwc);
    end;

    MeasureBodyText;

    SetPosition(pos);
    rbody.Top := lblSpacer.BoundsRect.Bottom;
    //lblBody.Caption := PWideChar(wcbody.memory);

    self.width := self.width + WND_MARGIN * 2;
    inc(rbody.Left, WND_MARGIN div 2);
    inc(rbody.Right, WND_MARGIN div 2);
    DoShow;

end;

end.
