I have just writen some code which uses the ShellObj and ShellUtl units
- download from (http://ourworld.compuserve.com/homepages/PRitchey/delphipg.htm)
to implement a "Send To" menu like the MS office products. Unfortunately I have been unable
to extract the icons from a Shortcut with any degree of success. The following code does it,
but the icons come out looking rather poor. Any Ideas ?
Matthew Holmes
---
type
TSHFileInfo = record
hIcon : HICON;
iIcon : integer;
dwAttributes : DWORD;
szDisplayName : array [1..MAX_PATH] of Char;
szTypeName : array[1..80] of Char;
end;
PTSHFileInfo = ^TSHFileInfo;
const
NO_TILES = 18;
sUntitled = 'Untitled.MAP';
SHGFI_ICON = $000000100; // get icon
SHGFI_DISPLAYNAME = $000000200; // get display name
SHGFI_TYPENAME = $000000400; // get type name
SHGFI_ATTRIBUTES = $000000800; // get attributes
SHGFI_ICONLOCATION = $000001000; // get icon location
SHGFI_EXETYPE = $000002000; // return exe type
SHGFI_SYSICONINDEX = $000004000; // get system icon index
SHGFI_LINKOVERLAY = $000008000; // put a link overlay on icon
SHGFI_SELECTED = $000010000; // show icon in selected state
SHGFI_LARGEICON = $000000000; // get large icon
SHGFI_SMALLICON = $000000001; // get small icon
SHGFI_OPENICON = $000000002; // get open icon
SHGFI_SHELLICONSIZE = $000000004; // get shell size icon
SHGFI_PIDL = $000000008; // pszPath is a pidl
SHGFI_USEFILEATTRIBUTES = $000000010; // use passed dwFileAttribute
function SHGetFileInfo(szPath : PChar;FileAttr : DWORD; pSHFI : PTSHFileInfo;
cbSHFI,uFlags :integer ) : integer; stdcall;
external 'SHELL32.DLL' name 'SHGetFileInfoA';
function ExtractIconA(hInst : LongInt;szExeName : PChar;nIconIndex : UINT)
: HICON; stdcall; external 'Shell32.DLL';
procedure TForm1.BuildSendToMenu;
var
I,J,nSavedDC : integer;
miTemp : TMenuItem;
hres : HResult;
iidSendTo : PITEMIDLIST;
szPath : Array [0..MAX_PATH] of Char;
sName : string;
SearchRec : TSearchRec;
SHFI : TSHFILEINFO;
pSHFI : PTSHFileInfo;
hbmIcon : HBITMAP;
hdcMem : HDC;
hbr : HBRUSH;
hIcon : HICON;
il : integer;
begin
{build the Send To Menu}
hres := SHGetSpecialFolderLocation(Handle,CSIDL_SENDTO,iidSendTo);
hbr := CreateSolidBrush(GetSysColor(COLOR_MENU));
ssSendTo := TStringList.Create;
if (SHGetPathFromIDList(iidSendTo, szPath)) then
begin
I := FindFirst(szPath + '\*.LNK',faAnyFile,SearchRec);
J := 0;
while (I = 0) do
begin
sName := StrPas(szPath) + '\' + SearchRec.Name;
miTemp := TMenuItem.Create(FileSendTo);
miTemp.Caption := ChangeFileExt(ExtractFileName(sName),'');
miTemp.Tag := J;
miTemp.OnClick := EvSendToClick;
miTemp.Visible := True;
FileSendTo.Add(miTemp);
{ Now create the icon bitmap }
pSHFI := @SHFI;
SHGetFileInfo(PChar(sName),0,pSHFI,sizeof(TSHFileInfo),
SHGFI_ICONLOCATION);
hIcon := ExtractIconA(hInstance,@(SHFI.szDisplayName[1]),SHFI.iIcon);
if (hIcon <> 0) then
begin
hbmIcon := CreateCompatibleBitmap(Canvas.Handle,16,16);
hdcMem := CreateCompatibleDC(Canvas.Handle);
nSavedDC := SaveDC(hdcMem);
SelectObject(hdcMem,hbmIcon);
SelectObject(hdcMem,GetStockObject(NULL_PEN));
SelectObject(hdcMem,hbr);
Rectangle(hdcMem,0,0,16,16);
DrawIconEx(hdcMem,0,0,hIcon,16,16,0,hbr,0);
DestroyIcon(hIcon);
RestoreDC(hdcMem,nSavedDC);
DeleteDC(hdcMem);
ssSendTo.AddObject(ResolveIt(Handle,PChar(sName)),Pointer(hbmIcon));
end;
INC(J);
I := FindNext(SearchRec);
end;
for J := 0 to ssSendTo.Count - 1 do
SetMenuItemBitmaps(FileSendTo.Handle,J,MF_BYPOSITION,
HBITMAP(ssSendTo.Objects[J]),HBITMAP(ssSendTo.Objects[J]));
FileSendTo.Enabled := True;
end;
DeleteObject(hbr);
end;