捐赠 | 广告 | 注册 | 发布 | 上传 | 关于我们    
  沪ICP备05001939号 DELPHI盒子 | 盒子论坛 | 盒子文章 | 盒子问答悬赏 | 最新更新 | 论坛检索 | 下载中心 | 高级搜索    
  精品专区 | 繁體中文 | 奖励公告栏 | 直通车账号登陆 | 关闭GOOGLE广告 | 临时留言    
 
广告
评论:TToolTip 提示组件BUG修正
qq757526555 34103 2008/5/15 20:24:44
project1的程序运行后,提示框出现在窗体后面了,怎么让它确定位置.
james_ 32456 2007/12/30 9:46:00
又发现一个bug,Destroy时没有
  DeallocateHWnd(fWindowHandle);
造成ls的问题。

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;
zh2000 32414 2007/12/26 10:09:47
好像用上面那个版本退出时都出现.
"....内存不能 read" 是不是我那里设置问题了..我用D7...
ghs_79 32409 2007/12/26 8:45:29
yangmaqi 的思路是想把这个功能做提示用,而不是帮助.
至于能当做什么用,大家发挥想象任意使用.便有了新的用法,或者修改了代码,请贴出来,大家交流,也方便他人.
wiseinfo 32402 2007/12/25 14:11:28
怎么让那个汽泡倒个方面哦,箭头向下,汽泡在上,??
wiseinfo 32401 2007/12/25 13:43:45
原作者ghs_79实现的what is help,其实这功能不实用,按照yangmaqi 的思路在界面某个位置能够POPUP一个提示更实用些,
ruralboy 32376 2007/12/22 21:26:57
谢谢馒头把它表出来:)

关键代码只是这里: 

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;
zizii 32375 2007/12/22 19:44:05
TooltipUtil.pas

{
    修改者:ghs
    日期:20071218
    功能:在原版本的基础上增加。
          RegisterControl:注册需要提示的控件。
          BeginHelp:设置光标状态为帮助crHelp;
          鼠标弹起后,显示注册的提示信息,同时光标进行还原。
          
   原版本
   作者:thaoqi
   出处:http://www.2ccc.com/article.asp?articleid=4389
   功能:首先谢谢xsherry大大,来盒子很长一段时间了,老是下东西,没有为盒子做什么贡献。
        前段时间xsherry大大抛砖引玉的文章,给我启发很大,最近一个项目提出要求人
        机交互界面更加有好,尽量少用MessageBox,所以在他的基础上,我试图模仿XP
        登录时候的那个ToolTip提示功能,用API摸索出一个符合要求的ToolTip提示框出
        来,最后我把实现的函数封装成了一个VCL的控件,希望大家能多提意见!
}
unit TooltipUtil;

interface

uses Messages, Windows, SysUtils, Classes, Contnrs, Controls, CommCtrl,
  StdCtrls, ExtCtrls, Consts, Forms, Dialogs, AppEvnts;

type
  TTipTool_ICON = (ttNoneIcon, ttInformationIcon, ttWarningIcon, ttStopIcon);
  TTipAlignment = (taLeft, taCenter, taRight);

  PTipInfo = ^TTipInfo;
  
  TTipInfo = packed record
    WinControl: TWinControl;
    Handle: THandle;
    Caption: string;
    Msg: string;
    TipICON: TTipTool_ICON;
    TipAlg: TTipAlignment;
    Cursor: TCursor;
  end;
  
  TToolTip = class(TComponent)
  private
    fTitle: string;
    fText: string;
    fEnabled: Boolean;
    fWindowHandle: HWND;
    fTipHandle: HWND;
    fInterval: Cardinal;
    fToolInfo: TToolInfo;
    fAlignment: TTipAlignment;
    fTipIcon: TTipTool_ICON;
    fControl: TWinControl;
    //
    Flist: TList;
    ApplicationEvents: TApplicationEvents;
    FLastHandle: THandle;

    procedure SetText(AText: string); //设置气泡提示信息
    procedure SetTitle(ATitle: string); //设置气泡提示的标题

    procedure UpdateTime; //更新计时器状态
    procedure WndProc(var Msg: TMessage); //接收windows消息
  protected
    //拦截消息=处理左键弹起
    procedure ApplicationEvents1Message(var Msg: tagMSG;
      var Handled: Boolean);
    //结束帮助=设置光标为控件本来状态  
    procedure EndHelp;  
    //下面两个过程原版在Public区,为了不让调用
    procedure Popup(Handle: HWND); overload; //在指定的句柄中弹出气泡(重载)
    procedure Popup(Handle: HWND; IconType: TTipTool_ICON; Title,
      Text: string); overload; //在指定的句柄中弹出气泡(重载)
  public
    constructor Create(AOwner: TComponent); override; //构造函数,创建实例
    destructor Destroy; override; //析构函数,销毁实例
    //注册控件信息
    procedure RegisterControl(WinControl: TWinControl; aCaption, aMsg: string;
      TipICON: TTipTool_ICON = ttInformationIcon; TipAlignment: TTipAlignment = taLeft);
    //开始帮助=设置光标状态
    procedure BeginHelp;
      
  published
      //气泡窗体的窗体句柄
    property Handle: HWND read fTipHandle;
      //气泡窗体的提示信息
    property Text: string read fText write SetText;
      //气泡窗体的标题信息
    property Title: string read fTitle write SetTitle;
      //气泡窗体的信息图标
    property ICON: TTipTool_ICON read fTipIcon write fTipIcon;
      //气泡窗体弹出时对齐位置
    property Alignment: TTipAlignment read fAlignment write fAlignment default taLeft;
      //气泡窗体的显示时间
    property Interval: Cardinal read fInterval write fInterval default 1000;
  end;

procedure Register;

implementation

const
  TTS_BALLOON = $0040; //ToolTip提示窗口的外形,指定为气球型
  TTS_CLOSE = $0080; //关闭按钮
  TTF_PARSELINKS = $1000; //可使用超链接
  TTM_SETTITLE = WM_USER + 32; //社这提示标题信息的消息

var
  DefTipProc: Pointer;

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;

  //设置气泡窗体弹出的坐标
  SendMessage(fTipHandle, TTM_TRACKPOSITION, 0, MAKELONG(x, y));
  //激活气泡窗体,并显示出来
  SendMessage(fTipHandle, TTM_TRACKACTIVATE, Integer(True), Integer(@fToolInfo));

  fEnabled := True;
  //更新计时器状态
  UpdateTime;
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.Popup(Handle: HWND; IconType: TTipTool_ICON;
  Title: string; Text: string);
begin
  fTipIcon := IconType;

  SetTitle(Title);
  SetText(Text);

  Popup(Handle);
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.RegisterControl(WinControl: TWinControl; aCaption, aMsg: string;
  TipICON: TTipTool_ICON = ttInformationIcon; TipAlignment: TTipAlignment = taLeft);
var
  TipInfo: PTipInfo;  
begin
  New(TipInfo);
  TipInfo.WinControl := WinControl;
  TipInfo.Handle := WinControl.Handle;
  TipInfo.Caption := aCaption;
  Tipinfo.Msg := aMsg;
  TipInfo.TipICON := TipICON;
  TIpInfo.TipAlg := TipAlignment;
  TipInfo.Cursor := WinControl.Cursor;
  
  Flist.Add(TipInfo);
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;

end.
zh2000 32370 2007/12/22 10:22:24
那可不可以 点击 帮助后,每点击一下 EDIT 都出阿(连续点击都出).....那就不用每看一下都点击一下了...
ruralboy 32360 2007/12/21 16:15:47
不妥, hint 是平凡跳出的,不兼容 :)
ruralboy 32359 2007/12/21 16:13:03
这样麻烦,我看看能否用 THintWindow 方式实现
yangmaqi 32353 2007/12/21 13:36:55
又一改法,大家把TooltipUtil.pas打开
把 protected 下面
    procedure Popup(Handle: HWND); overload; 
    procedure Popup(Handle: HWND; IconType: TTipTool_ICON; Title,
      Text: string); overload;
移到   public 下面去
程序中调用时用
var
  sText:string;
begin
  if LabeledEdit1.Text ='' then
  begin
    sText:='请在这里输入登录用的用户名';
    ToolTip1.Popup(TWinControl(LabeledEdit1).Handle, ttInformationIcon,
          '帮助信息', sText);
    Exit;
  end;
  if LabeledEdit2.Text ='' then
  begin
    sText:='请在这里输入登录用的用户密码';
    ToolTip1.Popup(TWinControl(LabeledEdit2).Handle, ttInformationIcon,
          '帮助信息', sText);
    Exit;          
  end;
end;
把此代码放在一个按钮事件中
当第一个框没有输入信息时则会用球形提示
当第二个框没有输入信息时也会用球形提示

这样可以在程序某些文本框输入异常时给于提示,不用弹出一些什么ShowMessage,MessageBox用这个显示比较柔和些。
ghs_79 32351 2007/12/21 9:16:17
这个不小的BUG,
客户说这个功能挺好,因为有些人电脑基础差,想让提示挺下来,慢慢看.通过提示可以知道怎么操作.
ghs_79 32350 2007/12/21 9:11:06
盒友反应好迅速呀,
james_ 32344 2007/12/20 22:50:44
又看到一个BUG
ApplicationEvents1Message
...
        if (tmpTipInfo.Handle = tmpHandle) and (tmpTipInfo.WinControl.Cursor =
          crHelp) then
        begin
          fAlignment := tmpTipInfo.TipAlg;//少了这个,无法使用位置控制
zh2000 32343 2007/12/20 22:34:45
请问这个可以当一般的 hint 用吗?
即当鼠标移动到edit时显示 hint内容?..........
ruralboy 32339 2007/12/20 20:51:33
已经修改了, 存放上 盒子ftp,文件名为: debuged_TooltipUtil.rar

不知道馒头知不知道这个单元文件.
ruralboy 32338 2007/12/20 19:03:34
基于程序员普片最求完美的心态来讲,点击问题应该算是不小的 BUG 了.

晚上有时间的话,我试试看完善它
第一页 上一页 下一页 最后页 有 18 条纪录 共1页 1 - 18
 用户名:
 密 码:
自动登陆(30天有效)
 
  DELPHI盒子版权所有 1999-2023 V4.01 粤ICP备10103342号-1 更新RSS列表