Create menus from directory tree (advanced)

Problem/Question/Abstract:

The enhanced version of my CreateTreeMenus

Answer:

You nedd to create only a ImageList and a Menu.

procedure TfrmMain.CreateTreeMenus(Path: string; Root: TMenuItem; ListImage:
  TImageList);
type
  pHIcon = ^HIcon;
var
  SR: TSearchRec;
  Result: Integer;
  Item: TMenuItem;
  SmallIcon: HIcon;
  IconA: TIcon;
  BitMapA: TBitMap;
  Indice: Integer;
  procedure GetAssociatedIcon(FileName: TFilename; pLargeIcon, PSmallIcon: pHIcon);
  var
    IconIndex: Word;
    FileExt: string;
    FileType: string;
    Reg: TRegistry;
    p: Integer;
    p1: pChar;
    p2: pChar;
    function GetSystemDir: TFileName;
    var
      SysDir: array[0..MAX_PATH - 1] of Char;
    begin
      SetString(Result, SysDir, GetSystemDirectory(SysDir, MAX_PATH));
      if (Result = '') then
        raise Exception.Create(SysErrorMessage(GetLastError));
    end;
  label
    NoAssoc;
  begin
    IconIndex := 0;
    FileExt := UpperCase(ExtractFileExt(FileName));
    if (((FileExt <> '.EXE') and (FileExt <> '.ICO')) or (not (FileExists(FileName))))
      then
    begin
      Reg := nil;
      try
        Reg := TRegistry.Create(KEY_QUERY_VALUE);
        Reg.RootKey := HKEY_CLASSES_ROOT;
        if (FileExt = '.EXE') then
          FileExt := '.COM';
        if (Reg.OpenKeyReadOnly(FileExt)) then
        try
          FileType := Reg.ReadString('');
        finally
          Reg.CloseKey;
        end;
        if ((FileType <> '') and Reg.OpenKeyReadOnly(FileType + '\DefaultIcon')) then
        try
          FileName := Reg.ReadString('');
        finally
          Reg.CloseKey;
        end;
      finally
        Reg.Free;
      end;
      if (FileName = '') then
        goto NoAssoc;
      p1 := PChar(FileName);
      p2 := StrRScan(p1, ',');
      if (p2 <> nil) then
      begin
        p := p2 - p1 + 1;
        IconIndex := StrToInt(Copy(FileName, p + 1, Length(FileName) - p));
        SetLength(FileName, p - 1);
      end;
    end;
    if (ExtractIconEx(PChar(FileName), IconIndex, PLargeIcon^, PSmallIcon^, 1) <> 1)
      then
    begin
      NoAssoc:
      try
        FileName := IncludeTrailingBackslash(GetSystemDir) + 'SHELL32.DLL';
      except
        FileName := 'C:\WINDOWS\SYSTEM\SHELL32.DLL';
      end;
      if (FileExt = '.DOC') then
        IconIndex := 1
      else if ((FileExt = '.EXE') or (FileExt = '.COM')) then
        IconIndex := 2
      else if (FileExt = '.HLP') then
        IconIndex := 23
      else if ((FileExt = '.INI') or (FileExt = '.INF')) then
        IconIndex := 63
      else if (FileExt = '.TXT') then
        IconIndex := 64
      else if (FileExt = '.BAT') then
        IconIndex := 65
      else if ((FileExt = '.DLL') or (FileExt = '.SYS') or (FileExt = '.VBX') or
        (FileExt = '.OCX') or (FileExt = '.VXD')) then
        IconIndex := 66
      else if (FileExt = '.FON') then
        IconIndex := 67
      else if (FileExt = '.TTF') then
        IconIndex := 68
      else if (FileExt = '.FOT') then
        IconIndex := 69
      else
        IconIndex := 0;
      if ((ExtractIconEx(PChar(FileName), IconIndex, PLargeIcon^, PSmallIcon^, 1) <>
        1)) then
      begin
        if (PLargeIcon <> nil) then
          PLargeIcon^ := 0;
        if (PSmallIcon <> nil) then
          PSmallIcon^ := 0;
      end;
    end;
  end;
begin
  Path := IncludeTrailingBackSlash(Path);
  Result := FindFirst(Path + '*.*', faDirectory, SR);
  while (Result = 0) do
  begin
    if (((SR.Attr and faDirectory) <> 0) and (SR.Name <> '.') and (SR.Name <> '..'))
      then
    begin
      Item := TMenuItem.Create(Self);
      Item.Caption := SR.Name;
      Item.ImageIndex := 0;
      Root.Add(Item);
      CreateTreeMenus(Path + SR.Name, Item, ListImage);
    end;
    if (((SR.Attr and faAnyFile) <> 0) and (SR.Name <> '.') and (SR.Name <> '..'))
      then
    begin
      Item := TMenuItem.Create(Self);
      Item.Caption := SR.Name;
      GetAssociatedIcon(sr.Name, nil, @SmallIcon);
      IconA := TIcon.Create;
      IconA.Handle := SmallIcon;
      BitMapA := TBitMap.Create;
      BitMapA.Width := IconA.Width;
      BitMapA.Height := IconA.Height;
      BitMapA.Canvas.Draw(0, 0, IconA);
      BitMapA.TransparentMode := tmAuto;
      Indice := ListImage.Add(BitMapA, nil);
      Item.ImageIndex := Indice;
      Root.Add(Item);
    end;
    Result := FindNext(SR);
  end;
  SysUtils.FindClose(SR);
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  CreateTreeMenus('c:\projects\', directory1, ImageList1);
end;

You can also use shgetfileinfo with SHGFI_ICON parameter in the place of checking individual file extension.