Create menus from directory tree (advanced) (Views: 30)
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. |