Duplicate the string sorting of the Windows XP Explorer

Problem/Question/Abstract:

I've noticed a change in Explorer's sorting algorithm. Under Windows 2000, one would see files sorted by name this way: A100, A20, A3, B100, B20, B3. Under Windows XP, one would see the same files sorted by name this way: A3, A20, A100, B3, B20, B100. Does anyone know of a string sort-compare function that uses this new sorting algorithm? I would prefer to not rely on an API call that doesn't exist in prior versions of Windows.

Answer:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
Edit1: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

type
TFolderContent = (
fcFiles, {Include all Files}
fcFolders, {Include all Folders}
fcHidden {Include all hidden objects}
);
TFolderContents = set of TFolderContent;
TFileResult = (
FileName, {Return a list of filenames}
Path {Return a list of complete file paths}
);

const
AllFolderContent = [fcFiles, fcFolders, fcHidden];

var
Form1: TForm1;

implementation

uses
ShellAPI, ShlObj, ActiveX;

{$R *.dfm}

var
SortFolder: IShellFolder;
SortColumn: Integer;

function ShellCompare(Item1, Item2: Pointer): Integer;
begin
Result := 0;
if Assigned(SortFolder) then
Result := ShortInt(SortFolder.CompareIDs(SortColumn, Item1, Item2));
end;

function PathToPIDL(APath: WideString): PItemIDList;
{Takes the passed Path and attempts to convert it to the equavalent PIDL}
var
Desktop: IShellFolder;
pchEaten, dwAttributes: ULONG;
begin
Result := nil;
SHGetDesktopFolder(Desktop);
dwAttributes := 0;
if Assigned(Desktop) then
Desktop.ParseDisplayName(0, nil, PWideChar(APath), pchEaten, Result,
dwAttributes);
end;

function StrRetToStr(StrRet: TStrRet; APIDL: PItemIDList; const Malloc: IMalloc):
WideString;
{Extracts the string from the StrRet structure}
var
P: PChar;
{S: string;}
begin
case StrRet.uType of
STRRET_CSTR:
begin
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
{Result := S}
end;
STRRET_OFFSET:
begin
if Assigned(APIDL) then
begin
{$R-}
P := PChar(@(APIDL).mkid.abID[StrRet.uOffset - SizeOf(APIDL.mkid.cb)]);
{$R+}
SetString(Result, P, StrLen(P));
{Result := S;}
end
else
Result := '';
end;
STRRET_WSTR:
begin
Result := StrRet.pOleStr;
if Assigned(StrRet.pOleStr) then
Malloc.Free(StrRet.pOLEStr);
end;
end;
end;

function GetDirectoryFolder(Directory: WideString): IShellFolder;
var
Desktop: IShellFolder;
pchEaten, dwAttributes: ULONG;
PIDL: PItemIDList;
begin
SHGetDesktopFolder(Desktop);
if Assigned(Desktop) then
begin
PIDL := nil;
Desktop.ParseDisplayName(0, nil, PWideChar(Directory), pchEaten, PIDL,
dwAttributes);
if Assigned(PIDL) then
begin
Desktop.BindToObject(PIDL, nil, IShellFolder, Result);
CoTaskMemFree(PIDL);
end;
end;
end;

procedure EnumFolder(Folder: IShellFolder; Contents: TFolderContents; PIDLList:
TList);
var
Flags: Longword;
EnumList: IEnumIDList;
Fetched: ULONG;
PIDL: PItemIDList;
begin
Flags := 0;
if fcFiles in Contents then
Flags := Flags or SHCONTF_NONFOLDERS;
if fcFolders in Contents then
Flags := Flags or SHCONTF_FOLDERS;
if fcHidden in Contents then
Flags := Flags or SHCONTF_INCLUDEHIDDEN;
Folder.EnumObjects(0, Flags, EnumList);
if Assigned(EnumList) then
begin
while EnumList.Next(1, PIDL, Fetched) <> S_FALSE do
PIDLList.Add(PIDL);
end;
end;

procedure GetDirectoryContents(Directory: WideString; Contents: TFolderContents;
FileResult: TFileResult; SortOnColumn: Integer; FileList: TStringList);
{Parameters:
Directory: Path of the directory to get the contents of
Contents:  What type of objects on the folder to include
FileResult: Return only the file names or the complete path for each file
SortOnColumn: What column (in Explorer report view) to sort the item on, 0 is the name
FileList:  The resulting file list user allocated}
var
Folder: IShellFolder;
PIDLList: TList;
i: Integer;
Malloc: IMalloc;
Flags: Longword;
StrRet: TStrRet;
begin
Assert(Assigned(FileList),
'User must allocate the FileString List in GetDirectoryContents');
Folder := GetDirectoryFolder(Directory);
if Assigned(Folder) then
begin
SHGetMalloc(Malloc);
PIDLList := TList.Create;
try
EnumFolder(Folder, Contents, PIDLList);
SortFolder := Folder;
SortColumn := SortOnColumn;
PIDLList.Sort(ShellCompare);
{Release the count on the interface}
SortFolder := nil;
FileList.Capacity := PIDLList.Count;
if FileResult = FileName then
Flags := SHGDN_NORMAL
else
Flags := SHGDN_FORPARSING;
for i := 0 to PIDLList.Count - 1 do
begin
FillChar(StrRet, SizeOf(StrRet), #0);
if Folder.GetDisplayNameOf(PIDLList[i], Flags, StrRet) = NOERROR then
FileList.Add(StrRetToStr(StrRet, PIDLList[i], Malloc));
end;
finally
for i := 0 to PIDLList.Count - 1 do
Malloc.Free(PIDLList[i]);
PIDLList.Free;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Files: TStringList;
begin
Files := TStringList.Create;
GetDirectoryContents(Edit1.Text, AllFolderContent, Path, 0, Files);
ListBox1.Items.Assign(Files);
Files.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Label1.Caption := 'Enter a Directory';
Edit1.Text := 'c:\';
end;

end.