导航:
论坛 -> DELPHI技术
斑竹:liumazi,sephil
作者:
2004/3/1 18:38:19
标题:
在这里看到一个做提示汽泡的代码,我改成VCL后就不能用了,各位老大帮忙看看吧!
浏览:1382
加入我的收藏
楼主:
unit LSTip; interface uses Windows, Messages, SysUtils, Variants, Classes,commctrl,Graphics,DesignIntf,TypInfo,Controls; //---------这是别人的代码-------- const TTS_BALLOON = $40; TTM_SETTITLE = (WM_USER + 32); //------------------------------ type TLSTip = class(TComponent) private { Private declarations } FBackColor:TColor; FTextColor:TColor; FTitle:string; //---------这是别人的代码-------- hTooltip: Cardinal; ti: TToolInfo; buffer : array[0..255] of char; procedure CreateToolTips(hWnd: Cardinal); procedure AddToolTip(hwnd: dword; lpti: PToolInfo; IconType: Integer; Text, Title: PChar; BackColor,TextColor:TColor); //---------------------------------------- protected { Protected declarations } public { Public declarations } constructor Create(AOwner: TComponent); override; procedure SetupTip; published { Published declarations } property BackColor:TColor read FBackColor write FBackColor; property TextColor:TColor read FTextColor write FTextColor; property Title:string read FTitle write FTitle; end; procedure Register; implementation procedure Register; begin RegisterComponents('LSSoft', [TLSTip]); end; //---------这是别人的代码-------- procedure TLSTip.CreateToolTips(hWnd: Cardinal); begin hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON, Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil); if hToolTip <> 0 then begin SetWindowPos(hToolTip, HWND_TOPMOST, 0,0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE); ti.cbSize := SizeOf(TToolInfo); ti.uFlags := TTF_SUBCLASS or TTF_TRANSPARENT; ti.hInst := hInstance; end; end; procedure TLSTip.AddToolTip(hwnd: dword; lpti: PToolInfo; IconType: Integer; Text, Title: PChar; BackColor,TextColor:TColor); var Rect: TRect; begin if (hwnd <> 0) AND (GetClientRect(hwnd, Rect)) then begin lpti.hwnd := hwnd; lpti.Rect := Rect; lpti.lpszText := Text; SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti)); FillChar(buffer, sizeof(buffer), #0); lstrcpy(buffer, Title); if (IconType > 3) or (IconType < 0) then IconType := 0; if BackColor<>0 then SendMessage(hToolTip, TTM_SETTIPBKCOLOR, BackColor, 0); if TextColor<>0 then SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, TextColor, 0); SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer)); end; end; //----------------------------- //--------------以上两个过程用于添加汽泡,是别人的代码-------- //-------------以下是我写的------------------------------ procedure TLSTip.SetupTip; var i:integer;propinfo:PPropInfo;Phandle:thandle;Vstr:string; begin for i:=0 to self.ComponentCount -1 do //进行组件的查找 begin propinfo:=GetPropInfo(components[i],'Handle');//检查是否有HANDLE属性 if propinfo<>nil then //如果有HANDLE则继续 begin Phandle:=GetPropValue(components[i],'Handle');//保存这个HANDLE propinfo:=GetPropInfo(components[i],'Hint');//检查是否有HINT属性 if propinfo<>nil then//如果有HINT则继续 begin CreateToolTips(Phandle);//调用过程CreateToolTips Vstr:=GetPropValue(components[i],'Hint');//取出HINT的值 AddToolTip(Phandle, @ti, 1, Pchar(Vstr),pchar(FTitle),FBackColor,FTextColor); end; end; end; end; constructor TLSTip.Create(AOwner: TComponent); begin inherited; FTitle:='提示'; end; end.
----------------------------------------------
^-^lifencheng^0^
作者:
2004/3/1 19:34:58
1楼:
错啦错啦,这段代码根本就是错误,各位对不起啦,老大删了吧 procedure TLSTip.SetupTip; var i:integer;propinfo:PPropInfo;Phandle:thandle;Vstr:string; begin for i:=0 to self.ComponentCount -1 do //进行组件的查找 begin propinfo:=GetPropInfo(components[i],'Handle');//检查是否有HANDLE属性 if propinfo<>nil then //如果有HANDLE则继续 begin Phandle:=GetPropValue(components[i],'Handle');//保存这个HANDLE propinfo:=GetPropInfo(components[i],'Hint');//检查是否有HINT属性 if propinfo<>nil then//如果有HINT则继续 begin CreateToolTips(Phandle);//调用过程CreateToolTips Vstr:=GetPropValue(components[i],'Hint');//取出HINT的值 AddToolTip(Phandle, @ti, 1, Pchar(Vstr),pchar(FTitle),FBackColor,FTextColor); end; end; end; end;
----------------------------------------------
^-^lifencheng^0^