帮我注释一下。。有好多我不懂。。谢谢 ( 积分: 50 )

  • 主题发起人 主题发起人 一剑飘雪
  • 开始时间 开始时间
一

一剑飘雪

Unregistered / Unconfirmed
GUEST, unregistred user!
unit VListView;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, StdCtrls, ToolWin, ShlObj, ImgList, Menus;

type
PShellItem = ^TShellItem;
TShellItem = record
FullID, //Full全部
ID: PItemIDList;
Empty: Boolean; //Empty空闲
DisplayName, //Display显示
TypeName: string;
ImageIndex,
Size,
Attributes: Integer;
ModDate: string;
end;

TForm1 = class(TForm)
ListView: TListView;
CoolBar1: TCoolBar;
ToolBar2: TToolBar;
ToolbarImages: TImageList;
btnBrowse: TToolButton;
btnLargeIcons: TToolButton;
btnSmallIcons: TToolButton;
btnList: TToolButton;
btnReport: TToolButton;
cbPath: TComboBox;
ToolButton3: TToolButton;
PopupMenu1: TPopupMenu;
btnBack: TToolButton;
procedure FormCreate(Sender: TObject);
procedure ListViewData(Sender: TObject; Item: TListItem);
procedure btnBrowseClick(Sender: TObject);
procedure cbPathKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure cbPathClick(Sender: TObject);
procedure btnLargeIconsClick(Sender: TObject);
procedure ListViewDblClick(Sender: TObject);
procedure ListViewDataHint(Sender: TObject; StartIndex,
EndIndex: Integer);
procedure ListViewKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure ListViewDataFind(Sender: TObject; Find: TItemFind;
const FindString: String; const FindPosition: TPoint;
FindData: Pointer; StartIndex: Integer; Direction: TSearchDirection;
Wrap: Boolean; var Index: Integer);
procedure ListViewCustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
procedure ListViewCustomDrawSubItem(Sender: TCustomListView;
Item: TListItem; SubItem: Integer; State: TCustomDrawState;
var DefaultDraw: Boolean);
procedure btnBackClick(Sender: TObject);
procedure Form1Close(Sender: TObject; var Action: TCloseAction);
private
FPIDL: PItemIDList; //保含一个列表的项目标识 前面P意思
FIDList: TList;
FIShellFolder, //外壳中的文件夹可以通过一个IShellFolder COM接口来进行控制
FIDesktopFolder: IShellFolder;
FPath: string; //一个namespace是一个收藏符号
procedure SetPath(const Value: string); overload;
procedure SetPath(ID: PItemIDList); overload;
procedure PopulateIDList(ShellFolder: IShellFolder); //Populate板上组装
procedure ClearIDList;
procedure CheckShellItems(StartIndex, EndIndex: Integer); //Check检查
function ShellItem(Index: Integer): PShellItem;
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

uses ShellAPI, ActiveX, ComObj, CommCtrl, FileCtrl;

//PIDL MANIPULATION
//PIDL 处理

procedure DisposePIDL(ID: PItemIDList); //Dispose处理
var
Malloc: IMalloc; //那个对象链接和嵌入的Malloc分配、释放和处理内存
begin
if ID = nil then Exit;
OLECheck(SHGetMalloc(Malloc)); //获得一个IMalloc接口实例
Malloc.Free(ID);
end;

function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
begin
Result := Malloc.Alloc(ID^.mkid.cb + SizeOf(ID^.mkid.cb)); //Alloc分配一块的内存
CopyMemory(Result, ID, ID^.mkid.cb + SizeOf(ID^.mkid.cb));
end;

function NextPIDL(IDList: PItemIDList): PItemIDList;
begin
Result := IDList;
Inc(PChar(Result), IDList^.mkid.cb);
end;

function GetPIDLSize(IDList: PItemIDList): Integer;
begin
Result := 0;
if Assigned(IDList) then
begin
Result := SizeOf(IDList^.mkid.cb);
while IDList^.mkid.cb <> 0 do
begin
Result := Result + IDList^.mkid.cb;
IDList := NextPIDL(IDList);
end;
end;
end;


procedure StripLastID(IDList: PItemIDList);
var
MarkerID: PItemIDList;
begin
MarkerID := IDList;
if Assigned(IDList) then
begin
while IDList.mkid.cb <> 0 do
begin
MarkerID := IDList;
IDList := NextPIDL(IDList);
end;
MarkerID.mkid.cb := 0;
end;
end;

function CreatePIDL(Size: Integer): PItemIDList;
var
Malloc: IMalloc;
HR: HResult;
begin
Result := nil;

HR := SHGetMalloc(Malloc);
if Failed(HR) then
Exit;

try
Result := Malloc.Alloc(Size);
if Assigned(Result) then
FillChar(Result^, Size, 0);
finally
end;
end;

function CopyPIDL(IDList: PItemIDList): PItemIDList;
var
Size: Integer;
begin
Size := GetPIDLSize(IDList);
Result := CreatePIDL(Size);
if Assigned(Result) then
CopyMemory(Result, IDList, Size);
end;

function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
var
cb1, cb2: Integer;
begin
if Assigned(IDList1) then
cb1 := GetPIDLSize(IDList1) - SizeOf(IDList1^.mkid.cb)
else
cb1 := 0;

cb2 := GetPIDLSize(IDList2);

Result := CreatePIDL(cb1 + cb2);
if Assigned(Result) then
begin
if Assigned(IDList1) then
CopyMemory(Result, IDList1, cb1);
CopyMemory(PChar(Result) + cb1, IDList2, cb2);
end;
end;

//SHELL FOLDER ITEM INFO

function GetDisplayName(ShellFolder: IShellFolder; PIDL: PItemIDList;
ForParsing: Boolean): string;
var
StrRet: TStrRet;
P: PChar;
Flags: Integer;
begin
Result := '';
if ForParsing then
Flags := SHGDN_FORPARSING //显示返回来的类型
else
Flags := SHGDN_NORMAL;

ShellFolder.GetDisplayNameOf(PIDL, Flags, StrRet); //获得一个PIDL对应的显示名称
case StrRet.uType of
STRRET_CSTR: //返回的字符串
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
STRRET_OFFSET: //查找字符串
begin
P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
end;
STRRET_WSTR:
Result := StrRet.pOleStr;
end;
end;

function GetShellImage(PIDL: PItemIDList; Large, Open: Boolean): Integer;
var
FileInfo: TSHFileInfo;
Flags: Integer;
begin
FillChar(FileInfo, SizeOf(FileInfo), #0);
Flags := SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_ICON;
if Open then Flags := Flags or SHGFI_OPENICON;
if Large then Flags := Flags or SHGFI_LARGEICON
else Flags := Flags or SHGFI_SMALLICON;
SHGetFileInfo(PChar(PIDL),
0,
FileInfo,
SizeOf(FileInfo),
Flags);
Result := FileInfo.iIcon;
end;

function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
var
Flags: UINT;
begin
Flags := SFGAO_FOLDER;
ShellFolder.GetAttributesOf(1, ID, Flags);
Result := SFGAO_FOLDER and Flags <> 0;
end;


function ListSortFunc(Item1, Item2: Pointer): Integer;
begin
Result := SmallInt(Form1.FIShellFolder.CompareIDs(
0,
PShellItem(Item1).ID,
PShellItem(Item2).ID
));
end;

{TForm1}

//GENERAL FORM METHODS

procedure TForm1.FormCreate(Sender: TObject);
var
FileInfo: TSHFileInfo; //TSHFileInfo包含一个文件对象信息
ImageListHandle: THandle; //THandle是操作系统资源
NewPIDL: PItemIDList; //保含一个列表的项目标识
begin
OLECheck(SHGetDesktopFolder(FIDesktopFolder)); //获得桌面接口 IShellFolder外壳文件夹访问接口
FIShellFolder := FIDesktopFolder; //二个都是IShellFolder类型 好像无用
FIDList := TList.Create;
ImageListHandle := SHGetFileInfo('C:/',
0,
FileInfo,
SizeOf(FileInfo), //得到小图标
SHGFI_SYSICONINDEX or SHGFI_SMALLICON);

//目地窗口句柄 赋值一个图像列表到一个列表查看控制
SendMessage(ListView.Handle, LVM_SETIMAGELIST, LVSIL_SMALL, ImageListHandle);

ImageListHandle := SHGetFileInfo('C:/',
0,
FileInfo,
SizeOf(FileInfo), //得到大图标
SHGFI_SYSICONINDEX or SHGFI_LARGEICON);

SendMessage(ListView.Handle, LVM_SETIMAGELIST, LVSIL_NORMAL, ImageListHandle);

OLECheck(
SHGetSpecialFolderLocation( //由PIDL获得特色文件夹的相应文件路径
Application.Handle, //所有者的窗口句柄
CSIDL_DRIVES, //程序启动时所指文件夹
NewPIDL) //NewPIDL: PItemIDList;
); //指向项目标识符位置的文件夹位置
SetPath(NewPIDL);
ActiveControl := cbPath; //焦点控件
cbPath.SelStart := 0;
cbPath.SelStart := Length(cbPath.Text); //光标在文本处的位置
end;

procedure TForm1.btnBrowseClick(Sender: TObject);
var
S: string;
begin
S := '';
if SelectDirectory('Select Directory', '', S) then
SetPath(S);
end;

procedure TForm1.cbPathKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_RETURN then
begin
if cbPath.Text[Length(cbPath.Text)] = ':' then
cbPath.Text := cbPath.Text + '/';
SetPath(cbPath.Text);
Key := 0;
end;
end;

procedure TForm1.cbPathClick(Sender: TObject);
var
I: Integer;
begin
I := cbPath.Items.IndexOf(cbPath.Text);
if I >= 0 then
SetPath(PItemIDList(cbPath.Items.Objects))
else
SetPath(cbPath.Text);
end;

procedure TForm1.btnLargeIconsClick(Sender: TObject);
begin
ListView.ViewStyle := TViewStyle((Sender as TComponent).Tag);
end;

procedure TForm1.ListViewDblClick(Sender: TObject);
var
RootPIDL,
ID: PItemIDList; //包含一列项目标识符
begin
if ListView.Selected <> nil then
begin
ID := ShellItem(ListView.Selected.Index).ID;
//显示鼠标当前选中位置
if not IsFolder(FIShellFolder, ID) then Exit;
RootPIDL := ConcatPIDLs(FPIDL, ID); { var }
SetPath(RootPIDL); { IDList: TList; }
end; { S: string; }
end; { begin }
{ IDList := TList.Create; }
function TForm1.ShellItem(Index: Integer): PShellItem; { IDList.Add(PChar('aa')); }
begin { S := PChar(IDList[0]); }
Result := PShellItem(FIDList[Index]); { ShowMessage(S); }
end; //FIDList: TList { end; }
//返回所在的字符串
procedure TForm1.ListViewKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_RETURN:
ListViewDblClick(Sender);
VK_BACK:
btnBackClick(Sender);
end;
end;

//SHELL-RELATED ROUTINES.

procedure TForm1.ClearIDList;
var
I: Integer;
begin
for I := 0 to FIDList.Count-1 do //FIDList := TList.Create;
begin
DisposePIDL(ShellItem(I).ID); //如果为nil则Exit,返之获得IMalloc接口实例
Dispose(ShellItem(I)); //释放
end;
FIDList.Clear;
end;

procedure TForm1.PopulateIDList(ShellFolder: IShellFolder);
const
Flags = SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN;
var
ID: PItemIDList;
EnumList: IEnumIDList;
NumIDs: LongWord;
SaveCursor: TCursor;
ShellItem: PShellItem;
begin
SaveCursor := Screen.Cursor;
try
Screen.Cursor := crHourglass;
OleCheck( //列举物体在文件夹
ShellFolder.EnumObjects( //调用所获得的IShellFolder接口的EnumObjects成员函数列举出子文件夹
Application.Handle, //是属主窗口的句柄
Flags,
EnumList) //地址接受那个返回的一个指针
); //到IEnumIDList接口创造通过的方法

FIShellFolder := ShellFolder; //?
ClearIDList;
while EnumList.Next(1, ID, NumIDs) = S_OK do
begin
ShellItem := New(PShellItem); //产生新的动态变数和组合 P 指出到它
ShellItem.ID := ID;
ShellItem.DisplayName := GetDisplayName(FIShellFolder, ID, False);
ShellItem.Empty := True; //显示图标用的参数
FIDList.Add(ShellItem);
end;

FIDList.Sort(ListSortFunc); //好像是列表分类排列

//We need to tell the ListView how many items it has.
ListView.Items.Count := FIDList.Count;

ListView.Repaint; //重画全部的控制
finally
Screen.Cursor := SaveCursor;
end;
end;

procedure TForm1.SetPath(const Value: string);
var
P: PWideChar; {如果要获得文件系统的路径,得先获得 }
NewPIDL: PItemIDList; {IShellFolder接口,然后把要转化的路 }
Flags, {径名转化为PWideChar 类型的以null结 }
NumChars: LongWord; {尾的UNICODE字符串，然后作为参数调 }
begin {用桌面的IShellFolder接口的ParseDisplayName }
NumChars := Length(Value); {方法才能获得PIDL }
Flags := 0; //文件的属性
P := StringToOleStr(Value);

OLECheck(
FIDesktopFolder.ParseDisplayName( //文件名到项目标识符(PIDL)
Application.Handle,
nil,
P,
NumChars,
NewPIDL,
Flags)
);
SetPath(NewPIDL);
end;

procedure TForm1.SetPath(ID: PItemIDList);
var
Index: Integer;
NewShellFolder: IShellFolder;
begin
//调用IShellFolder的BindToObject成员函数获得子文件夹的IShellFolder接口
OLECheck(
FIDesktopFolder.BindToObject(
ID, //识别子文件夹相对于父文件夹
nil,
IID_IShellFolder, //归还接口，该处一定要指向该参数
Pointer(NewShellFolder)) //地址收到的接口指针
);

ListView.Items.BeginUpdate; //屏幕重画
try
PopulateIDList(NewShellFolder);
FPIDL := ID;
FPath := GetDisplayName(FIDesktopFolder, FPIDL, True);
Index := cbPath.Items.IndexOf(FPath); //返回字符串在列表中的位置
if (Index < 0) then
begin
cbPath.Items.InsertObject(0, FPath, Pointer(FPIDL));//插入字符串到该位置,并与对象发生连接
cbPath.Text := cbPath.Items[0];
end
else begin
cbPath.ItemIndex := Index;
cbPath.Text := cbPath.Items[cbPath.ItemIndex];
end;

if ListView.Items.Count > 0 then //如果listview里面项目大于2,则焦点放在第1项
begin
ListView.Selected := ListView.Items[0];
ListView.Selected.Focused := True;
ListView.Selected.MakeVisible(False);
end;
finally
ListView.Items.EndUpdate; //关掉BeginUpdate屏幕重画
end;
end;

//ROUTINES FOR MANAGING VIRTUAL DATA

procedure TForm1.CheckShellItems(StartIndex, EndIndex: Integer);

function ValidFileTime(FileTime: TFileTime): Boolean;
begin
Result := (FileTime.dwLowDateTime <> 0) or (FileTime.dwHighDateTime <> 0);
end;

var
FileData: TWin32FindData;
FileInfo: TSHFileInfo;
SysTime: TSystemTime;
I: Integer;
LocalFileTime: TFILETIME;
begin
//Here all the data that wasn't initialized in PopulateIDList is
//filled in.
for I := StartIndex to EndIndex do
begin
if ShellItem(I)^.Empty then
with ShellItem(I)^ do
begin
FullID := ConcatPIDLs(FPIDL, ID);
ImageIndex := GetShellImage(FullID, ListView.ViewStyle = vsIcon, False);

//File Type
SHGetFileInfo(
PChar(FullID),
0,
FileInfo,
SizeOf(FileInfo),
SHGFI_TYPENAME or SHGFI_PIDL
);
TypeName := FileInfo.szTypeName;

//Get File info from Windows
FillChar(FileData, SizeOf(FileData), #0);
SHGetDataFromIDList(
FIShellFolder,
ID,
SHGDFIL_FINDDATA,
@FileData,
SizeOf(FileData)
);

//File Size, in KB
Size := (FileData.nFileSizeLow + 1023 ) div 1024;
if Size = 0 then Size := 1;

//Modified Date
FillChar(LocalFileTime, SizeOf(TFileTime), #0);
with FileData do
if ValidFileTime(ftLastWriteTime)
and FileTimeToLocalFileTime(ftLastWriteTime, LocalFileTime)
and FileTimeToSystemTime(LocalFileTime, SysTime) then
try
ModDate := DateTimeToStr(SystemTimeToDateTime(SysTime))
except
on EConvertError do ModDate := '';
end
else
ModDate := '';

//Attributes
Attributes := FileData.dwFileAttributes;

//Flag this record as complete.
Empty := False;
end;
end;
end;

procedure TForm1.ListViewDataHint(Sender: TObject; StartIndex,
EndIndex: Integer);
begin
//OnDataHint is called before OnData. This gives you a chance to
//initialize only the data structures that need to be drawn.
//You should keep track of which items have been initialized so no
//extra work is done.
if (StartIndex > FIDList.Count) or (EndIndex > FIDList.Count) then Exit;
CheckShellItems(StartIndex, EndIndex);
end;

procedure TForm1.ListViewData(Sender: TObject; Item: TListItem);
var
Attrs: string;
begin
//OnData gets called once for each item for which the ListView needs
//data. If the ListView is in Report View, be sure to add the subitems.
//Item is a "dummy" item whose only valid data is it's index which
//is used to index into the underlying data.
if (Item.Index > FIDList.Count) then Exit;
with ShellItem(Item.Index)^ do
begin
Item.Caption := DisplayName;
Item.ImageIndex := ImageIndex;

if ListView.ViewStyle <> vsReport then Exit;

if not IsFolder(FIShellFolder, ID) then
Item.SubItems.Add(Format('%dKB', [Size]))
else
Item.SubItems.Add('');
Item.SubItems.Add(TypeName);
try
Item.SubItems.Add(ModDate);
except
end;

if Bool(Attributes and FILE_ATTRIBUTE_READONLY) then Attrs := Attrs + 'R';
if Bool(Attributes and FILE_ATTRIBUTE_HIDDEN) then Attrs := Attrs + 'H';
if Bool(Attributes and FILE_ATTRIBUTE_SYSTEM) then Attrs := Attrs + 'S';
if Bool(Attributes and FILE_ATTRIBUTE_ARCHIVE) then Attrs := Attrs + 'A';
end;
Item.SubItems.Add(Attrs);
end;

procedure TForm1.ListViewDataFind(Sender: TObject; Find: TItemFind;
const FindString: String; const FindPosition: TPoint; FindData: Pointer;
StartIndex: Integer; Direction: TSearchDirection; Wrap: Boolean;
var Index: Integer);
//OnDataFind gets called in response to calls to FindCaption, FindData,
//GetNearestItem, etc. It also gets called for each keystroke sent to the
//ListView (for incremental searching)
var
I: Integer;
Found: Boolean;
begin
I := StartIndex;
if (Find = ifExactString) or (Find = ifPartialString) then
begin
repeat
if (I = FIDList.Count-1) then
if Wrap then I := 0 else Exit;
Found := Pos(UpperCase(FindString), UpperCase(ShellItem(I)^.DisplayName)) = 1;
Inc(I);
until Found or (I = StartIndex);
if Found then Index := I-1;
end;
end;

procedure TForm1.ListViewCustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
var
Attrs: Integer;
begin
if Item = nil then Exit;
Attrs := ShellItem(Item.Index).Attributes;
if Bool(Attrs and FILE_ATTRIBUTE_READONLY) then
ListView.Canvas.Font.Color := clGrayText;
if Bool(Attrs and FILE_ATTRIBUTE_HIDDEN) then
ListView.Canvas.Font.Style :=
ListView.Canvas.Font.Style + [fsStrikeOut];
if Bool(Attrs and FILE_ATTRIBUTE_SYSTEM) then
Listview.Canvas.Font.Color := clHighlight;
end;

procedure TForm1.ListViewCustomDrawSubItem(Sender: TCustomListView;
Item: TListItem; SubItem: Integer; State: TCustomDrawState;
var DefaultDraw: Boolean);
begin
if SubItem = 0 then Exit;
ListView.Canvas.Font.Color := GetSysColor(COLOR_WINDOWTEXT);
//workaround for Win98 bug.
end;

procedure TForm1.btnBackClick(Sender: TObject);
var
Temp: PItemIDList;
begin
Temp := CopyPIDL(FPIDL);
if Assigned(Temp) then
StripLastID(Temp);
if Temp.mkid.cb <> 0 then
SetPath(Temp)
else
Beep;
end;

procedure TForm1.Form1Close(Sender: TObject; var Action: TCloseAction);
begin
ClearIDList;
FIDList.Free;
end;

end.
 
unit VListView;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, StdCtrls, ToolWin, ShlObj, ImgList, Menus;

type
PShellItem = ^TShellItem;
TShellItem = record
FullID, //Full全部
ID: PItemIDList;
Empty: Boolean; //Empty空闲
DisplayName, //Display显示
TypeName: string;
ImageIndex,
Size,
Attributes: Integer;
ModDate: string;
end;

TForm1 = class(TForm)
ListView: TListView;
CoolBar1: TCoolBar;
ToolBar2: TToolBar;
ToolbarImages: TImageList;
btnBrowse: TToolButton;
btnLargeIcons: TToolButton;
btnSmallIcons: TToolButton;
btnList: TToolButton;
btnReport: TToolButton;
cbPath: TComboBox;
ToolButton3: TToolButton;
PopupMenu1: TPopupMenu;
btnBack: TToolButton;
procedure FormCreate(Sender: TObject);
procedure ListViewData(Sender: TObject; Item: TListItem);
procedure btnBrowseClick(Sender: TObject);
procedure cbPathKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure cbPathClick(Sender: TObject);
procedure btnLargeIconsClick(Sender: TObject);
procedure ListViewDblClick(Sender: TObject);
procedure ListViewDataHint(Sender: TObject; StartIndex,
EndIndex: Integer);
procedure ListViewKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure ListViewDataFind(Sender: TObject; Find: TItemFind;
const FindString: String; const FindPosition: TPoint;
FindData: Pointer; StartIndex: Integer; Direction: TSearchDirection;
Wrap: Boolean; var Index: Integer);
procedure ListViewCustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
procedure ListViewCustomDrawSubItem(Sender: TCustomListView;
Item: TListItem; SubItem: Integer; State: TCustomDrawState;
var DefaultDraw: Boolean);
procedure btnBackClick(Sender: TObject);
procedure Form1Close(Sender: TObject; var Action: TCloseAction);
private
FPIDL: PItemIDList; //保含一个列表的项目标识 前面P意思
FIDList: TList;
FIShellFolder, //外壳中的文件夹可以通过一个IShellFolder COM接口来进行控制
FIDesktopFolder: IShellFolder;
FPath: string; //一个namespace是一个收藏符号
procedure SetPath(const Value: string); overload;
procedure SetPath(ID: PItemIDList); overload;
procedure PopulateIDList(ShellFolder: IShellFolder); //Populate板上组装
procedure ClearIDList;
procedure CheckShellItems(StartIndex, EndIndex: Integer); //Check检查
function ShellItem(Index: Integer): PShellItem;
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

uses ShellAPI, ActiveX, ComObj, CommCtrl, FileCtrl;

//PIDL MANIPULATION
//PIDL 处理

procedure DisposePIDL(ID: PItemIDList); //Dispose处理
var
Malloc: IMalloc; //那个对象链接和嵌入的Malloc分配、释放和处理内存
begin
if ID = nil then Exit;
OLECheck(SHGetMalloc(Malloc)); //获得一个IMalloc接口实例
Malloc.Free(ID);
end;

function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
begin
Result := Malloc.Alloc(ID^.mkid.cb + SizeOf(ID^.mkid.cb)); //Alloc分配一块的内存
CopyMemory(Result, ID, ID^.mkid.cb + SizeOf(ID^.mkid.cb));
end;

function NextPIDL(IDList: PItemIDList): PItemIDList;
begin
Result := IDList;
Inc(PChar(Result), IDList^.mkid.cb);
end;

function GetPIDLSize(IDList: PItemIDList): Integer;
begin
Result := 0;
if Assigned(IDList) then
begin
Result := SizeOf(IDList^.mkid.cb);
while IDList^.mkid.cb <> 0 do
begin
Result := Result + IDList^.mkid.cb;
IDList := NextPIDL(IDList);
end;
end;
end;


procedure StripLastID(IDList: PItemIDList);
var
MarkerID: PItemIDList;
begin
MarkerID := IDList;
if Assigned(IDList) then
begin
while IDList.mkid.cb <> 0 do
begin
MarkerID := IDList;
IDList := NextPIDL(IDList);
end;
MarkerID.mkid.cb := 0;
end;
end;

function CreatePIDL(Size: Integer): PItemIDList;
var
Malloc: IMalloc;
HR: HResult;
begin
Result := nil;

HR := SHGetMalloc(Malloc);
if Failed(HR) then
Exit;

try
Result := Malloc.Alloc(Size);
if Assigned(Result) then
FillChar(Result^, Size, 0);
finally
end;
end;

function CopyPIDL(IDList: PItemIDList): PItemIDList;
var
Size: Integer;
begin
Size := GetPIDLSize(IDList);
Result := CreatePIDL(Size);
if Assigned(Result) then
CopyMemory(Result, IDList, Size);
end;

function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
var
cb1, cb2: Integer;
begin
if Assigned(IDList1) then
cb1 := GetPIDLSize(IDList1) - SizeOf(IDList1^.mkid.cb)
else
cb1 := 0;

cb2 := GetPIDLSize(IDList2);

Result := CreatePIDL(cb1 + cb2);
if Assigned(Result) then
begin
if Assigned(IDList1) then
CopyMemory(Result, IDList1, cb1);
CopyMemory(PChar(Result) + cb1, IDList2, cb2);
end;
end;

//SHELL FOLDER ITEM INFO

function GetDisplayName(ShellFolder: IShellFolder; PIDL: PItemIDList;
ForParsing: Boolean): string;
var
StrRet: TStrRet;
P: PChar;
Flags: Integer;
begin
Result := '';
if ForParsing then
Flags := SHGDN_FORPARSING //显示返回来的类型
else
Flags := SHGDN_NORMAL;

ShellFolder.GetDisplayNameOf(PIDL, Flags, StrRet); //获得一个PIDL对应的显示名称
case StrRet.uType of
STRRET_CSTR: //返回的字符串
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
STRRET_OFFSET: //查找字符串
begin
P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
end;
STRRET_WSTR:
Result := StrRet.pOleStr;
end;
end;

function GetShellImage(PIDL: PItemIDList; Large, Open: Boolean): Integer;
var
FileInfo: TSHFileInfo;
Flags: Integer;
begin
FillChar(FileInfo, SizeOf(FileInfo), #0);
Flags := SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_ICON;
if Open then Flags := Flags or SHGFI_OPENICON;
if Large then Flags := Flags or SHGFI_LARGEICON
else Flags := Flags or SHGFI_SMALLICON;
SHGetFileInfo(PChar(PIDL),
0,
FileInfo,
SizeOf(FileInfo),
Flags);
Result := FileInfo.iIcon;
end;

function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
var
Flags: UINT;
begin
Flags := SFGAO_FOLDER;
ShellFolder.GetAttributesOf(1, ID, Flags);
Result := SFGAO_FOLDER and Flags <> 0;
end;


function ListSortFunc(Item1, Item2: Pointer): Integer;
begin
Result := SmallInt(Form1.FIShellFolder.CompareIDs(
0,
PShellItem(Item1).ID,
PShellItem(Item2).ID
));
end;

{TForm1}

//GENERAL FORM METHODS

procedure TForm1.FormCreate(Sender: TObject);
var
FileInfo: TSHFileInfo; //TSHFileInfo包含一个文件对象信息
ImageListHandle: THandle; //THandle是操作系统资源
NewPIDL: PItemIDList; //保含一个列表的项目标识
begin
OLECheck(SHGetDesktopFolder(FIDesktopFolder)); //获得桌面接口 IShellFolder外壳文件夹访问接口
FIShellFolder := FIDesktopFolder; //二个都是IShellFolder类型 好像无用
FIDList := TList.Create;
ImageListHandle := SHGetFileInfo('C:/',
0,
FileInfo,
SizeOf(FileInfo), //得到小图标
SHGFI_SYSICONINDEX or SHGFI_SMALLICON);

//目地窗口句柄 赋值一个图像列表到一个列表查看控制
SendMessage(ListView.Handle, LVM_SETIMAGELIST, LVSIL_SMALL, ImageListHandle);

ImageListHandle := SHGetFileInfo('C:/',
0,
FileInfo,
SizeOf(FileInfo), //得到大图标
SHGFI_SYSICONINDEX or SHGFI_LARGEICON);

SendMessage(ListView.Handle, LVM_SETIMAGELIST, LVSIL_NORMAL, ImageListHandle);

OLECheck(
SHGetSpecialFolderLocation( //由PIDL获得特色文件夹的相应文件路径
Application.Handle, //所有者的窗口句柄
CSIDL_DRIVES, //程序启动时所指文件夹
NewPIDL) //NewPIDL: PItemIDList;
); //指向项目标识符位置的文件夹位置
SetPath(NewPIDL);
ActiveControl := cbPath; //焦点控件
cbPath.SelStart := 0;
cbPath.SelStart := Length(cbPath.Text); //光标在文本处的位置
end;

procedure TForm1.btnBrowseClick(Sender: TObject);
var
S: string;
begin
S := '';
if SelectDirectory('Select Directory', '', S) then
SetPath(S);
end;

procedure TForm1.cbPathKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_RETURN then
begin
if cbPath.Text[Length(cbPath.Text)] = ':' then
cbPath.Text := cbPath.Text + '/';
SetPath(cbPath.Text);
Key := 0;
end;
end;

procedure TForm1.cbPathClick(Sender: TObject);
var
I: Integer;
begin
I := cbPath.Items.IndexOf(cbPath.Text);
if I >= 0 then
SetPath(PItemIDList(cbPath.Items.Objects))
else
SetPath(cbPath.Text);
end;

procedure TForm1.btnLargeIconsClick(Sender: TObject);
begin
ListView.ViewStyle := TViewStyle((Sender as TComponent).Tag);
end;

procedure TForm1.ListViewDblClick(Sender: TObject);
var
RootPIDL,
ID: PItemIDList; //包含一列项目标识符
begin
if ListView.Selected <> nil then
begin
ID := ShellItem(ListView.Selected.Index).ID;
//显示鼠标当前选中位置
if not IsFolder(FIShellFolder, ID) then Exit;
RootPIDL := ConcatPIDLs(FPIDL, ID); { var }
SetPath(RootPIDL); { IDList: TList; }
end; { S: string; }
end; { begin }
{ IDList := TList.Create; }
function TForm1.ShellItem(Index: Integer): PShellItem; { IDList.Add(PChar('aa')); }
begin { S := PChar(IDList[0]); }
Result := PShellItem(FIDList[Index]); { ShowMessage(S); }
end; //FIDList: TList { end; }
//返回所在的字符串
procedure TForm1.ListViewKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_RETURN:
ListViewDblClick(Sender);
VK_BACK:
btnBackClick(Sender);
end;
end;

//SHELL-RELATED ROUTINES.

procedure TForm1.ClearIDList;
var
I: Integer;
begin
for I := 0 to FIDList.Count-1 do //FIDList := TList.Create;
begin
DisposePIDL(ShellItem(I).ID); //如果为nil则Exit,返之获得IMalloc接口实例
Dispose(ShellItem(I)); //释放
end;
FIDList.Clear;
end;

procedure TForm1.PopulateIDList(ShellFolder: IShellFolder);
const
Flags = SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN;
var
ID: PItemIDList;
EnumList: IEnumIDList;
NumIDs: LongWord;
SaveCursor: TCursor;
ShellItem: PShellItem;
begin
SaveCursor := Screen.Cursor;
try
Screen.Cursor := crHourglass;
OleCheck( //列举物体在文件夹
ShellFolder.EnumObjects( //调用所获得的IShellFolder接口的EnumObjects成员函数列举出子文件夹
Application.Handle, //是属主窗口的句柄
Flags,
EnumList) //地址接受那个返回的一个指针
); //到IEnumIDList接口创造通过的方法

FIShellFolder := ShellFolder; //?
ClearIDList;
while EnumList.Next(1, ID, NumIDs) = S_OK do
begin
ShellItem := New(PShellItem); //产生新的动态变数和组合 P 指出到它
ShellItem.ID := ID;
ShellItem.DisplayName := GetDisplayName(FIShellFolder, ID, False);
ShellItem.Empty := True; //显示图标用的参数
FIDList.Add(ShellItem);
end;

FIDList.Sort(ListSortFunc); //好像是列表分类排列

//We need to tell the ListView how many items it has.
ListView.Items.Count := FIDList.Count;

ListView.Repaint; //重画全部的控制
finally
Screen.Cursor := SaveCursor;
end;
end;

procedure TForm1.SetPath(const Value: string);
var
P: PWideChar; {如果要获得文件系统的路径,得先获得 }
NewPIDL: PItemIDList; {IShellFolder接口,然后把要转化的路 }
Flags, {径名转化为PWideChar 类型的以null结 }
NumChars: LongWord; {尾的UNICODE字符串，然后作为参数调 }
begin {用桌面的IShellFolder接口的ParseDisplayName }
NumChars := Length(Value); {方法才能获得PIDL }
Flags := 0; //文件的属性
P := StringToOleStr(Value);

OLECheck(
FIDesktopFolder.ParseDisplayName( //文件名到项目标识符(PIDL)
Application.Handle,
nil,
P,
NumChars,
NewPIDL,
Flags)
);
SetPath(NewPIDL);
end;

procedure TForm1.SetPath(ID: PItemIDList);
var
Index: Integer;
NewShellFolder: IShellFolder;
begin
//调用IShellFolder的BindToObject成员函数获得子文件夹的IShellFolder接口
OLECheck(
FIDesktopFolder.BindToObject(
ID, //识别子文件夹相对于父文件夹
nil,
IID_IShellFolder, //归还接口，该处一定要指向该参数
Pointer(NewShellFolder)) //地址收到的接口指针
);

ListView.Items.BeginUpdate; //屏幕重画
try
PopulateIDList(NewShellFolder);
FPIDL := ID;
FPath := GetDisplayName(FIDesktopFolder, FPIDL, True);
Index := cbPath.Items.IndexOf(FPath); //返回字符串在列表中的位置
if (Index < 0) then
begin
cbPath.Items.InsertObject(0, FPath, Pointer(FPIDL));//插入字符串到该位置,并与对象发生连接
cbPath.Text := cbPath.Items[0];
end
else begin
cbPath.ItemIndex := Index;
cbPath.Text := cbPath.Items[cbPath.ItemIndex];
end;

if ListView.Items.Count > 0 then //如果listview里面项目大于2,则焦点放在第1项
begin
ListView.Selected := ListView.Items[0];
ListView.Selected.Focused := True;
ListView.Selected.MakeVisible(False);
end;
finally
ListView.Items.EndUpdate; //关掉BeginUpdate屏幕重画
end;
end;

//ROUTINES FOR MANAGING VIRTUAL DATA

procedure TForm1.CheckShellItems(StartIndex, EndIndex: Integer);

function ValidFileTime(FileTime: TFileTime): Boolean;
begin
Result := (FileTime.dwLowDateTime <> 0) or (FileTime.dwHighDateTime <> 0);
end;

var
FileData: TWin32FindData;
FileInfo: TSHFileInfo;
SysTime: TSystemTime;
I: Integer;
LocalFileTime: TFILETIME;
begin
//Here all the data that wasn't initialized in PopulateIDList is
//filled in.
for I := StartIndex to EndIndex do
begin
if ShellItem(I)^.Empty then
with ShellItem(I)^ do
begin
FullID := ConcatPIDLs(FPIDL, ID);
ImageIndex := GetShellImage(FullID, ListView.ViewStyle = vsIcon, False);

//File Type
SHGetFileInfo(
PChar(FullID),
0,
FileInfo,
SizeOf(FileInfo),
SHGFI_TYPENAME or SHGFI_PIDL
);
TypeName := FileInfo.szTypeName;

//Get File info from Windows
FillChar(FileData, SizeOf(FileData), #0);
SHGetDataFromIDList(
FIShellFolder,
ID,
SHGDFIL_FINDDATA,
@FileData,
SizeOf(FileData)
);

//File Size, in KB
Size := (FileData.nFileSizeLow + 1023 ) div 1024;
if Size = 0 then Size := 1;

//Modified Date
FillChar(LocalFileTime, SizeOf(TFileTime), #0);
with FileData do
if ValidFileTime(ftLastWriteTime)
and FileTimeToLocalFileTime(ftLastWriteTime, LocalFileTime)
and FileTimeToSystemTime(LocalFileTime, SysTime) then
try
ModDate := DateTimeToStr(SystemTimeToDateTime(SysTime))
except
on EConvertError do ModDate := '';
end
else
ModDate := '';

//Attributes
Attributes := FileData.dwFileAttributes;

//Flag this record as complete.
Empty := False;
end;
end;
end;

procedure TForm1.ListViewDataHint(Sender: TObject; StartIndex,
EndIndex: Integer);
begin
//OnDataHint is called before OnData. This gives you a chance to
//initialize only the data structures that need to be drawn.
//You should keep track of which items have been initialized so no
//extra work is done.
if (StartIndex > FIDList.Count) or (EndIndex > FIDList.Count) then Exit;
CheckShellItems(StartIndex, EndIndex);
end;

procedure TForm1.ListViewData(Sender: TObject; Item: TListItem);
var
Attrs: string;
begin
//OnData gets called once for each item for which the ListView needs
//data. If the ListView is in Report View, be sure to add the subitems.
//Item is a "dummy" item whose only valid data is it's index which
//is used to index into the underlying data.
if (Item.Index > FIDList.Count) then Exit;
with ShellItem(Item.Index)^ do
begin
Item.Caption := DisplayName;
Item.ImageIndex := ImageIndex;

if ListView.ViewStyle <> vsReport then Exit;

if not IsFolder(FIShellFolder, ID) then
Item.SubItems.Add(Format('%dKB', [Size]))
else
Item.SubItems.Add('');
Item.SubItems.Add(TypeName);
try
Item.SubItems.Add(ModDate);
except
end;

if Bool(Attributes and FILE_ATTRIBUTE_READONLY) then Attrs := Attrs + 'R';
if Bool(Attributes and FILE_ATTRIBUTE_HIDDEN) then Attrs := Attrs + 'H';
if Bool(Attributes and FILE_ATTRIBUTE_SYSTEM) then Attrs := Attrs + 'S';
if Bool(Attributes and FILE_ATTRIBUTE_ARCHIVE) then Attrs := Attrs + 'A';
end;
Item.SubItems.Add(Attrs);
end;

procedure TForm1.ListViewDataFind(Sender: TObject; Find: TItemFind;
const FindString: String; const FindPosition: TPoint; FindData: Pointer;
StartIndex: Integer; Direction: TSearchDirection; Wrap: Boolean;
var Index: Integer);
//OnDataFind gets called in response to calls to FindCaption, FindData,
//GetNearestItem, etc. It also gets called for each keystroke sent to the
//ListView (for incremental searching)
var
I: Integer;
Found: Boolean;
begin
I := StartIndex;
if (Find = ifExactString) or (Find = ifPartialString) then
begin
repeat
if (I = FIDList.Count-1) then
if Wrap then I := 0 else Exit;
Found := Pos(UpperCase(FindString), UpperCase(ShellItem(I)^.DisplayName)) = 1;
Inc(I);
until Found or (I = StartIndex);
if Found then Index := I-1;
end;
end;

procedure TForm1.ListViewCustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
var
Attrs: Integer;
begin
if Item = nil then Exit;
Attrs := ShellItem(Item.Index).Attributes;
if Bool(Attrs and FILE_ATTRIBUTE_READONLY) then
ListView.Canvas.Font.Color := clGrayText;
if Bool(Attrs and FILE_ATTRIBUTE_HIDDEN) then
ListView.Canvas.Font.Style :=
ListView.Canvas.Font.Style + [fsStrikeOut];
if Bool(Attrs and FILE_ATTRIBUTE_SYSTEM) then
Listview.Canvas.Font.Color := clHighlight;
end;

procedure TForm1.ListViewCustomDrawSubItem(Sender: TCustomListView;
Item: TListItem; SubItem: Integer; State: TCustomDrawState;
var DefaultDraw: Boolean);
begin
if SubItem = 0 then Exit;
ListView.Canvas.Font.Color := GetSysColor(COLOR_WINDOWTEXT);
//workaround for Win98 bug.
end;

procedure TForm1.btnBackClick(Sender: TObject);
var
Temp: PItemIDList;
begin
Temp := CopyPIDL(FPIDL);
if Assigned(Temp) then
StripLastID(Temp);
if Temp.mkid.cb <> 0 then
SetPath(Temp)
else
Beep;
end;

procedure TForm1.Form1Close(Sender: TObject; var Action: TCloseAction);
begin
ClearIDList;
FIDList.Free;
end;

end.
 
里面有我的部分注释。。不知道对不对。。。

请大家帮我把余下的部分注一下。。。

谢谢！
 
怎么没有人帮我把部分代码注释一下呢？
 
自己查资料吧，就是多，没什么难度
 
您必须登录或注册才可回复。

Similar threads

新
您好，线程怎么用信号量同步 ？ 以下代码不行......谢谢 (50分)
2
回复
29
查看
427
新的自我
新
C
如何释放内存,源码已贴出。 (100分)
回复
18
查看
219
chinesetree
C
L
如何判断进程有无响应的方法(经验共享),我的答案!(0分)
回复
3
查看
158
LiChaoHui
L
J
为什么我删除不了进程呢？看看下面的代码(100分)
回复
8
查看
196
jadesun
J
P
为何这里　DisPose 出错 ？谢谢(20分)
回复
5
查看
155
pcgod
P
后退
顶部