// 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;
|