home *** CD-ROM | disk | FTP | other *** search
/ Softwarová Záchrana 3 / Softwarova-zachrana-3.bin / ArsClip / source.zip / UnitFrmDummyUnicodeTooltip.pas < prev    next >
Pascal/Delphi Source File  |  2004-05-28  |  9KB  |  381 lines
  1. unit UnitFrmDummyUnicodeTooltip;
  2.  
  3. {
  4.     Purpose:
  5.         Gather up all the logic needed to display Unicode in a Tooltip
  6.         I have to parasite The TTooltip to a form so it can specify
  7.         the NotifyFOrmat
  8.  
  9. }
  10. interface
  11.  
  12. uses
  13.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  14.   Dialogs, ExtCtrls,
  15.  
  16.   UnitTWideChar, UnitClipQueue;
  17.  
  18.  
  19.  
  20. type TTooltipWindow = class(THintWindow)
  21.     private
  22.         ShowingHint : boolean;
  23.         MaxWidth : cardinal;
  24.  
  25.         hwndTip : THandle;
  26.         LastPoint : TPoint;
  27.     protected
  28.         HittestActive : boolean;
  29.         procedure AlterSizePosition(var r : TRect; Pos : TPoint);
  30.         //procedure WMNCHitTest(VAR Msg: TWMNcHitTest); message WM_NCHITTEST;
  31.     public
  32.         constructor Create; reintroduce;
  33.         destructor Destroy; override;
  34.  
  35.         procedure SetMaxWidth(max : cardinal);
  36.         procedure ShowTooltip(s : string; Pos : TPoint); overload;
  37.         procedure ShowTooltip(ci : TClipItem; Pos : TPoint); overload;
  38.         procedure ShowTooltip(wc : TWideChar; Pos : TPoint); overload;
  39.         procedure CloseTooltip;
  40.  
  41.         function IsHit(Pos : TPoint) : boolean;
  42.  
  43. end;
  44.  
  45.  
  46.  
  47.  
  48. type
  49.   TFrmDummyUnicodeTooltip = class(TForm)
  50.     procedure FormCreate(Sender: TObject);
  51.   private
  52.     { Private declarations }
  53.  
  54.     LastHint : string;
  55.     LastClipItem : TClipItem;
  56.     TooltipWindows : TTooltipWindow;
  57.     wc : TWideChar;
  58.  
  59.     {For Unicode Popup}
  60.     procedure WMNotifyFormat(var msg : TWMNotifyFormat); message WM_NOTIFYFORMAT;
  61.     procedure WMNotify(var msg : TWMNotify); message WM_NOTIFY;
  62.  
  63.  
  64.   public
  65.     procedure SetLastClip(ci : TClipItem); overload;
  66.     procedure SetLastClip(s : string); overload;
  67.     procedure SetLastClip(wcc : TWideChar); overload;
  68.  
  69.     { Public declarations }
  70.   end;
  71.  
  72. var
  73.   FrmDummyUnicodeTooltip: TFrmDummyUnicodeTooltip;
  74.  
  75. implementation
  76.  
  77. {$R *.dfm}
  78.  
  79. uses CommCtrl, UnitMisc, Math;
  80.  
  81.  
  82. { TTooltipWindow }
  83.  
  84. procedure TTooltipWindow.CloseTooltip;
  85. var ti : TOOLINFOW;
  86. begin
  87.     Windows.SetLastError(ERROR_SUCCESS);
  88.  
  89.     self.ReleaseHandle;
  90.     self.ShowingHint := false;
  91.  
  92.     if (hwndTip <> 0) then begin
  93.         fillchar(ti, sizeof(ti), #0);
  94.         ti.cbSize := sizeof(TOOLINFO);
  95.         ti.uFlags   := TTF_SUBCLASS;
  96.         ti.hInst := hInstance; // ??
  97.  
  98.         // only hwndTip, .uId, cbSize are used, all else is ignored
  99.         SendMessage(hwndTip, TTM_TRACKACTIVATE, Integer(false), Integer(@ti));
  100.  
  101.         Windows.DestroyWindow(hwndTip);
  102.     end;
  103.  
  104.     hwndTip := 0;
  105. end;
  106.  
  107. constructor TTooltipWindow.Create;
  108. begin
  109.     inherited Create(FrmDummyUnicodeTooltip);
  110.     self.MaxWidth := 300;
  111.  
  112.     self.Font.Name := 'Arial';
  113.     self.Color := Graphics.clInfoBk;
  114. end;
  115.  
  116. destructor TTooltipWindow.Destroy;
  117. begin
  118.   inherited;
  119. end;
  120.  
  121. procedure TTooltipWindow.SetMaxWidth(max: cardinal);
  122. begin
  123.     MaxWidth := max;
  124. end;
  125.  
  126.  
  127. procedure TTooltipWindow.AlterSizePosition(var r: TRect; Pos : TPoint);
  128. begin
  129.     if self.MaxWidth <> 0 then begin
  130.         if (r.Bottom - r.top) > self.MaxWidth then r.Bottom := r.top + self.MaxWidth;
  131.     end;
  132.  
  133.     inc(r.Top, Pos.y );
  134.     inc(r.Bottom, Pos.Y );
  135.     inc(r.Left, Pos.X );
  136.     inc(r.right, Pos.X );
  137. end;
  138.  
  139.  
  140. procedure TTooltipWindow.ShowTooltip(s: string; Pos : TPoint);
  141. var r : TRect;
  142. begin
  143.     UnitMisc.AppendLog('ShowTooltip(s,pos)');
  144.     self.LastPoint := pos;
  145.  
  146.     if self.ShowingHint then EXIT;
  147.     self.ShowingHint := true;
  148.     FrmDummyUnicodeTooltip.SetLastClip(s);
  149.  
  150.     if (s <> '') then begin
  151.         r := self.CalcHintRect(180, s, nil);
  152.         self.AlterSizePosition(r, Pos);
  153.  
  154.         self.ActivateHint(r, s);
  155.  
  156.     end else begin
  157.         self.CloseTooltip;
  158.     end;
  159. end;
  160.  
  161.  
  162. procedure TTooltipWindow.ShowTooltip(wc: TWideChar; Pos: TPoint);
  163. var r : TRect;
  164.     ti : TOOLINFOw;
  165. begin
  166.     Windows.SetLastError(ERROR_SUCCESS);
  167.  
  168.     UnitMisc.AppendLog('ShowTooltip(wc,pos)');
  169.     self.LastPoint := pos;
  170.  
  171.     if self.ShowingHint then EXIT;
  172.     self.ShowingHint := true;
  173.  
  174.     FrmDummyUnicodeTooltip.SetLastClip(wc);
  175.  
  176.     r := Rect(0, 0, Self.MaxWidth, 0);
  177.     DrawTextW(self.Canvas.Handle, wc.Memory, (-1),
  178.         r,
  179.         DT_CALCRECT or DT_LEFT or
  180.         DT_WORDBREAK or DT_NOPREFIX or DrawTextBiDiModeFlagsReadingOnly);
  181.     Inc(r.right, 6);
  182.     Inc(r.bottom, 2);
  183.     self.AlterSizePosition(r, Pos);
  184.  
  185.     //
  186.     // Set the size & text callback options
  187.     //
  188.  
  189.     fillchar(ti, sizeof(ti), #0);
  190.     ti.cbSize := sizeof(TOOLINFO);
  191.     ti.uFlags := TTF_SUBCLASS or TTF_TRACK or TTF_ABSOLUTE; // Docs never said anything about TTF_TRACK!
  192.     ti.hwnd := FrmDummyUnicodeTooltip.handle;
  193.     ti.uId := 0;
  194.  
  195.     ti.lpszText := LPSTR_TEXTCALLBACKw;
  196.     ti.hInst := hInstance;
  197.  
  198.     ti.rect.Top  := r.top;
  199.     ti.rect.Bottom  := r.Bottom;
  200.     ti.rect.Right  := r.Right;
  201.     ti.rect.Left   := r.Left;
  202.  
  203.  
  204.     //
  205.     // Create, set max width, activate, and set position
  206.     //
  207.     hwndTip := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil,
  208.                   TTS_ALWAYSTIP or TTS_NOPREFIX or WS_POPUP,
  209.                   0,0,0,0, FrmDummyUnicodeTooltip.handle, 0, hInstance, nil);
  210.  
  211.     SetWindowPos(hwndTip, HWND_TOPMOST, 0, 0, 0, 0,
  212.         SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  213.  
  214.     SendMessage(hwndTip, TTM_SETMAXTIPWIDTH, 0, Self.MaxWidth);
  215.  
  216.     SendMessage(hwndTip, TTM_ADDTOOL, 0, Integer(@ti));
  217.     SendMessage(hwndTip, TTM_TRACKPOSITION, 0, MakeLong(pos.x, pos.y));
  218.     SendMessage(hwndTip, TTM_TRACKACTIVATE, Integer(true),
  219.         Integer(@ti));
  220.  
  221.  
  222.  
  223. end;
  224.  
  225. procedure TTooltipWindow.ShowTooltip(ci: TClipItem; Pos : TPoint);
  226. var wcc : TWideChar;
  227. begin
  228.     Windows.SetLastError(ERROR_SUCCESS);
  229.  
  230.     self.LastPoint := pos;
  231.     //
  232.     // Only Unicode items are show directly in this method
  233.     //
  234.     if (ci.GetFormat <> CF_UNICODETEXT) then begin
  235.         Self.ShowTooltip(ci.GetAsText, Pos);
  236.         EXIT;
  237.     end;
  238.  
  239.     //
  240.     // Set size based on size of text
  241.     //
  242.     wcc := TWideChar.Create;
  243.     wcc.Append(ci.getHandle, ci.GetDataSize );
  244.  
  245.     self.ShowTooltip(wcc, pos);
  246.  
  247.     wcc.Clear;
  248.     MyFree(wcc);
  249. end;
  250.  
  251.  
  252.  
  253. {
  254. //
  255. // Removed - inconsistant!
  256. // A plain text item would receive this message, a unicode text item
  257. // would not
  258. // REPLACED with IsHit
  259. procedure TTooltipWindow.WMNCHitTest(var Msg: TWMNcHitTest);
  260. }
  261. function TTooltipWindow.IsHit(Pos: TPoint): boolean;
  262. var r : TRect;
  263. begin
  264.     Windows.SetLastError(ERROR_SUCCESS);
  265.     if (hwndTip <> 0) then begin
  266.         windows.GetClientRect(hwndTip, r);
  267.     end else begin
  268.         r := Self.GetClientRect;
  269.     end;
  270.  
  271.     inc(r.left, LastPoint.x);
  272.     inc(r.Right, LastPoint.X);
  273.     inc(r.Top, lastpoint.Y);
  274.     inc(r.Bottom, Lastpoint.y);
  275.     result := Windows.PtInRect(r, Pos);
  276.  
  277.     {
  278.     // DOES NOT WORK!!!!!! Damn MS documentation
  279.     // unable to find any case where it fires a true result
  280.     fillchar(hi,sizeof(hi),#0);
  281.  
  282.     hi.pt.x := Pos.x;
  283.     hi.pt.y := Pos.Y;
  284.     hi.hwnd := self.hwndTip;
  285.     hi.ti.cbSize := sizeof(hi.ti);
  286.  
  287.  
  288.     result := (Windows.SendMessage(self.hwndTip, TTM_HITTEST, 0,Integer(@hi)) <> 0);
  289.     }
  290. end;
  291.  
  292.  
  293. { TFrmDummyUnicodeTooltip }
  294.  
  295. //
  296. // I'm created, then multiple calls to Show/Close Tooltip
  297. //
  298. procedure TFrmDummyUnicodeTooltip.FormCreate(Sender: TObject);
  299. begin
  300.     TooltipWindows := TTooltipWindow.Create;
  301.     wc := TWideChar.Create;
  302. end;
  303.  
  304.  
  305. //
  306. // Callbacks used when UNICODE is sent via the ShowTooltip method
  307. // Say "I've got Unicode" for the format
  308. // Say, "Here's the string you asked for" for the content
  309. //
  310. procedure TFrmDummyUnicodeTooltip.WMNotifyFormat(var msg: TWMNotifyFormat);
  311. begin
  312.     if (self.wc.size <> 0) then begin
  313.         msg.Result := NFR_UNICODE;
  314.     end else begin
  315.         msg.Result := NFR_ANSI;
  316.     end;
  317. end;
  318.  
  319. procedure TFrmDummyUnicodeTooltip.WMNotify(var msg: TWMNotify);
  320. const TTN_FIRST = $-520;
  321. const TTN_GETDISPINFO = (TTN_FIRST - 0);
  322. const TTN_GETDISPINFOW = (TTN_FIRST - 10);
  323.  
  324. var pdiw : ^tagNMTTDISPINFOW;
  325.     pdia : ^tagNMTTDISPINFO;
  326.  
  327. begin
  328.     // Tell the popup what text to show
  329.     //
  330.     // NOTE: This string must exist while the tooltip is being shown
  331.     // Bad, bad, bad things happen when the string disappears
  332.     //
  333.  
  334.     if msg.NMHdr^.code  = TTN_GETDISPINFOW then begin
  335.         pdiw := Pointer(TMessage(msg).lparam);
  336.         {if (self.LastClipItem <> nil) then begin
  337.             wc.Clear;
  338.             wc.Append(self.LastClipItem.getHandle, self.LastClipItem.GetDataSize);
  339.             wc.LeftStr(600);
  340.         end;}
  341.         wc.LeftStr(600);
  342.         pdiw.lpszText := wc.Memory;
  343.  
  344.         msg.Result := 0;
  345.     end else if msg.NMHdr^.code  = TTN_GETDISPINFO then begin
  346.         pdia := Pointer(TMessage(msg).lparam);
  347.         pdia.lpszText := PChar(self.LastHint);
  348.         pdia.hinst := 0;
  349.  
  350.         msg.Result := 0;
  351.     end;
  352.  
  353. end;
  354.  
  355.  
  356.  
  357.  
  358. procedure TFrmDummyUnicodeTooltip.SetLastClip(ci: TClipItem);
  359. begin
  360.     self.LastClipItem := ci;
  361.     self.LastHint := '';
  362. end;
  363.  
  364. procedure TFrmDummyUnicodeTooltip.SetLastClip(s: string);
  365. begin
  366.     self.LastHint := s;
  367.     self.LastClipItem := nil;
  368.     self.wc.Clear;
  369. end;
  370.  
  371. procedure TFrmDummyUnicodeTooltip.SetLastClip(wcc: TWideChar);
  372. begin
  373.     self.wc.clear;
  374.     self.wc.Append(wcc);
  375.     self.LastHint := '';
  376.     self.LastClipItem := nil;
  377. end;
  378.  
  379.  
  380. end.
  381.