ShIvADeSt
Moderator | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Код:
unit WarpDesk;
interface
uses Windows,ActiveX,ShlObj,ShellApi,SysUtils,Messages,Classes,WarpMenu;
procedure InitWarpDesktop(hWnd : THandle);
procedure DoneWarpDesktop(hWnd : THandle);
procedure ExecMenu(hWnd : THandle; Menu : HMenu);
procedure ExecMenuEx(hWnd : THandle; Menu : HMenu; Pos : TPoint; Flags : integer);
procedure PopupDesktop(hWnd : THandle; Mouse : boolean);
procedure HandleDeskMenu(hWnd : THandle; wParam,lParam : integer);
procedure InitDeskMenu;
procedure DoneDeskMenu;
procedure DrawDeskMenuItem(p : PDrawItemStruct);
procedure MeasureDeskMenuItem(p : PMeasureItemStruct);
procedure RefreshMenu(IconMode : integer);
const
siNoIcons = 0;
siSmallIcons= 1;
siLargeIcons= 2;
ShowIcons : integer = siLargeIcons;
NotifyObj : THandle = 0;
sfTrashCan = 0;
sfNetwork = 1;
sfControls = 2;
SkipFoldSet : set of sfTrashCan..sfControls = [sfTrashCan..sfControls];
implementation
type
TMenu = class;
TMenuItem = class
Owner : TMenu;
PIdl,GPidl : PItemIDList;
Title : string;
hLargeIcon,hSmallIcon : HIcon;
constructor Create(Master : TMenu; Idl,GIdl : PItemIDList; const ItemName : string);
destructor Destroy; override;
procedure Execute(hWnd : THandle);
procedure Draw(Ctx : PDrawItemStruct); virtual;
end;
TMenu = class(TMenuItem)
Handle : HMENU;
Items : TList;
Folder : IShellFolder;
constructor Create(Master : TMenu; Idl,GIdl : PItemIDList; const ItemName : string; ShellLink : IShellFolder);
constructor CreateRoot(Idl : PItemIDList; ShellLink : IShellFolder);
destructor Destroy; override;
function MakeItem(pidl,GIdl : PItemIDList) : boolean;
function MakeSubMenu(pidl,GIdl : PItemIDList; ShellLink : IShellFolder) : boolean;
procedure AddMenu(Src : TMenuItem; Sub : boolean);
procedure BuildMenu;
end;
var
pMalloc : IMalloc;
DeskItems : TList;
DeskRoot : TMenu;
CtxMnu : IContextMenu;
SkipFolders : array[sfTrashCan..sfControls] of record
pidl : PItemIDList;
csidl : integer;
end = ( (csidl : CSIDL_BITBUCKET),
(csidl : CSIDL_NETWORK ),
(csidl : CSIDL_CONTROLS ) );
ItemHeight : array[siNoIcons..siLargeIcons] of integer = (19, 19, 35);
MenuHeight : integer;
ScreenWidth : integer;
Metrics : TNonClientMetrics = (cbSize : sizeof(Metrics));
LastCtxOrg : TPoint;
function GetDisplayName(Folder : IShellFolder; pidl : PItemIDList) : string;
var Value : TStrRet;
begin
Folder.GetDisplayNameOf( PIdl, SHGDN_INFOLDER, Value );
with Value do case uType of
STRRET_CSTR : Result := pchar(@cStr[0]);
STRRET_WSTR :
begin
Result := pOleStr;
pMalloc.Free( pOleStr );
end;
STRRET_OFFSET : Result := pchar( dword(pidl) + uOffset );
end;
end;
function GetIdlSize(Idl : PItemIdList) : integer;
begin
result := Idl.mkid.cb;
if result = 0 then exit;
inc(result, GetIdlSize(PItemIdList(integer(Idl)+result)));
end;
function IdlCopy(Idl : PItemIdList) : PItemIdList;
var L : integer;
begin
L := GetIdlSize(Idl)+2;
result := pMalloc.Alloc(L);
move(Idl.mkid, Result.mkid, L);
end;
function IdlCat(GIdl, LIdl : PItemIdList) : PItemIdList;
var L1,L2 : integer;
begin
L1 := GetIdlSize(GIdl);
L2 := GetIdlSize(LIdl)+2;
result := pMalloc.Alloc(L1+L2);
move(GIdl.mkid, Result.mkid, L1);
move(LIdl.mkid, PItemIdList(integer(Result)+L1).mkid, L2);
end;
function IsEqualIdl(p1,p2 : PItemIDList) : boolean;
var i,l : integer;
begin
result := false;
L := p1.mkid.cb;
if L <> p2.mkid.cb then exit;
if L <> 0 then
begin
for i := 0 to L-3 do
if p1.mkid.abID[i] <> p2.mkid.abID[i] then exit;
inc(integer(p1), l);
inc(integer(p2), l);
result := IsEqualIdl(p1, p2);
end
else result := true;
end;
function IsSkipFolder(p : PItemIDList) : boolean;
var i : integer;
begin
result := true;
for i := 0 to high(SkipFolders) do
if (i in SkipFoldSet) and IsEqualIdl(SkipFolders[i].pidl, p) then exit;
result := false;
end;
constructor TMenuItem.Create(Master : TMenu; Idl,GIdl : PItemIDList; const ItemName : string);
var FI : TSHFileInfo;
begin
Owner := Master;
PIdl := Idl;
GPidl := GIdl;
Title := ItemName;
fillchar(fi, sizeof(fi), 0);
SHGetFileInfo(pchar(GIdl), 0, fi, sizeof(fi), SHGFI_PIDL or SHGFI_ICON or SHGFI_LARGEICON);
HLargeIcon := FI.hIcon;
SHGetFileInfo(pchar(GIdl), 0, fi, sizeof(fi), SHGFI_PIDL or SHGFI_ICON or SHGFI_SMALLICON);
HSmallIcon := FI.hIcon;
end;
destructor TMenuItem.Destroy;
begin
pMalloc.Free(GPIdl);
pMalloc.Free(PIdl);
inherited;
end;
procedure TMenuItem.Execute(hWnd : THandle);
procedure RunContext;
var ItemPopup : HMENU;
begin
ItemPopup := CreatePopupMenu;
CtxMnu.QueryContextMenu(ItemPopup, 0, ID_CONTEXT_FIRST, ID_CONTEXT_LAST, CMF_DEFAULTONLY);
ExecMenuEx(hWnd, ItemPopup, LastCtxOrg, TPM_CENTERALIGN);
DestroyMenu(ItemPopup);
end;
procedure RunDefault(Invoke : boolean);
var EI : TShellExecuteInfo;
begin
fillchar(ei, sizeof(ei), 0);
ei.cbSize := sizeof(ei);
ei.wnd := hWnd;
ei.nShow := SW_SHOW;
if Invoke then ei.fMask := SEE_MASK_INVOKEIDLIST
else ei.fMask := SEE_MASK_IDLIST;
ei.lpIdList := Gpidl;
ShellExecuteEx(@ei);
end;
begin
CtxMnu := nil;
if Owner = nil then RunDefault(false)
else if ((GetAsyncKeyState(VK_RBUTTON) <> 0) or
(GetAsyncKeyState(VK_CONTROL) <> 0)) and Succeeded(
Owner.Folder.GetUIObjectOf(0, 1, pidl, IID_IContextMenu, nil,
pointer(CtxMnu))) then
RunContext
else RunDefault(true);
end;
procedure TMenuItem.Draw(Ctx : PDrawItemStruct);
var IconSize : integer; IconHandle : HICON;
begin
IconHandle := HLargeIcon;
case ShowIcons of
siSmallIcons :
begin
IconSize := 16;
if HSmallIcon <> 0 then IconHandle := HSmallIcon;
end;
siLargeIcons : IconSize := 32;
else IconSize := 0;
end;
with Ctx^, rcItem do
begin
if itemAction = ODA_SELECT then
begin
DeleteObject(SelectObject(hdc, CreatePen(PS_NULL, 0, 0)));
if (itemState and ODS_SELECTED) <> 0 then
begin
SetTextColor(HDC, GetSysColor(COLOR_HIGHLIGHTTEXT));
SetBkColor(HDC, GetSysColor(COLOR_HIGHLIGHT));
DeleteObject(SelectObject(hdc, GetSysColorBrush(COLOR_HIGHLIGHT)));
end
else DeleteObject(SelectObject(hdc, GetSysColorBrush(COLOR_MENU)));
Rectangle(HDC, Left, Top, Right, Bottom);
if itemState = ODS_SELECTED then
begin
LastCtxOrg := point((Left+Right) div 2, Top);
ClientToScreen(WindowFromDC(HDC), LastCtxOrg);
end;
end;
inc(Left, 4);
DrawIconEx(HDC, Left, Top+1, IconHandle, IconSize, IconSize, 0, 0, DI_COMPAT or DI_NORMAL);
inc(Left, 4+IconSize);
DrawText(HDC, pchar(Title), length(Title), rcItem, DT_SINGLELINE or DT_VCENTER or DT_LEFT);
end;
end;
constructor TMenu.CreateRoot(Idl : PItemIDList; ShellLink : IShellFolder);
var S : string;
begin
S := GetDisplayName(ShellLink, Idl);
if S = '' then S := 'Root';
Create(nil, Idl, IdlCopy(Idl), S, ShellLink);
end;
constructor TMenu.Create(Master : TMenu; Idl,GIdl : PItemIDList; const ItemName : string; ShellLink : IShellFolder);
var
pidlChild,gpidlChild : PItemIDList;
Iterator : IEnumIDList;
celtFetched,Attr : cardinal;
Child : IShellFolder;
HR : HResult;
begin
Folder := ShellLink;
Items := TList.Create;
inherited Create(Master, Idl,GIdl, ItemName);
hr := Folder.EnumObjects( 0, SHCONTF_FOLDERS or SHCONTF_NONFOLDERS, Iterator );
if Succeeded( hr ) then
while Iterator.Next( 1, pidlChild, celtFetched ) = NOERROR do
begin
gpidlChild := IdlCat(GIdl, pidlChild);
if IsSkipFolder(gpidlChild) then MakeItem(pidlChild,gpidlChild)
else begin
Attr := $ffffffff;
hr := folder.GetAttributesOf(1, pidlChild, Attr);
if Succeeded( hr ) then
if ((Attr and $70000000 = $70000000) or not Succeeded(
Folder.BindToObject( pidlChild, nil, IID_IShellFolder,
pointer(Child) ))) then
MakeItem(pidlChild,gpidlChild)
else MakeSubMenu(pidlChild,gpidlChild, Child);
end;
end;
Iterator := nil;
if Owner = nil then exit;
end;
procedure TMenu.BuildMenu;
var i : integer; Item : TMenuItem;
begin
if Owner = nil then
begin
DestroyMenu(Handle);
DeskItems.Count := 0;
end;
Handle := CreatePopupMenu;
AddMenu(Self, false);
if Items.Count <> 0 then
begin
for i := 0 to Items.Count-1 do begin
Item := TMenuItem(Items[i]);
if not (Item is TMenu) then continue;
(Item as TMenu).BuildMenu;
end;
AppendMenu(Handle, MF_SEPARATOR, 0, nil);
for i := 0 to Items.Count-1 do begin
Item := TMenuItem(Items[i]);
if Item is TMenu then continue;
AddMenu(Item, false);
end;
end;
if Owner <> nil then AddMenu(Self, true);
end;
destructor TMenu.Destroy;
var i : integer;
begin
Folder := nil;
for i := 0 to Items.Count-1 do TMenuItem(Items[i]).Free;
DestroyMenu(Handle);
Items.Free;
inherited;
end;
procedure TMenu.AddMenu(Src : TMenuItem; Sub : boolean);
var Flags : integer;
Param : pchar;
begin
if ShowIcons = siNoIcons then
begin
Flags := MF_STRING;
Param := pchar(Src.Title);
end
else
begin
Flags := MF_OWNERDRAW;
Param := pchar(Src);
end;
if Sub then AppendMenu(Owner.Handle, Flags or MF_POPUP, Handle, Param)
else
begin
if (GetMenuItemCount(Handle)+1) mod (MenuHeight div ItemHeight[ShowIcons]) = 0 then
Flags := Flags or MF_MENUBARBREAK;
AppendMenu(Handle, Flags, DeskItems.Count, Param);
end;
DeskItems.Add(Src);
end;
function TMenu.MakeItem(pidl,GIdl : PItemIDList) : boolean;
var ItemName : string;
begin
ItemName := GetDisplayName(Folder, pidl);
result := ItemName <> '';
if not result then exit;
Items.Add(TMenuItem.Create(Self, pidl, GIdl, ItemName));
end;
function TMenu.MakeSubMenu(pidl,GIdl : PItemIDList; ShellLink : IShellFolder) : boolean;
var ItemName : string;
begin
ItemName := GetDisplayName(Folder, pidl);
result := ItemName <> '';
if result then
Items.Add(TMenu.Create(Self, pidl, GIdl, ItemName, ShellLink))
else ShellLink := nil;
end;
procedure ExecMenu(hWnd : THandle; Menu : HMenu);
var MousePos : TPoint;
begin
GetCursorPos(MousePos);
ExecMenuEx(hWnd, Menu, MousePos, TPM_RIGHTALIGN);
end;
procedure ExecMenuEx(hWnd : THandle; Menu : HMenu; Pos : TPoint; Flags : integer);
begin
SetForegroundWindow(hWnd);
TrackPopupMenu(Menu, flags or TPM_LEFTBUTTON or TPM_RIGHTBUTTON,
Pos.X, Pos.Y, 0, hWnd, nil);
PostMessage(hWnd, WM_USER, 0, 0);
end;
procedure PopupDesktop(hWnd : THandle; Mouse : boolean);
begin
// GetAsyncKeyState(VK_RBUTTON);
GetAsyncKeyState(VK_CONTROL);
if Mouse then ExecMenu(hWnd, DeskRoot.Handle)
else ExecMenuEx(hWnd, DeskRoot.Handle,
point(ScreenWidth div 2, MenuHeight), TPM_CENTERALIGN);
end;
procedure HandleDeskMenu(hWnd : THandle; wParam,lParam : integer);
var ci : TCMInvokeCommandInfo;
begin
case wParam of
ID_CONTEXT_FIRST..ID_CONTEXT_LAST :
begin
fillchar(ci, sizeof(ci), 0);
ci.cbSize := sizeof(ci);
ci.hwnd := hWnd;
ci.lpVerb := pchar(wParam-ID_CONTEXT_FIRST);
ci.nShow := SW_SHOW;
CtxMnu.InvokeCommand(ci);
CtxMnu := nil;
end;
else if wParam < DeskItems.Count then
TMenuItem(DeskItems[wParam]).Execute(hWnd);
end;
end;
var DC: HDC;
procedure InitWarpDesktop(hWnd : THandle);
begin
DC := GetWindowDC(hWnd);
InitDeskMenu;
end;
procedure DoneWarpDesktop(hWnd : THandle);
begin
ReleaseDC(hWnd, DC);
DoneDeskMenu;
end;
procedure InitDeskMenu;
var Desktop : IShellFolder;
pidlItself : PItemIDList;
begin
DoneDeskMenu;
SHGetDesktopFolder( Desktop );
SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, pidlItself);
DeskRoot := TMenu.CreateRoot(pidlItself, Desktop);
RefreshMenu(ShowIcons);
end;
procedure DoneDeskMenu;
begin
if DeskRoot = nil then exit;
DeskRoot.Free;
DeskRoot := nil;
DeskItems.Count := 0;
end;
procedure DrawDeskMenuItem(p : PDrawItemStruct);
begin
if p.CtlType <> ODT_MENU then exit;
TMenuItem(p.itemData).Draw(p);
end;
function TextWidth(const S : string) : integer;
var Size : TSize;
begin
if GetTextExtentPoint32(DC, pchar(s), length(s), Size) then
result := Size.cx
else result := length(s)*6;
end;
procedure MeasureDeskMenuItem(p : PMeasureItemStruct);
begin
if p.CtlType <> ODT_MENU then exit;
p.ItemHeight := ItemHeight[ShowIcons];
p.ItemWidth := ItemHeight[ShowIcons] +
TextWidth(TMenuItem(p.itemData).Title);
end;
procedure RefreshMenu(IconMode : integer);
begin
MenuHeight := GetSystemMetrics(SM_CYMAXIMIZED);
ScreenWidth := GetSystemMetrics(SM_CXSCREEN);
SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @Metrics, 0);
ItemHeight[siNoIcons] := Metrics.iMenuHeight;
if ItemHeight[siNoIcons] > 19 then
ItemHeight[siSmallIcons] := ItemHeight[siNoIcons]
else ItemHeight[siSmallIcons] := 19;
DeleteObject(SelectObject(DC, CreateFontIndirect(Metrics.lfMenuFont)));
ShowIcons := IconMode;
DeskRoot.BuildMenu;
end;
procedure InitialRoutine;
var i : integer;
Idl : PItemIdList;
DesktopLocation : array[0..MAX_PATH] of char;
begin
CoInitialize( nil );
SHGetMalloc( pMalloc );
SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, Idl);
SHGetPathFromIdList(Idl, DesktopLocation);
pMalloc.Free(Idl);
NotifyObj := FindFirstChangeNotification(DesktopLocation, longbool(1),
FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME);
DeskItems := TList.Create;
for i := 0 to high(SkipFolders) do with SkipFolders[i] do
SHGetSpecialFolderLocation(0, csidl, pidl);
end;
procedure FinalRoutine;
var i : integer;
begin
for i := 0 to high(SkipFolders) do pMalloc.Free(SkipFolders[i].pidl);
FindCloseChangeNotification(NotifyObj);
DeskItems.Free;
CtxMnu := nil;
pMalloc := nil;
CoUninitialize;
end;
initialization
InitialRoutine;
finalization
FinalRoutine;
end.
|
----------
И создал Бог женщину... Существо получилось злобное, но забавное... |
|
