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

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;interfaceuses  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中注释的代码可以控制多实例是否在任务栏合并及是否可锁定到任务栏。