Mega Code Archive
How to create menus from folder tree (advanced)
<![CDATA[
Title: How to create menus from folder tree (advanced)
Question: 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;
]]>