delphi替换QQ托盘图标演示

Pascal编程基础

下载此实例

开发语言：Pascal
实例大小：0.30M
下载次数：11
浏览次数：197
发布时间：2019-12-28
实例类别：Pascal编程基础
发布人：女生宿舍卖黄瓜
文件格式：.rar
所需积分：2

实例介绍

[下载地址]

【实例简介】

【实例截图】

from clipboard

【核心代码】

unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, CommCtrl, ShellApi, uZHint, uHint2, XPMan, uNotifyIcon,
  Menus, ImgList, ExtCtrls, uTrayIconInject;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    ZHint1: TZHint;
    Memo1: TMemo;
    Edit1: TEdit;
    CheckBox1: TCheckBox;
    PopupMenu1: TPopupMenu;
    sdfsadf1: TMenuItem;
    asdfasfsadf1: TMenuItem;
    IL: TImageList;
    Timer1: TTimer;
    Button4: TButton;
    Button5: TButton;
    IL2: TImageList;
    Button6: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Button3Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
  private
    { Private declarations }
    Tray: TTrayIcon;
    FHint2: THint2;
    FOldPos: TPoint;
    FCapture: Boolean;
    FCount: Integer;
    FFram: Integer;
    Extra: TTButtonExtraInfo;
    procedure PopTip;
    procedure OnShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses Types;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Tray.IconCount >= IL.Count then
    Exit;
  
  IL.GetIcon(Tray.IconCount, Icon);
  Tray.NotifyIcon('Tray'   IntToStr(GetTickCount), Icon.Handle,  '自定义提示', '已加入到通知区域 '
      FormatDateTime('yyyy-mm-dd hh:mm:ss', Now), [ntIcon, ntInfo, ntMouseHint], True);
end;

{ TTrayIcon }


procedure TForm1.FormCreate(Sender: TObject);
begin
  Tray := TTrayIcon.Create;
  Tray.Menu := PopupMenu1;
  FHint2 := THint2.Create('', '', 0);
  Application.OnShowHint := OnShowHint;
  Button1Click(Button1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Tray.RemoveIcon(0);

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Tray.Free;
  FHint2.Free;
end;

procedure TForm1.PopTip;
var
  Param: THintShowParam;
  Pos2: TPoint;
begin
  FillChar(Param, sizeof(Param), 0);
  GetCursorPos(Pos2);
  with Param do begin
    Param.Pos := Pos2;
    Param.Title := Edit1.Text;
    Param.Info := Memo1.Text;
    Param.TimeOut := 5000;
    Param.BkColor := clCream;
    Param.BorderColor := $968157;
    TitleBkColor := $00E2E1C7;//$00FF8080;
    TitleFont.Name := '宋体';
    TitleFont.Style := [fsBold];
    TitleFont.Color := clBlack;
    TitleFont.Size := 9;
    InfoFont.Name := 'MONO';
    InfoFont.Size := 9;
    TimeOut := 3000;
    if CheckBox1.Checked then
      Round := 3
    else
      Round := 0;

    ParentWnd := Handle;
    InfoFont.Color := clRed;
    Param.AlphaBlendValue := 255;
    Param.Flag := HF_ALPHABLEND;
  end;
  FHint2.ShowHint(Param);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
//
  FCapture := True;
  SetCapture(Handle);
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
//
  FCapture := False;
  ReleaseCapture;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
//
  if not FCapture then
    Exit;

  if (FOldPos.X <> X) or (FOldPos.Y <> Y) then  begin
    FOldPos.X := X;
    FOldPos.Y := Y;
    PopTip;
  end
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_ESCAPE then
    FHint2.HideHint;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
//
  Tray.NotifyIcon(0, Application.Icon.Handle, Edit1.Text, Memo1.Text, [ntIcon, ntInfo]);
end;

procedure TForm1.OnShowHint(var HintStr: string; var CanShow: Boolean;
  var HintInfo: THintInfo);
var
  Param: THintShowParam;
  Pos2: TPoint;
begin
  CanShow := False;
  FillChar(Param, sizeof(Param), 0);

  with Param do begin
    Windows.ClientToScreen(TWinControl(HintInfo.HintControl).Handle, HintInfo.CursorPos);
    Param.Pos := HintInfo.CursorPos;
    Param.Title := HintInfo.HintControl.Name;
    Param.Info := HintStr;
    Param.TimeOut := HintInfo.HideTimeout;
    Param.BkColor := clCream;
    Param.BorderColor := $968157;
    TitleBkColor := $00E2E1C7;//$00FF8080;
    TitleFont.Name := '宋体';
    TitleFont.Style := [fsBold];
    TitleFont.Color := clBlack;
    TitleFont.Size := 9;
    InfoFont.Name := 'MONO';
    InfoFont.Size := 9;
    if CheckBox1.Checked then
      Round := 3
    else
      Round := 0;
      
    InfoFont.Color := clRed;
    Param.AlphaBlendValue := 230;
    Param.Flag := HF_ALPHABLEND;
  end;
  FHint2.ShowHint(Param);
end;


function NotifyIcon(const Extra: TTButtonExtraInfo; Icon: TIcon): Boolean;
var
  NI: TNotifyIconData5;
  ret: Boolean;
  Code: Integer;
begin
  Result := True;
  FillChar(NI, sizeof(NI), 0);
  NI.cbSize := sizeof(NI);
  NI.uID := Extra.ID;
  NI.Wnd := Extra.Wnd;
  NI.Icon := Icon.Handle;
  NI.uFlags := NIF_ICON or NIF_INFO;

  NI.dwInfoFlag := 1;
  NI.uTimeOut := 300;
  NI.szTip := '';
  NI.szInfoTitle := '找到QQ';
  StrLCopy(NI.szInfo, PChar('QQ 图标已替换. '  FormatDateTime('yyyy-mm-dd hh:mm:ss', Now)), sizeof(NI.szInfo));
  
  Ret := Shell_NotifyIcon(NIM_MODIFY, @NI);
end;



procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if FCount > 4 then begin
    FCount := 0;
    if FFram = 0 then
      FFram := 1
    else
      FFram := 0;

    IL2.GetIcon(FFram, Icon);
    
    FIndWndExtra('TXGuiFoundation', NotifyIcon, Icon);
  end else begin
    Inc(FCount);
  end;

end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  Timer1.Enabled := True;
end;

procedure TForm1.Button5Click(Sender: TObject);
begin
  Timer1.Enabled := False;
end;

procedure TForm1.Button6Click(Sender: TObject);
var
  Param: THintShowParam;
  Pt: TPoint;
begin
  Pt := Memo1.BoundsRect.TopLeft;
  Windows.ClientToScreen(Handle, Pt);

  FillChar(Param, sizeof(Param), 0);
  with Param do begin
    Pos := Pt;
    Title := Edit1.Text;
    Info := Memo1.Text;
    BkColor := clCream;
    BorderColor := $968157;
    TitleBkColor := $00E2E1C7;//$00FF8080;
    TitleFont.Name := '宋体';
    TitleFont.Style := [fsBold];
    TitleFont.Color := clBlack;
    TitleFont.Size := 9;
    InfoFont.Name := 'MONO';
    InfoFont.Size := 9;
    InfoFont.Color := ColorToRGB(clWindowText);
    TimeOut := 5000;
    Round := 3;

    ParentWnd := Handle;
    Param.AlphaBlendValue := 230;
    Param.Flag := HF_ALPHABLEND;
  end;

  FHint2.ShowHint(Param);
end;

end.

标签： 图标托盘 QQ

实例下载地址

delphi替换QQ托盘图标演示

点此下载实例

不能下载？内容有错？点击这里报错 + 投诉 + 提问

好例子网口号：伸出你的我的手 — 分享！

网友评论

我要评论

小贴士

感谢您为本站写下的评论，您的评论对其它用户来说具有重要的参考价值，所以请认真填写。

类似“顶”、“沙发”之类没有营养的文字，对勤劳贡献的楼主来说是令人沮丧的反馈信息。
相信您也不想看到一排文字/表情墙，所以请不要反馈意义不大的重复字符，也请尽量不要纯表情的回复。
提问之前请再仔细看一遍楼主的说明，或许是您遗漏了。
请勿到处挖坑绊人、招贴广告。既占空间让人厌烦，又没人会搭理，于人于己都无利。

关于好例子网

本站旨在为广大IT学习爱好者提供一个非营利性互相学习交流分享平台。本站所有资源都可以被免费获取学习研究。本站资源来自网友分享，对搜索内容的合法性不具有预见性、识别性、控制性，仅供学习研究，请务必在下载后24小时内给予删除，不得用于其他任何用途，否则后果自负。基于互联网的特殊性，平台无法对用户传输的作品、信息、内容的权属或合法性、安全性、合规性、真实性、科学性、完整权、有效性等进行实质审查；无论平台是否已进行审查，用户均应自行承担因其传输的作品、信息、内容而可能或已经产生的侵权或权属纠纷等法律责任。本站所有资源不代表本站的观点或立场，基于网友分享，根据中国法律《信息网络传播权保护条例》第二十二与二十三条之规定，若资源存在侵权或相关问题请联系本站客服人员，点此联系我们。关于更多版权及免责申明参见版权及免责申明

delphi替换QQ托盘图标演示

同类人气实例

实例介绍

实例下载地址

delphi替换QQ托盘图标演示

相关软件

相关文章

网友评论

小贴士

关于好例子网

下载周排行

下载总排行