在好例子网,分享、交流、成长!
您当前所在位置:首页Pascal 开发实例Pascal编程基础 → delphi替换QQ托盘图标演示

delphi替换QQ托盘图标演示

Pascal编程基础

下载此实例
  • 开发语言:Pascal
  • 实例大小:0.30M
  • 下载次数:9
  • 浏览次数:144
  • 发布时间:2019-12-28
  • 实例类别:Pascal编程基础
  • 发 布 人:女生宿舍卖黄瓜
  • 文件格式:.rar
  • 所需积分:2
 相关标签: 图标 托盘 QQ

实例介绍

【实例简介】

【实例截图】

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托盘图标演示

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

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

网友评论

发表评论

(您的评论需要经过审核才能显示)

查看所有0条评论>>

小贴士

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

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

关于好例子网

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

;
报警