ジャンプリストを使ってみる その３

前回はユーザータスクの追加をしましたので、今回はカスタムカテゴリの追加をします。と思って試行錯誤してたんですがどうやってもメモリエラーが起こってしまってカテゴリの追加が出来ませんでした。
で、たどり着いた結論は、shlobj.pasで定義されてるICustomDestinationList.AppendCategoryの定義がどうも間違ってるようだと。
定義を下記のように修正したらあっさりカテゴリの追加に成功しました。

 function AppendCategory(pszCategory: LPCWSTR; const poa: IObjectArray): HRESULT; stdcall;

下記はTTaskListをカテゴリとして登録する関数です。カスタムカテゴリにはセパレータを追加する事は出来ないようなのでPath,Argumentが空のアイテムは無視するようにします。

function TJumplist.AddCategoryToList(ACategoryName: string;
  oaRemoved: IObjectArray; List: TTaskList;
  CDL: ICustomDestinationList): Boolean;
var
  OC:   IObjectCollection;
  Item: TTaskItem;

  OA: IObjectArray;
  UK: IUnknown;
  Cnt: Cardinal;
begin
  Result := False;
  if Succeeded(CoCreateInstance(CLSID_EnumerableObjectCollection, nil,
      CLSCTX_INPROC, IID_IObjectCollection, OC)) then
  begin
    for Item in List do
    begin
      // カスタムカテゴリにはセパレータは追加不可
      if (Item.Path <> '') And (Item.Argument <> '') then
      begin
        if Item.CreateObject(UK) then
          OC.AddObject(UK);
      end;
    end;

    OC.GetCount(Cnt);
    if (Cnt > 0) And Succeeded(OC.QueryInterface(IID_IObjectArray, OA)) then
    begin
      Result := Succeeded(CDL.AppendCategory(PChar(ACategoryName), OA));
    end;
  end;
end;

BeginListを呼んだ時に返ってくるユーザーの手で削除されたタスクの一覧、これに含まれるアイテムは追加しないようにしたら良いのかと思ってたんですが、そうすると毎回ジャンプリストがリセットされてユーザーの設定が無効になってしまったので特に何も考えず追加したら良いようです。

function TJumplist.CreateJumpList: Boolean;
var
  CDL:       ICustomDestinationList;
  MinSlots:  UINT;
  oaRemoved: IObjectArray;

  Item: TPair<string, TTaskList>;
  Done: Boolean;
begin
  Result := False;

  if Failed(CoCreateInstance(CLSID_DestinationList, nil, CLSCTX_INPROC_SERVER,
      IID_ICustomDestinationList, CDL)) then
    Exit;

  if Failed(CDL.SetAppID(PChar(FAppID))) then
    Exit;

  // ジャンプリストの編集開始
  if Failed(CDL.BeginList(MinSlots, IID_IObjectArray, oaRemoved)) then
    Exit;

  Done := True;
  // カスタムカテゴリの追加
  for Item in FCategories do
  begin
    if not AddCategoryToList(Item.Key, oaRemoved, Item.Value, CDL) then
      Done := False;
  end;

  // タスクの追加
  if Done then
  begin
    Done := AddTasksToList(Tasks, CDL);
  end;

  // 変更の適用又は破棄
  if Done then
    Result := Succeeded(CDL.CommitList)
  else
    Result := Succeeded(CDL.AbortList);
end;

下記処理で、ユーザータスクとカスタムカテゴリを追加できました。

procedure TForm1.Button1Click(Sender: TObject);
var
  JL: TJumplist;
  Task: TTaskItem;
begin
  SetCurrentProcessExplicitAppUserModelID('AU2010.Samples.JumplistTest');

  if CheckWin32Version(6, 1) then
  begin
    JL := TJumplist.Create('AU2010.Samples.JumplistTest');
    Task := TTaskItem.Create;
    Task.Path := Application.ExeName;
    Task.Argument := '/ARG1';
    Task.IconLocation := Application.ExeName;
    Task.IconIndex := 0;
    Task.Title := 'TEST1';
    JL.Tasks.Add(Task);

    JL.Tasks.Add(TTaskItem.Create);

    Task := TTaskItem.Create;
    Task.Path := Application.ExeName;
    Task.Argument := '/ARG2';
    Task.Title := 'TEST2';
    JL.Tasks.Add(Task);

    Task := TTaskItem.Create;
    Task.Path := Application.ExeName;
    Task.Argument := '/ARG5';
    Task.Title := 'TEST5';
    Task.IconLocation := Application.ExeName;
    Task.IconIndex := 0;
    JL.Categories['カスタム'].Add(Task);

    JL.Categories['カスタム'].Add(TTaskItem.Create);

    Task := TTaskItem.Create;
    Task.Path := Application.ExeName;
    Task.Argument := '/ARG3';
    Task.Title := 'TEST3';
    Task.IconLocation := Application.ExeName;
    Task.IconIndex := 0;
    JL.Categories['カスタム'].Add(Task);

    Task := TTaskItem.Create;
    Task.Path := Application.ExeName;
    Task.Argument := '/ARG4';
    Task.Title := 'TEST4';
    Task.IconLocation := Application.ExeName;
    Task.IconIndex := 0;
    JL.Categories['カテゴリ2'].Add(Task);

    JL.CreateJumpList;
    FreeAndNil(JL);
  end;
end;

今回使ったユニット、uJumpList.pasとPropvarUtil.pasを置いておきます。
使い方は、今回のButton1Clickの中身を参照してください。