destructor TToolTip.Destroy; var I: Integer; tmpTipInfo: PTipInfo; begin if fTipHandle <> 0 then CloseWindow(fTipHandle); for I := Flist.Count - 1 downto 0 do // Iterate begin tmpTipInfo := PTipInfo(FList.Items[i]); Dispose(tmpTipInfo); end; // for Flist.Free; ApplicationEvents.Free; DeallocateHWnd(fWindowHandle); inherited Destroy; end;
function TipWndProc(WinHanlde, MessageID, WParam, LParam: LongWord): Longint; stdcall; begin result := CallWindowProc(DefTipProc, WinHanlde, messageid, wparam, lparam); case messageid of WM_Lbuttondown, WM_RButtondown, wm_NCLbuttondown, WM_NCRButtondown: SendMessage(WinHanlde, TTM_TRACKACTIVATE, Integer(false), 0); end; end;
constructor TToolTip.Create(AOwner: TComponent); begin inherited Create(AOwner);
if not (AOwner is TWinControl) then begin raise exception.Create('TToolTip''s owner must be a ''TWinControl'' type.'); Destroy; end;
fWindowHandle := Classes.AllocateHWnd(WndProc);
fEnabled := False; fInterval := 1000;
//创建气泡提示窗口 fTipHandle := CreateWindow(TOOLTIPS_CLASS, nil, WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP, // or TTS_CLOSE, 0, 0, 0, 0, fWindowHandle, 0, HInstance, nil);
defTipProc := pointer( GetWindowLong(FTipHandle, GWL_WndProc)); SetWindowLong(FTipHandle, GWL_WNDPROC, longint(@TipwndProc)); if fTipHandle <> 0 then begin //设置ToolInfo的大小 fToolInfo.cbSize := SizeOf(fToolInfo); //设置基本风格 fToolInfo.uFlags := TTF_PARSELINKS or TTF_IDISHWND or TTF_TRACK; //设置所有者的句柄 fToolInfo.uId := fWindowHandle; end; Flist := TList.Create; ApplicationEvents := TApplicationEvents.Create(nil); ApplicationEvents.OnMessage := ApplicationEvents1Message; end;
destructor TToolTip.Destroy; var I: Integer; tmpTipInfo: PTipInfo; begin if fTipHandle <> 0 then CloseWindow(fTipHandle); for I := Flist.Count - 1 downto 0 do // Iterate begin tmpTipInfo := PTipInfo(FList.Items[i]); Dispose(tmpTipInfo); end; // for Flist.Free; ApplicationEvents.Free; inherited Destroy; end;
procedure TToolTip.SetText(AText: string); begin fText := AText;
if fTipHandle <> 0 then begin //设置标题信息 fToolInfo.lpszText := PAnsiChar(fText); //向气泡窗体发送消息,将ToolInfo的信息设置到气泡窗体中 SendMessage(fTipHandle, TTM_ADDTOOL, 0, Integer(@fToolInfo)); SendMessage(fTipHandle, TTM_SETTOOLINFO, 0, Integer(@fToolInfo)); end; end;
procedure TToolTip.SetTitle(ATitle: string); begin fTitle := ATitle;
if fTipHandle <> 0 then //设置气泡窗体的提示图标和标题信息 SendMessage(fTipHandle, TTM_SETTITLE, Integer(fTipIcon), Integer(fTitle)); end;
procedure TToolTip.Popup(Handle: HWND); var tmpRect: TRect; x, y: word; begin x := 0;
fControl := FindControl(Handle); if fControl.Hint <> '' then fControl.ShowHint := False;
//得到需要显示窗体所在的屏幕区域 GetWindowRect(Handle, tmpRect);
//计算显示区域位置的坐标 with tmpRect do begin y := (Bottom - Top) div 2 + Top;
case fAlignment of taLeft: x := Left; taCenter: x := (Right - Left) div 2 + Left; taRight: x := Right; end; end;
procedure TToolTip.WndProc(var Msg: TMessage); begin fEnabled := False; with Msg do begin case Msg of WM_TIMER: try SendMessage(fTipHandle, TTM_TRACKACTIVATE, Integer(False), Integer(@fToolInfo)); if fControl.Hint <> '' then fControl.ShowHint := True; except Application.HandleException(Self); end; else Result := DefWindowProc(fWindowHandle, Msg, wParam, lParam); end; end; //更新计时器状态 UpdateTime; end;
procedure TToolTip.UpdateTime; begin KillTimer(fWindowHandle, 1); if (FInterval <> 0) and FEnabled then if SetTimer(fWindowHandle, 1, FInterval, nil) = 0 then raise EOutOfResources.Create(SNoTimers); end;
procedure Register; begin RegisterComponents('ToolTip', [TToolTip]); end;
procedure TToolTip.ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean); var I: Integer; tmpTipInfo: PTipInfo; tmpPoint: TPoint; tmpHandle: THandle; begin if Msg.message = WM_LBUTTONUP then begin GetCurSorPos(tmpPoint); tmpHandle := WindowFromPoint(tmpPoint); if FLastHandle <> tmpHandle then //防止不停触发 begin FLastHandle := tmpHandle; for I := 0 to FList.Count - 1 do // Iterate begin tmpTipInfo := PTipInfo(FList.Items[i]); //只有调用了BeginHelp,才会弹出提示窗口 if (tmpTipInfo.Handle = tmpHandle) and (tmpTipInfo.WinControl.Cursor = crHelp) then begin Popup(tmpHandle, tmpTipInfo.TipICON, tmpTipInfo.Caption, tmpTipInfo.Msg); break; end; end; // for EndHelp; DefWindowProc(Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam); end; end;
end;
procedure TToolTip.BeginHelp; var i: Integer; tmpTipInfo: PTipInfo; begin for I := 0 to FList.Count - 1 do // Iterate begin tmpTipInfo := PTipInfo(FList.Items[i]); tmpTipInfo.WinControl.Cursor := crHelp; end; // for end;
procedure TToolTip.EndHelp; var i: Integer; tmpTipInfo: PTipInfo; begin for I := 0 to FList.Count - 1 do // Iterate begin tmpTipInfo := PTipInfo(FList.Items[i]); tmpTipInfo.WinControl.Cursor := tmpTipInfo.Cursor; end; // for end;
又看到一个BUG ApplicationEvents1Message ... if (tmpTipInfo.Handle = tmpHandle) and (tmpTipInfo.WinControl.Cursor = crHelp) then begin fAlignment := tmpTipInfo.TipAlg;//少了这个,无法使用位置控制