itemprop.pas

动态提示控件

        end;
        Result := DefWindowProc(Wnd, Msg, wParam, lParam);
      end;

    // these are the biggies -- the messages that IContextMenu2::HandlMenuMsg is
    // supposed to handle.
    WM_DRAWITEM,
    WM_MEASUREITEM,
    WM_INITMENUPOPUP:
      begin
        if IsCM3 then
        begin
          // grab object pointer from window data -- we put it there in WM_CREATE
          CM3 := IContextMenu3(GetWindowLong(Wnd, GWL_USERDATA));

          {$IFDEF DFS_COMPILER_3_UP}
          Assert(CM3 <> NIL, 'NIL Context Menu!');
          {$ENDIF}

          // pass along to context menu
          CM3.HandleMenuMsg2(Msg, wParam, lParam, Result);
        end
        else if IsCM2 then
        begin
          // grab object pointer from window data -- we put it there in WM_CREATE
          CM2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA));

          {$IFDEF DFS_COMPILER_3_UP}
          Assert(CM2 <> NIL, 'NIL Context Menu!');
          {$ENDIF}

          // pass along to context menu
          CM2.HandleMenuMsg(Msg, wParam, lParam);
        end;
        if Msg = WM_INITMENUPOPUP then
          Result := 0
        else
          Result := 1;
      end;

    // this is to set Application.Hint
    WM_MENUSELECT:
      begin
        // This occurs every time the current menu selection changes
        // LoWord(wParam) will be the CmdID if the menu entry is a command item,
        //   or the sub-menu's index if a sub-menu.
        // HiWord(wParam) will be a set of MF_ flags
        // lParam is the handle of the menu in which the command item or
        //   sub-menu lies. 
        // When the user Escapes out of the menu, flags will be $FFFF and
        //   lParam = Nil.

        // Grab object pointer from window data -- we put it there in WM_CREATE
        // Because CM2 and CM3 descend from CM, we can typecast any of the three
        // to CM
        CM := IContextMenu(GetWindowLong(Wnd, GWL_USERDATA));
        // We mimic the VCL's TMenuItem hint dispatching algorithm by setting
        // Application.Hint
        if ((DWParam.Hi = $FFFF) and (lParam = 0)) then
          Application.Hint :=  ''
        else if (DWParam.Lo >= CMD_ID_OFFSET) then
        begin
          SetLength(Name, MAX_PATH);
          // If it doesn't have one, it won't null out the string so we have to.
          Name[1] := #0;
          CM.GetCommandString(DWParam.Lo - CMD_ID_OFFSET, GCS_VERB,
            NIL, PChar(Name), MAX_PATH);
          SetLength(Name, StrLen(PChar(Name)));
          {
          NOTE:
            Not all context menu extensions report verbs (WinZip, for example);
            SendTo is explicitly instructed by the shell not to include any
            verbs (via CMF_NOVERBS)
          }
          SetLength(Help, MAX_PATH);
          // If it doesn't have one, it won't null out the string so we have to.
          Help[1] := #0;
          CM.GetCommandString(DWParam.Lo - CMD_ID_OFFSET,
            GCS_HELPTEXT, NIL, PChar(Help), MAX_PATH);
          SetLength(Help, StrLen(PChar(Help)));
          // The pipe ('|') separates the short hint from the long one.
          Application.Hint := Name + '|' + Help;
        end;
      end;
  else
    Result := DefWindowProc(Wnd, Msg, wParam, lParam);
  end;
end;


type
  TInterfaceCommand = (icContextMenu, icProperties, icDefaultAction, icVerb);

// Internal function used by all others as they share a lot of common
// functionality.
function InvokeInterfaceElement(Filename: string; AFolder: IShellFolder;
   var APIDL: PItemIDList; AnAttr: ULONG; Cmd: TInterfaceCommand;
   const Verb: string; Parent: HWND; Pos: TPoint; PidlCount: integer): boolean;

  function HandleContextMenu(const CtxMenu: IContextMenu; Attr: ULONG): boolean;
  const
    RENAME_COMMAND = $13;
  var
    Popup: HMenu;
    ICI: TCMInvokeCommandInfo;
    MenuCmd: Cardinal;
//    CmdString: string;
    CallbackWnd: HWnd;
    AWndClass: TWndClass;
  begin
    Result := FALSE;
    g_RenameSelected := FALSE;
    CallbackWnd := 0;
    FillChar(ICI, SizeOf(TCMInvokeCommandInfo), #0);
    with ICI do
    begin
      cbSize := SizeOf(TCMInvokeCommandInfo);
      hWnd := Parent;
      nShow := SW_SHOWNORMAL;
    end;
    case Cmd of
      icContextMenu:
        begin
          Popup := CreatePopupMenu;
          try
            // Add "or CMF_CANRENAME" if you want the rename item
            if Succeeded(CtxMenu.QueryContextMenu(Popup, 0, 1, $7FFF,
              CMF_EXPLORE or CMF_CANRENAME)) then
            begin
              FillChar(AWndClass, SizeOf(AWndClass), #0);
              AWndClass.lpszClassName := 'ItemPropMenuCallbackHelper';
              AWndClass.Style := CS_PARENTDC;
              AWndClass.lpfnWndProc := @MenuCallbackProc;
              AWndClass.hInstance := HInstance;
              Windows.RegisterClass(AWndClass);
              CallbackWnd := CreateWindow('ItemPropMenuCallbackHelper',
                 'ItemPropCallbackProcessor', WS_POPUPWINDOW, 0, 0, 0, 0, 0,
                 0, HInstance, Pointer(CtxMenu));

              Result := TRUE; // We displayed the menu, that's it unless they
                              // make a selection.
              MenuCmd := Cardinal(TrackPopupMenuEx(Popup, TPM_LEFTALIGN or
                 TPM_RETURNCMD or TPM_RIGHTBUTTON, Pos.x, Pos.y, CallbackWnd,
                 NIL));
              if MenuCmd = RENAME_COMMAND then
              begin
                g_RenameSelected := TRUE;
                Result := TRUE;
              end
              else
              if MenuCmd <> 0 then
              begin
(*
                SetLength(CmdString, 255);
                if Succeeded(CtxMenu.GetCommandString(MenuCmd - CMD_ID_OFFSET, GCS_VERB, NIL,
                   PChar(CmdString), 255)) then
                  ICI.lpVerb := PChar(CmdString)
                else
                  ICI.lpVerb := MakeIntResource(MenuCmd - CMD_ID_OFFSET);
*)
                ICI.lpVerb := MakeIntResource(MenuCmd - CMD_ID_OFFSET);
                Result := Succeeded(CtxMenu.InvokeCommand(ICI));
              end;
            end;
          finally
            DestroyMenu(Popup);
            if CallbackWnd <> 0 then
              DestroyWindow(CallbackWnd);
          end;
        end;
      icVerb:
        begin
          ICI.lpVerb := PChar(Verb);
          Result := Succeeded(CtxMenu.InvokeCommand(ICI));
        end;
      icProperties:
        begin
          // does it have a property sheet?
          if (Attr and SFGAO_HASPROPSHEET) <> 0 then
          begin
            ICI.lpVerb := 'properties'; // Built-in verb for all items, I think
            Result := Succeeded(CtxMenu.InvokeCommand(ICI));
          end;
        end;
      icDefaultAction:
        begin
          Popup := CreatePopupMenu;
          try
            if Succeeded(CtxMenu.QueryContextMenu(Popup, 0, 1, $7FFF,
               CMF_DEFAULTONLY)) then
            begin
              MenuCmd := GetMenuDefaultItem(Popup, 0, 0);
              if MenuCmd <> $FFFFFFFF then
              begin
                ICI.lpVerb := MakeIntResource(MenuCmd - CMD_ID_OFFSET);
                Result := Succeeded(CtxMenu.InvokeCommand(ICI));
              end;
            end;
          finally
            DestroyMenu(Popup);
          end;
        end;
    end;
  end; { InvokeInterfaceElement }

  function HandleFromPIDLs(Parent: HWND; SubFolder: IShellFolder;
     var ItemID: PItemIDList; Attr: ULONG; PidlCount: integer): boolean;
  var
    ContextMenu: IContextMenu;
    ContextMenu2: IContextMenu2;
    ContextMenu3: IContextMenu3;
  begin
    Result := FALSE;
    IsCM2 := FALSE;

    if Succeeded(SubFolder.GetUIObjectOf(Parent, PidlCount, ItemID,
       IID_IContextMenu, NIL, pointer(ContextMenu))) then
    begin
      if Succeeded(ContextMenu.QueryInterface(IID_IContextMenu2,
         pointer(ContextMenu2))) then
      begin
{$IFNDEF DFS_NO_COM_CLEANUP}
        ContextMenu.Release; // Delphi 3 does this for you.
{$ENDIF}
        ContextMenu := ContextMenu2;
        IsCM2 := TRUE;

        if Succeeded(ContextMenu.QueryInterface(IID_IContextMenu3,
           pointer(ContextMenu3))) then
        begin
{$IFNDEF DFS_NO_COM_CLEANUP}
          ContextMenu.Release; // Delphi 3 does this for you.
{$ENDIF}
          ContextMenu := ContextMenu3;
          IsCM3 := TRUE;
        end;
      end;
      try
        Result := HandleContextMenu(ContextMenu, Attr);
      finally
{$IFNDEF DFS_NO_COM_CLEANUP}
        ContextMenu.Release; // Delphi 3 does this for you.
{$ENDIF}
      end;
    end;
  end;

  function HasWildcards(const s: string): boolean;
  begin
    Result := (StrScan(PChar(s), '*') <> NIL) or (StrScan(PChar(s), '?') <> NIL);
  end;

const
  {$IFDEF DFS_CPPB}
  ATTR_ALL = ULONG($FFFFFFFF);
  {$ELSE}
  ATTR_ALL = $FFFFFFFF;
  {$ENDIF}
var
  ShellMalloc: IMalloc;
  SubFolder,
  ShellFolder: IShellFolder;
  FolderID,
  ItemID: pItemIDList;
  Eaten, ulAttr: ULONG;
  uiAttr: UINT;
{$IFDEF DFS_COMPILER_3_UP}
  oleWild,
  oleAll,
  oleSubDir,
  oleFilename: widestring;
{$ELSE}
  oleWild,
  oleAll,
  oleSubDir,
  oleFilename: PWideChar;
{$ENDIF}
  OldCursor: TCursor;
  JustName: string;
  EnumList: IEnumIDList;
  CompID: pItemIDList;
  CompFolder: IShellFolder;
{$IFDEF DFS_CPPB}
  Fetched: Cardinal;
  Dummy: UINT absolute 0;
{$ELSE}
  Fetched: ULONG;
{$ENDIF}
  SR: TSearchRec;
  WildFiles: TStringList;
  WildPIDLs: PPIDLArray;
  Count,
  x: integer;
begin
  IsCM2 := FALSE;
  IsCM3 := FALSE;
  Result := FALSE;
  OldCursor := Screen.Cursor;
  Screen.Cursor := crHourglass;
  try
    if (APIDL <> NIL) then
    begin
      Result := HandleFromPIDLs(Parent, AFolder, APIDL, AnAttr, PidlCount);
    end else
    begin
      SHGetMalloc(ShellMalloc);
      // I'm extra liberal with my try-finally blocks when dealing with system
      // resources like these.  Last thing I want to do is make the shell itself
      // unstable.
      try
        JustName := ExtractFileName(FileName);
{$IFDEF DFS_COMPILER_3_UP}
        oleSubDir := ExtractFilePath(Filename);
        try
          oleFilename := JustName;
          try
{$ELSE}
        oleSubDir := StringToOLEStr(ExtractFilePath(Filename));
        if assigned(oleSubDir) then
        try
          oleFilename := StringToOLEStr(JustName);
          if assigned(oleFilename) then
          try