Buy now, 799$, online ordering, delivery by email

iconman sample

The iconman sample is one of the samples that come with the namespace extension library for Delphi.

It only has one file, the file items.pas.

Most of the code has been generated by the NSE wizard.

items.pas

unit Items;

interface

uses
  Windows, ActiveX, Classes, ComObj, NamespaceExtension, ShlObj,
  uShellUIObject, NSEFactory, uNamespaceApp, ContextMenu, Menus;

type
  TIconManNamespaceItem = class (TNamespaceItem)
  private
    FInd : cardinal;
    FModule : string;
    FIndex : integer;
    FValid : boolean;
    procedure SetIndex(value : integer);
    procedure SetInd(value : cardinal);
    function GetModule: string;
    function GetIndex: integer;
  protected
    function GetAttributes : cardinal; override;
    function GetInfoTip: string; override;
    function GetItemDetail(Col : integer) : string; override;
    function GetStorageType : string; override;
    function IsValidObject : boolean; override;
  public
    constructor Create(AOwner: TComponent); override;
    function CompareWith(iCol : cardinal; nsi : TNamespaceItem) : smallint; override;
    function GetDisplayName(uFlags : cardinal) : string; override;
    function GetFindData(var pFindData : WIN32_FIND_DATAW) : boolean; override;
    function GetIconIndex(uFlags : cardinal; var puiReturnFlags : cardinal) : integer; override;
    function SetItemName(aName : string) : boolean; override;
    function GetIconModule : string; override;
  published
    property Ind : cardinal read FInd write SetInd;
    property IconModule : string read GetModule write FModule;
    property IconIndex : integer read GetIndex write SetIndex;
    property Valid : boolean read FValid write FValid;
  end;

  TIconManNamespaceExtension = class(TNamespaceExtension)
  protected
    // Override to return the attributes for the namespaces's root.
    function GetAttributes : cardinal; override;
    // Override to return the correct title for column Col.
    function GetColumnTitle(Col : integer) : string; override;
    // Override to provide the default column.
    function GetDefaultColumn(var pSort : cardinal; var pDisplay : cardinal) : boolean; override;
    // Override to return the display name for the namespace's root.
    function GetDisplayName : string; override;
    // Override to return the icon index that represents the namespace's root.
    function GetIconIndex : integer; override;
    // Override to return the infotip for the namespaces's root.
    function GetInfoTip : string; override;
    // Override to return the junction point for this namespace
    function GetJunctionPoint : TJunctionPoint; override;
    // Override to return true if the current version of the object is the same as explorers
    function IsValidObject : boolean; override;
    function GetWebPage : string; override;
    function GetCPCategory : TCPCategory; override;
    procedure Change(sender : TObject);
    procedure RestoreDefault(sender: TObject);
  public
    function GetFirstId(var pData : TNamespaceItem; var Cookie : cardinal; FFlags : cardinal) : boolean; override;
    function GetNextId(pPrev : TNamespaceItem; var pData : TNamespaceItem; var Cookie : cardinal; FFlags : cardinal) : boolean; override;
    function GetMenuItems(mi : TExplorerMenuType; var DelphiMenu : TPopupMenu;
                          var FreeOnCompletion : boolean) : boolean; override;
  end;

const
  Class_IconManNamespaceExtension: TGUID = '{CFB9AD9B-448D-4DA3-B187-8C4B57140667}';
  Class_IconManUIObject: TGUID = '{9161D7E5-642F-4784-9DE5-123B70B0B724}';

implementation

uses ComServ, SysUtils, ShellApi, CommCtrl, ShlExt, Registry, Dialogs;

type
  TSHUpdateImage = procedure(pszHashItem : LPCSTR; iIndex : integer; uFlags : cardinal; iImageIndex : integer); stdcall;


var
  FileIconInit : TFileIconInit;
  SHUpdateImage : TSHUpdateImage;
  hShell32 : HMODULE;

const
  Names : array[0..48] of string = (
    'Unknown File Type',
    'Default document',
    'Default application',
    'Closed folder',
    'Open folder',
    '5 1/4 floppy',
    '3 1/2 floppy',
    'Removable drive',
    'Hard disk drive',
    'Network drive',
    'network drive offline',
    'CD drive',
    'RAM disk',
    'Entire network',
    'Network Service',
    'My Computer',
    'Printer Manager',
    'Network Neighborhood',
    'Network Workgroup',
    'Start Menu Programs',
    'Start Menu Documents',
    'Start Menu Settings',
    'Start Menu Find',
    'Start Menu Help',
    'Start Menu Run',
    'Start Menu Suspend',
    'Start Menu Docking',
    'Start Menu Shutdown',
    'Sharing overlay (hand)',
    'Shortcut overlay (small arrow)',
    'Default printer overlay (small tick)',
    'Recycle bin empty',
    'Recycle bin full',
    'Dial-up Network Folder',
    'Desktop',
    'Control Panel',
    'Program Group',
    'Printer',
    'Font Folder',
    'Taskbar',
    'Audio CD',
    'Novell Tree',
    '(Unknown)',
    'IE favorites',
    'Start Menu Logoff',
    '(Unknown)',
    '(Unknown)',
    'Lock',
    'Hibernate');

{ TIconManNamespaceItem }

function TIconManNamespaceItem.GetIconModule : string;
begin
  Result := IconModule;
end;

function TIconManNamespaceItem.CompareWith(iCol: cardinal;
  nsi: TNamespaceItem): smallint;
  var Item : TIconManNamespaceItem;
begin
  // TODO: Replace the next line with code to compare two namespace items.
  // Return 1 if nsi should be higher up the list than self,  -1 is nsi
  // should be lower in the list than self or zero if both are equal.
  Item := nsi as TIconManNamespaceItem;
  if (iCol = 1) then begin
    if (Item.Ind > Ind) then
      Result := 1
    else if (Item.Ind < ind) then
      result := -1
    else
      result := 0;
  end else
    Result := AnsiCompareStr(GetDisplayName(0), nsi.GetDisplayName(0));
end;

function TIconManNamespaceItem.GetAttributes: cardinal;
begin
  // Return the attributes of your namespace item.  Or one or more of the following:
  // SFGAO_CANCOPY - object can be copied.
  // SFGAO_CANMOVE - object can be moved.
  // SFGAO_CANLINK - object can be linked.
  // SFGAO_CANRENAME - object can be renamed.
  // SFGAO_CANDELETE - object can be deleted.
  // SFGAO_HASPROPSHEET - Object has property sheets.
  // SFGAO_DROPTARGET - Object is a drop target.
  // SFGAO_LINK - Object is a shortcut (link).
  // SFGAO_SHARE - Object is shared.
  // SFGAO_READONLY - Object is read only.
  // SFGAO_GHOSTED - Object is ghosted (cut).
  // SFGAO_HIDDEN - hidden object.
  // SFGAO_FILESYSANCESTOR - Object contains file system folder.
  // SFGAO_FOLDER - Object is a folder.
  // SFGAO_FILESYSTEM - Object is a file system thing (file/folder/root).
  // SFGAO_HASSUBFOLDER - Object is expandable in the tree view.
  // SFGAO_REMOVABLE - is this removeable media?
  // SFGAO_COMPRESSED - Object is compressed (use alt color).
  // SFGAO_BROWSABLE - Object is in-place browsable.
  // SFGAO_NONENUMERATED - Object is a non-enumerated object.
  // SFGAO_NEWCONTENT - Object should show bold in explorer tree.
  // TODO: Replace the next line.
  Result := 0;
end;

function TIconManNamespaceItem.GetDisplayName(uFlags: cardinal): string;
begin
  //TODO: Replace the next line with code to return the display name that
  // should show in explorer.
  Result := Names[Ind];
end;

function TIconManNamespaceItem.GetFindData(
  var pFindData: WIN32_FIND_DATAW): boolean;
begin
  // TODO: Replace next line with code to populate pFindData with things like
  // access time etc.
  Result := False;
end;

function TIconManNamespaceItem.GetIconIndex(uFlags: cardinal;
  var puiReturnFlags: cardinal): integer;
begin
  // TODO: Replace next line with code to return the index in your resource that
  // holds the display icon for the object.
  Result := IconIndex;
end;

function TIconManNamespaceItem.GetInfoTip: string;
begin
  // TODO: Replace the next line with code to return the info tip for this object.
  Result := GetDisplayName(0);
end;

function TIconManNamespaceItem.GetItemDetail(Col: integer): string;
begin
  // TODO: Replace the next line with code that for the column 'Col' returns
  // the text to display.
  if (col = 0) then
    Result := GetDisplayName(0)
  else if (col = 1) then
    Result := Format('%d', [Ind])
  else
    Result := '';
end;

function TIconManNamespaceItem.GetStorageType: string;
begin
  // TODO: Replace the next line with code to return the storage type for this object
  Result := '';
end;

function TIconManNamespaceItem.IsValidObject: boolean;
begin
  // TODO: Replace the next line with code to return true if object still exists
  // and has not changed.
  Result := FValid;
  FValid := true;
end;

function TIconManNamespaceItem.SetItemName(aName: string): boolean;
begin
  //TODO: Replace the next line with code to set the objects name to aName.
  Result := False;
end;

function TIconManNamespaceItem.GetIndex: integer;
begin
  if FIndex = -1 then
    Result := FInd
  else
    Result := FIndex;
end;

function TIconManNamespaceItem.GetModule: string;
begin
  if FModule = '' then
    Result := '%SystemRoot%\system32\SHELL32.dll'
  else
    Result := FModule;
end;

procedure TIconManNamespaceItem.SetIndex(value : integer);
begin
  FIndex := value;
  FValid := False;
end;

constructor TIconManNamespaceItem.Create(AOwner: TComponent);
begin
  inherited;
  FIndex := -1;
end;

procedure TIconManNamespaceItem.SetInd(value: cardinal);
var
  Reg : TRegistry;
  temp : TStringList;
begin
  FInd := Value;
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    Reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Icons');
    if Reg.ValueExists(IntToStr(value)) then begin
      temp := TStringList.Create;
      try
        temp.CommaText := Reg.ReadString(IntToStr(Value));
        IconModule := temp[0];
        IconIndex := StrToIntDef(temp[1],-1);
      finally
        temp.Free;
      end;
    end;
  finally
    Reg.Free;
  end;
end;

{ TIconManNamespaceExtension }

function TIconManNamespaceExtension.GetAttributes: cardinal;
begin
  // Return the attributes of your root namespace.  Or one or more of the following:
  // SFGAO_CANCOPY - object can be copied.
  // SFGAO_CANMOVE - object can be moved.
  // SFGAO_CANLINK - object can be linked.
  // SFGAO_CANRENAME - object can be renamed.
  // SFGAO_CANDELETE - object can be deleted.
  // SFGAO_HASPROPSHEET - Object has property sheets.
  // SFGAO_DROPTARGET - Object is a drop target.
  // SFGAO_LINK - Object is a shortcut (link).
  // SFGAO_SHARE - Object is shared.
  // SFGAO_READONLY - Object is read only.
  // SFGAO_GHOSTED - Object is ghosted (cut).
  // SFGAO_HIDDEN - hidden object.
  // SFGAO_FILESYSANCESTOR - Object contains file system folder.
  // SFGAO_FOLDER - Object is a folder.
  // SFGAO_FILESYSTEM - Object is a file system thing (file/folder/root).
  // SFGAO_HASSUBFOLDER - Object is expandable in the tree view.
  // SFGAO_REMOVABLE - is this removeable media?
  // SFGAO_COMPRESSED - Object is compressed (use alt color).
  // SFGAO_BROWSABLE - Object is in-place browsable.
  // SFGAO_NONENUMERATED - Object is a non-enumerated object.
  // SFGAO_NEWCONTENT - Object should show bold in explorer tree.
  // TODO: Replace the next line.
  Result := SFGAO_BROWSABLE or SFGAO_FOLDER;
end;

function TIconManNamespaceExtension.GetColumnTitle(Col: integer): string;
begin
  // TODO: Replace the following with code to return the column heading for
  // Column number Col. Return a null string when no more columns are to be
  // defined.
  if Col = 0 then Result := 'Name'
  else if Col = 1 then Result := 'Index'
  else Result := '';
end;

function TIconManNamespaceExtension.GetDefaultColumn(var pSort,
  pDisplay: cardinal): boolean;
begin
  // Replace this code when column 0 is not the default column
  pSort := 1;
  pDisplay := 0;
  Result := true;
end;

function TIconManNamespaceExtension.GetDisplayName: string;
begin
  // Returns the display name for the root of your namespace.
  Result := 'System Icons';
end;

function TIconManNamespaceExtension.GetFirstId(var pData: TNamespaceItem;
  var Cookie: cardinal; FFlags: cardinal): boolean;
  var pItem : TIconManNamespaceItem;
begin
  // TODO: Replace the next line with code to create your folder item enumerator
  // and pass back the first item and a cookie that refers to the enumerator.
  pData := TIconManNamespaceItem.Create(nil);
  pItem := pData as TIconManNamespaceItem;
  Cookie := 0;
  pItem.Ind := 0;
  Result := True;
end;

function TIconManNamespaceExtension.GetIconIndex: integer;
begin
  // TODO: Replace the next line with code to return the icon index to use for
  // the namespace root.
  Result := 0;
end;

function TIconManNamespaceExtension.GetInfoTip: string;
begin
  // TODO: Replace the next line with code to return the info tip to use for the
  // namespace root
  Result := GetDisplayName;
end;

function TIconManNamespaceExtension.GetJunctionPoint: TJunctionPoint;
begin
  Result := jpControlPanel;
end;

function TIconManNamespaceExtension.GetNextId(pPrev: TNamespaceItem;
  var pData: TNamespaceItem; var Cookie: cardinal;
  FFlags: cardinal): boolean;
  var pItem : TIconManNamespaceItem;
begin
  // TODO: Replace the next line with code to return the item after pPrev from
  // the enumerator.  When there are no more items, return false.
  if Cookie > 47 then
    Result := False
  else begin
    pData := TIconManNamespaceItem.Create(nil);
    pItem := pData as TIconManNamespaceItem;
    Cookie := Cookie+1;
    pItem.Ind := Cookie;
    Result := True;
  end;
end;

function TIconManNamespaceExtension.IsValidObject: boolean;
begin
  //TODO: replace the next line to return true if the namespace object has not
  //changed.
  Result := True;
end;

function TIconManNamespaceExtension.GetMenuItems(mi : TExplorerMenuType;
              var DelphiMenu : TPopupMenu; var FreeOnCompletion : boolean) : boolean;
var
  item : TMenuItem;
begin
  Delphimenu := TPopupMenu.Create(nil);

  item := TMenuItem.Create(nil);
  item.Caption := 'Change';
  item.OnClick := Change;
  DelphiMenu.Items.Add(item);

  item := TMenuItem.Create(nil);
  item.Caption := 'Restore Default';
  item.OnClick := RestoreDefault;
  DelphiMenu.Items.Add(item);

  FreeOnCompletion := true;

  Result := true;
end;

function TIconManNameSpaceExtension.GetCPCategory: TCPCategory;
begin
  Result := cpAppearanceAndThemes;
end;

function TIconManNameSpaceExtension.GetWebPage: string;
begin
  Result := 'folder.htt';
end;

procedure TIconManNamespaceExtension.Change(sender: TObject);
var
  wtemp : widestring;
  stemp : string;
  i : integer;
  icn : cardinal;
  nsi : TIconManNamespaceItem;
  Reg : TRegistry;
  temp : TStringList;
  shfi : SHFILEINFO;
  hilLarge : HIMAGELIST;
  hilSmall : HIMAGELIST;
  hNewIconSmall : HICON;
  hNewIconLarge : HICON;
begin
  nsi := TIconManNameSpaceItem(Selections[0]);
  if Assigned(nsi) then begin
    wtemp := nsi.IconModule + #0;
    icn := nsi.IconIndex;
    SetLength(wtemp,260);
    if PickIconDlg(WndView,PWideChar(wtemp),260,icn) <> 0 then begin
      for i := 1 to 260 do begin
        if wtemp[i] = #0 then begin
          SetLength(wtemp,i-1);
          break;
        end;
      end;
      stemp := wtemp;
      reg := TRegistry.Create;
      try
        reg.RootKey := HKEY_LOCAL_MACHINE;
        reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Icons',true);
        if (Pos('SHELL32.DLL',UpperCase(stemp)) <> 0) and (icn = nsi.Ind) then begin
          // delete the registry entry if it is there
          nsi.IconModule := '';
          nsi.IconIndex := -1;
          if reg.ValueExists(IntToStr(nsi.Ind)) then
            reg.DeleteValue(IntToStr(nsi.Ind));
        end else begin
          // Modify or add the registry entry
          nsi.IconModule := stemp;
          nsi.IconIndex := icn;
          temp := TStringList.Create;
          try
            temp.Add(stemp);
            temp.Add(IntToStr(icn));
            stemp := temp.CommaText;
          finally
            temp.Free;
          end;
          reg.WriteString(IntToStr(nsi.Ind),stemp);
        end;
        UpdateAddedItem(nsi,false);
        if (assigned(SHUpdateImage)) then
          SHUpdateImage(PChar(nsi.IconModule), nsi.IconIndex, 0, nsi.Ind);
        ExtractIconEx(PChar(nsi.IconModule), nsi.IconIndex, hNewIconLarge, hNewIconSmall, 1);
        hilLarge := SHGetFileInfo('*.dll', FILE_ATTRIBUTE_NORMAL, shfi, SizeOf(shfi), SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_LARGEICON);
        ImageList_ReplaceIcon(hilLarge, nsi.Ind, hNewIconLarge);
        hilSmall := SHGetFileInfo('*.dll', FILE_ATTRIBUTE_NORMAL, shfi, SizeOf(shfi), SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
        ImageList_ReplaceIcon(hilSmall, nsi.Ind, hNewIconSmall);
        SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST or SHCNF_FLUSHNOWAIT, nil, nil);
        SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST or SHCNF_FLUSHNOWAIT, nil, nil);
      finally
        reg.Free;
      end;
    end;
  end;
end;

procedure TIconManNamespaceExtension.RestoreDefault(sender: TObject);
var
  nsi : TIconManNamespaceItem;
  Reg : TRegistry;
  shfi : SHFILEINFO;
  hilLarge : HIMAGELIST;
  hilSmall : HIMAGELIST;
  hNewIconSmall : HICON;
  hNewIconLarge : HICON;
begin
  nsi := TIconManNameSpaceItem(Selections[0]);
  if Assigned(nsi) then begin
    reg := TRegistry.Create;
    try
      reg.RootKey := HKEY_LOCAL_MACHINE;
      reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Icons',true);
      if reg.ValueExists(IntToStr(nsi.Ind)) then
        reg.DeleteValue(IntToStr(nsi.Ind));
      nsi.IconModule := '';
      nsi.IconIndex := nsi.Ind;
      UpdateAddedItem(nsi,false);
      if (assigned(SHUpdateImage)) then
        SHUpdateImage(PChar(nsi.IconModule), nsi.IconIndex, 0, nsi.Ind);
      ExtractIconEx(PChar(nsi.IconModule), nsi.IconIndex, hNewIconLarge, hNewIconSmall, 1);
      hilLarge := SHGetFileInfo('*.dll', FILE_ATTRIBUTE_NORMAL, shfi, SizeOf(shfi), SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_LARGEICON);
      ImageList_ReplaceIcon(hilLarge, nsi.Ind, hNewIconLarge);
      hilSmall := SHGetFileInfo('*.dll', FILE_ATTRIBUTE_NORMAL, shfi, SizeOf(shfi), SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
      ImageList_ReplaceIcon(hilSmall, nsi.Ind, hNewIconSmall);
      SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST or SHCNF_FLUSHNOWAIT, nil, nil);
      SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST or SHCNF_FLUSHNOWAIT, nil, nil);
    finally
      reg.Free;
    end;
  end;
end;


initialization
  hShell32 := LoadLibrary('shell32.dll');
  FileIconInit := GetProcAddress(hShell32, MakeIntResource(660));
  SHUpdateImage := GetProcAddress(hShell32, MakeIntResource(191));
  RegisterClass(TIconManNamespaceItem);
  TNamespaceExtensionFactory.Create(ComServer, TIconManNamespaceExtension,
                                    Class_IconManNamespaceExtension,
                                    Class_IconManUIObject, 'IconManNamespaceExtension',
                                    'System Icons',
                                    ciMultiInstance, tmApartment);

  TUIClassFactory.Create(ComServer, TShellUIObject, Class_IconManUIObject,
    'IconManUIObject', 'System Icons - UI Object', ciMultiInstance, tmApartment);

end.