// Der folgende Code entstand aufgrund einer Email-Anfrage.
// Es sollte ein Dialog erstellt werden, dem man den Namen eines Ordners
// übergibt, und der dann die erste Ebene der Unterordner als Karteikarten
// abbildet, auf denen die jeweils enthaltenen Dateien als Icons zu sehen sind.
// Für leere Ordner wird keine Karteikarte erzeugt.
// Zusätzlich habe ich noch eine Reaktion bei einem Doppelklick auf ein Icon
// dazugebastelt.

// Getestet mit D4 unter XP

  ... 
  private 
    { Private-Deklarationen } 
  public 
    function GetHIcon(Datei: string): HIcon; 
    procedure findfile(pfad: string; gefunden: TStrings); 
    procedure findDir(pfad: string; gefunden: TStrings); 
    function Dlg: boolean; 
    procedure Mydblclick(sender: TObject); 
    procedure MyResize(Sender: TObject); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
uses filectrl, shellapi, commctrl, comctrls;
 
var 
  Ordner: string; 
 
procedure TForm1.Mydblclick(sender: TObject); 
var 
  p: TPoint; 
  th: THandle; 
  inf: _LV_HITTESTINFO; 
  c: Pchar; 
  s: string; 
begin 
  getcursorpos(p); 
  th := TListview(sender).handle; 
  p := TListview(sender).screentoclient(p); 
  inf.pt := p; 
  ListView_HitTest(th, inf); 
  if inf.iitem >= 0 then 
  begin 
    getmem(c, max_path); 
    ListView_GetItemText(th, inf.iitem, 0, c, max_path); 
    s := c; 
    freemem(c); 
    s := ordner + TTabsheet(Tlistview(sender).parent).caption + '\' + s; 
    // "s" enthält jetzt den kompletten Pfad und Namen der Datei. 
    if fileexists(s) then 
    begin 
      // Hier können dann entsprechende Aktivitäten folgen. 
      // z.B.: 
      showmessage(s); 
    end; 
  end; 
end; 
 
function TForm1.GetHIcon(Datei: string): HIcon; 
var 
  FileInfo: SHFileInfo; 
begin 
  SHGetFileInfo(pchar(Datei), 0, FileInfo, 
    sizeof(FileInfo), SHGFI_USEFILEATTRIBUTES or SHGFI_Icon); 
  result := FileInfo.hIcon; 
end; 
 
procedure TForm1.findfile(pfad: string; gefunden: TStrings); 
var 
  sr: TWin32FindData; 
  h: THandle; 
begin 
  gefunden.clear; 
  h := FindFirstFile(PChar(pfad + '*.*'), sr); 
  if h <> INVALID_HANDLE_VALUE then 
    repeat 
      if sr.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then 
        gefunden.add(sr.cFileName); 
    until Findnextfile(h, sr) = false; 
  windows.FindClose(h); 
end; 
 
procedure TForm1.findDir(pfad: string; gefunden: TStrings); 
var 
  sr: TWin32FindData; 
  h: THandle; 
begin 
  h := FindFirstFile(PChar(pfad + '*.*'), sr); 
  if h <> INVALID_HANDLE_VALUE then 
    repeat 
      if (sr.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0) 
        and (string(sr.cFileName) <> '.') and (string(sr.cFileName) <> '..') 
          then 
        gefunden.add(sr.cFileName); 
    until Findnextfile(h, sr) = false; 
  windows.FindClose(h); 
end; 
 
procedure TForm1.MyResize(Sender: TObject); 
var 
  x: integer; 
begin 
  with TForm(sender) do 
    for x := 0 to componentcount - 1 do 
      if components[x] is TListview then 
        TListview(components[x]).arrange(arDefault); 
end; 
 
function TForm1.Dlg: boolean; 
var 
  edg: string; 
  basis: TForm; 
  tts: TTabsheet; 
  tli: TListitem; 
  il: TImagelist; 
  pc: TPageControl; 
  w, h, i, j: integer; 
  sld, slf, sli: TStringlist; 
  function idx: boolean; 
  var 
    x: integer; 
  begin 
    for x := 0 to sli.count - 1 do 
    begin 
      if sli[x] = edg then 
      begin 
        tli.imageindex := x; 
        result := true; 
        exit; 
      end; 
    end; 
    result := false; 
  end; 
begin 
  result := false; 
  if not directoryexists(ordner) then 
    exit; 
  screen.cursor := crhourglass; 
  try 
    w := 500; 
    h := 300; 
    if ansilastchar(ordner) <> '\' then 
      ordner := ordner + '\'; 
    sld := TStringlist.create; 
    slf := TStringlist.create; 
    sli := TStringlist.create; 
    finddir(ordner, sld); 
    basis := TForm.create(nil); 
    il := TImagelist.create(basis); 
    il.width := 32; 
    il.height := il.width; 
    with basis do 
    begin 
      borderstyle := bssizetoolwin; 
      caption := ordner; 
      onResize := Myresize; 
      setbounds((screen.width - w) div 2, (screen.height - h) div 2, w, h); 
      pc := TPagecontrol.create(basis); 
      pc.parent := basis; 
      pc.align := alclient; 
      with pc do 
        for i := 0 to sld.count - 1 do 
        begin 
          findfile(ordner + sld[i] + '\', slf); 
          if slf.count > 0 then 
          begin 
            tts := TTabsheet.create(basis); 
            with tts do 
            begin 
              PageControl := pc; 
              Caption := sld[i]; 
              with TListview.create(basis) do 
              begin 
                largeimages := il; 
                align := alclient; 
                parent := tts; 
                viewstyle := vsIcon; 
                ondblclick := Mydblclick; 
                for j := 0 to slf.count - 1 do 
                begin 
                  tli := items.add; 
                  tli.caption := slf[j]; 
                  edg := lowercase(extractfileext(slf[j])); 
                  if not idx then 
                  begin 
                    tli.imageindex := ImageList_AddIcon(il.handle, 
                      gethicon(ordner + sld[i] + '\' + slf[j])); 
                    sli.add(edg); 
                  end; 
                end; 
              end; 
            end; 
          end; 
        end; 
      sld.free; 
      slf.free; 
      sli.free; 
      showmodal; 
      free; 
    end; 
  except 
    screen.cursor := crdefault; 
    exit; 
  end; 
  result := true; 
  screen.cursor := crdefault; 
end; 
 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  ordner := 'C:\Programme\Microsoft Office\Office10'; 
  if not dlg then 
    showmessage('FEHLER'); 
end;



Zugriffe seit 6.9.2001 auf Delphi-Ecke