Delphi之Windows Taskbar API 编程，包括任务栏进度条，图标覆盖，任务栏缩略图，跳转列表

最新推荐文章于 2020-05-04 21:57:02 发布

螃蟹＠横着走

最新推荐文章于 2020-05-04 21:57:02 发布

阅读量5.5k

点赞数

分类专栏： Delphi

本文链接：https://blog.csdn.net/MaxWoods/article/details/8604299

版权

Delphi 专栏收录该内容

143 篇文章 5 订阅

订阅专栏

Taskbar API 参考MSDN：

http://msdn.microsoft.com/en-us/magazine/dd942846.aspx

又一介绍Taskbar的文章：

http://blogs.msdn.com/b/yochay/archive/2009/01/06/windows-7-taskbar-part-1-the-basics.aspx

跳转列表参见：

http://www.cnblogs.com/gnielee/archive/2010/03/16/windows7-taskbar-jumplists.html

http://blog.csdn.net/ntwilford/article/details/5635381

如何阻止程序锁定到任务栏的C#代码：

http://stackoverflow.com/questions/6378098/how-to-prevent-an-app-from-being-pinned-in-windows-7

要看到跳转列表的效果，请保证任务栏属性中的隐私两个选择框被选中，自定义的Catalog在Win 8中测试添加会报错，只对Win 7有效：

程序运行如下图，Delphi XE 3 + Win 7 调试通过：

源代码下载：http://www.ctdisk.com/file/17157509

主要代码如下：

unit Form_Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ShellAPI, ShlObj, ObjectArray, PropSys, ExtCtrls, StdCtrls, ImgList,
  DwmApi;

type
  TFormMain = class(TForm)
    Timer1: TTimer;
    btnProgressbar: TButton;
    btnIconOverlay: TButton;
    ImageList1: TImageList;
    btnThumbnail: TButton;
    btnJumpList: TButton;
    btnThumbnailClip: TButton;
    btnThumbnailCus: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure btnProgressbarClick(Sender: TObject);
    procedure btnIconOverlayClick(Sender: TObject);
    procedure btnThumbnailClick(Sender: TObject);
    procedure btnJumpListClick(Sender: TObject);
    procedure btnThumbnailClipClick(Sender: TObject);
    procedure btnThumbnailCusClick(Sender: TObject);
  private
    wmTBC: Cardinal;
    TBL: ITaskbarList4;
    I: Integer;
    fForceIconic: BOOL;
    fHasIconicBitmap: BOOL;
    function CreateDIB(nWidth, nHeight: Integer): HBITMAP;
  protected
    procedure WndProc(var Message: TMessage); override;
  public
    procedure AddCataToList(CDL: ICustomDestinationList);
    function CreateShellLink(Arg, Title: string): IShellLink;
  end;

var
  FormMain: TFormMain;

implementation

{$R *.dfm}

uses ActiveX, ComObj, Math;

function IsWindows7: Boolean;
var
  osver: OSVERSIONINFO;
begin
  osver.dwOSVersionInfoSize := sizeof(osver);
  if GetVersionEx(osver) then
  begin
    Result := (osver.dwMajorVersion = 6) and (osver.dwMinorVersion = 1);
  end
  else
    Result := False;
end;

procedure TFormMain.AddCataToList(CDL: ICustomDestinationList);
var
  OC: IObjectCollection;
  SL: IShellLink;
  OA: IObjectArray;
  hr: HRESULT;
begin
  OC := CreateComObject(CLSID_EnumerableObjectCollection) as IObjectCollection;
  SL := CreateShellLink('在线', '在线');
  hr := OC.AddObject(SL);
  if Succeeded(hr) then
    SL := nil;
  SL := CreateShellLink('忙', '忙');
  hr := OC.AddObject(SL);
  if Succeeded(hr) then
    SL := nil;
  SL := CreateShellLink('离开', '离开');
  hr := OC.AddObject(SL);
  if Succeeded(hr) then
    SL := nil;
  OA := OC as IObjectArray;
  if IsWindows7 then
    hr := CDL.AppendCategory('自定义', OA)
  else
    hr := CDL.AddUserTasks(OA);
  if Succeeded(hr) then
    OA := nil;
end;

procedure TFormMain.btnProgressbarClick(Sender: TObject);
begin
  Timer1.Enabled := not Timer1.Enabled;
end;

procedure TFormMain.btnIconOverlayClick(Sender: TObject);
var
  Icon: TIcon;
begin
  Icon := TIcon.Create;
  ImageList1.GetIcon(0, Icon);
  TBL.SetOverlayIcon(Handle, Icon.Handle, '覆盖图标');
end;

procedure TFormMain.btnThumbnailClick(Sender: TObject);
var
  TB: array [0 .. 1] of THUMBBUTTON;
begin
  Icon := TIcon.Create;
  ImageList1.GetIcon(0, Icon);
  //
  TB[0].iId := 1;
  StrCopy(TB[0].szTip, '按钮提示');
  TB[0].hIcon := Icon.Handle;
  TB[0].dwFlags := THBF_ENABLED;
  TB[0].dwMask := THB_ICON or THB_TOOLTIP or THB_FLAGS;
  //
  TB[1].iId := 2;
  StrCopy(TB[1].szTip, '禁用按钮');
  TB[1].hIcon := Icon.Handle;
  TB[1].dwFlags := THBF_DISABLED;
  TB[1].dwMask := THB_ICON or THB_TOOLTIP or THB_FLAGS;
  //
  TBL.ThumbBarAddButtons(Handle, 2, @TB);
end;

procedure TFormMain.btnJumpListClick(Sender: TObject);
var
  CDL: ICustomDestinationList;
  uMaxSlots: UINT;
  poaRemoved: IObjectArray;
  hr: HRESULT;
begin
  CDL := CreateComObject(CLSID_DestinationList) as ICustomDestinationList;
  hr := CDL.BeginList(uMaxSlots, IID_IObjectArray, poaRemoved);
  if Succeeded(hr) then
  begin
    AddCataToList(CDL);
    hr := CDL.CommitList;
  end;
end;

procedure TFormMain.btnThumbnailClipClick(Sender: TObject);
var
  Rect: TRect;
begin
  //
  Rect := GetClientRect;
  Rect.Right := Rect.Right div 2;
  Rect.Bottom := Rect.Bottom div 2;
  TBL.SetThumbnailClip(Handle, Rect);
  TBL.SetThumbnailTooltip(Handle, pchar('缩略图剪切示例'));
end;

procedure TFormMain.btnThumbnailCusClick(Sender: TObject);
begin
  fForceIconic := True;
  fHasIconicBitmap := True;
  DwmSetWindowAttribute(Handle, DWMWA_FORCE_ICONIC_REPRESENTATION,
    @fForceIconic, sizeof(fForceIconic));
  DwmSetWindowAttribute(Handle, DWMWA_HAS_ICONIC_BITMAP, @fHasIconicBitmap,
    sizeof(fHasIconicBitmap));
end;

function TFormMain.CreateDIB(nWidth, nHeight: Integer): HBITMAP;
const
  RINGWIDTH: Integer = 20;
  MAXRING: Integer = 3;
  MAXTABS: Integer = 20;
var
  hbm: HBITMAP;
  hdcMem: HDC;
  pbDS: LPBYTE;
  bmi: BITMAPINFO;
  nGreen, nRed, nBlue, x, y: Integer;
  edgeDistance, ring, nAlpha: Integer;
begin
  hdcMem := CreateCompatibleDC(0);
  if hdcMem > 0 then
  begin
    ZeroMemory(@(bmi.bmiHeader), sizeof(BITMAPINFOHEADER));
    bmi.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
    bmi.bmiHeader.biWidth := nWidth;
    bmi.bmiHeader.biHeight := -nHeight; // Use a top-down DIB
    bmi.bmiHeader.biPlanes := 1;
    bmi.bmiHeader.biBitCount := 32;
    pbDS := 0;
    hbm := CreateDIBSection(hdcMem, bmi, DIB_RGB_COLORS, Pointer(pbDS), 0, 0);
    if (hbm > 0) then
    begin
      nRed := 0;
      nGreen := 185;
      nBlue := 242;
      // Fill in the pixels of the bitmap
      for y := 0 to nHeight - 1 do
      begin
        for x := 0 to nWidth - 1 do
        begin
          edgeDistance := min(min(y, nHeight - y), min(x, nWidth - x));
          ring := min(Round(edgeDistance / RINGWIDTH) + 1, MAXRING);
          nAlpha := Round(ring * (255 / MAXRING));
          pbDS[0] := Round((nBlue * nAlpha / 255));
          pbDS[1] := Round((nGreen * nAlpha / 255));
          pbDS[2] := Round((nRed * nAlpha / 255));
          pbDS[3] := nAlpha;
          pbDS := pbDS + 4;
        end;
      end;
    end;
    DeleteDC(hdcMem);
  end;
  Result := hbm;
end;

function TFormMain.CreateShellLink(Arg, Title: string): IShellLink;
var
  SL: IShellLink;
  PS: IPropertyStore;
  propvar: PROPVARIANT;
  PKEY: PROPERTYKEY;
  hr: HRESULT;
  FilePath: pchar;
begin
  SL := CreateComObject(CLSID_ShellLink) as IShellLink;
  FilePath := pchar(Application.ExeName);
  hr := SL.SetPath(FilePath);
  if Succeeded(hr) then
  begin
    hr := SL.SetArguments(pchar(Arg));
    hr := SL.SetIconLocation(FilePath, 0);
    hr := SL.SetDescription(pchar(Title));
    if Succeeded(hr) then
    begin
      PS := SL as IPropertyStore;
      propvar.vt := VT_LPWSTR;
      propvar.pwszVal := pchar(Title);
      PKEY.fmtid := StringToGUID('{F29F85E0-4FF9-1068-AB91-08002B27B3D9}');
      PKEY.pid := 2;
      hr := PS.SetValue(PKEY, propvar);
      PS.GetValue(PKEY, propvar);
      if Succeeded(hr) then
      begin
        PS.Commit;
        Result := SL;
      end
      else
        Result := nil;
    end
    else
      Result := nil;
  end
  else
    Result := nil;
end;

procedure TFormMain.FormCreate(Sender: TObject);
var
  PS: IPropertyStore;
  hr: HRESULT;
  propvar: PROPVARIANT;
  PKEY: PROPERTYKEY;
begin
  hr := SHGetPropertyStoreForWindow(Handle, IID_IPropertyStore, Pointer(PS));
  if Succeeded(hr) then
  begin
    // AppUserModel_ID
    // PKEY.fmtid := StringToGUID('{9F4C2855-9F79-4B39-A8D0-E1D42DE1D5F3}');
    // PKEY.pid := 5;
    // propvar.vt := VT_LPWSTR;
    // propvar.pwszVal := pchar('MyApp');
    // hr := PS.SetValue(PKEY, propvar);
    // if Succeeded(hr) then
    // PS.Commit;
    // PKEY_AppUserModel_PreventPinning , 不允许锁定到任务栏
    // propvar.vt := VT_BOOL;
    // propvar.boolVal := True;
    // PKEY.fmtid := StringToGUID('{9F4C2855-9F79-4B39-A8D0-E1D42DE1D5F3}');
    // PKEY.pid := 9;
    // hr := PS.SetValue(PKEY, propvar);
    // if Succeeded(hr) then
    // PS.Commit;
  end;
  //
  wmTBC := RegisterWindowMessage('TaskbarButtonCreated');
  TBL := CreateComObject(CLSID_TaskbarList) as ITaskbarList4;
  TBL.SetProgressState(Handle, TBPF_NOPROGRESS or TBPF_INDETERMINATE);
end;

procedure TFormMain.Timer1Timer(Sender: TObject);
begin
  if I < 100 then
    Inc(I);
  TBL.SetProgressValue(Handle, I, 100);
  if I >= 100 then
  begin
    TBL.SetProgressState(Handle, TBPF_NOPROGRESS);
    Timer1.Enabled := False;
    I := 0;
  end;
end;

procedure TFormMain.WndProc(var Message: TMessage);
var
  RC: TRect;
  hbm: HBITMAP;
  nWidth, nHeight: Integer;
  P: TPoint;
begin
  inherited;
  case Message.Msg of
    WM_DWMSENDICONICTHUMBNAIL:
      begin
        hbm := CreateDIB(HIWORD(Message.lParam), LOWORD(Message.lParam));
        DwmSetIconicThumbnail(Handle, hbm, 0);
        DeleteObject(hbm);
      end;
    WM_DWMSENDICONICLIVEPREVIEWBITMAP:
      begin
        RC := ClientRect;
        nWidth := RC.Right - RC.left;
        nHeight := RC.Bottom - RC.top;
        hbm := CreateDIB(nWidth, nHeight);
        if (hbm > 0) then
        begin
          DwmSetIconicLivePreviewBitmap(Handle, hbm, P, DWM_SIT_DISPLAYFRAME);
          DeleteObject(hbm);
        end;
      end;
  end;
end;

end.

Create中注释的代码可以控制多实例是否在任务栏合并及是否可锁定到任务栏。