28 Апрель 2011

Компилятор: Borland Delphi 7

Операционная система: Windows XP

Текст файла Project1.dpr

program Project1;

uses
Forms,
Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.


Текст файла Unit1.pas

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
OpenDialog1: TOpenDialog;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Edit1Change(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
protected
procedure WndProc(var Msg: TMessage); override;
private
public
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

uses ShlObj, ActiveX;

var
ICM2: IContextMenu2;
DesktopFolder: IShellFolder;
Malloc: IMalloc;

procedure TForm1.FormCreate(Sender: TObject);
begin
OleInitialize(nil);
SHGetDesktopFolder(DesktopFolder);
SHGetMalloc(Malloc)
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
OleUninitialize
end;

procedure TForm1.WndProc(var Msg: TMessage);
begin
with Msg do
if ((Msg=WM_INITMENUPOPUP) or (Msg=WM_DRAWITEM) or (Msg=WM_MENUCHAR)
or (Msg=WM_MEASUREITEM)) and Assigned(ICM2) then
begin
ICM2.HandleMenuMsg(Msg,wParam,lParam);
Result:=0
end;
inherited
end;

procedure ShowICM(Handle: hWnd; X,Y: integer; FileName: string);
var
Command: LongBool;
ICmd: integer;
P: TPoint;
pchEaten,dwAttributes: cardinal;
ItemIDList: PItemIDList;
ShellFolder: IShellFolder;
Menu: HMenu;
ICM: IContextMenu;
ICI: TCMInvokeCommandInfo;
begin
DesktopFolder.ParseDisplayName(Handle,nil,
StringToOleStr(ExtractFileDir(FileName)),pchEaten,ItemIDList,dwAttributes);
DesktopFolder.BindToObject(ItemIDList,nil,IID_IShellFolder,ShellFolder);
if ShellFolder=nil then ShellFolder:=DesktopFolder;
ShellFolder.ParseDisplayName(Handle,nil,
StringToOleStr(ExtractFileName(FileName)),pchEaten,ItemIDList,dwAttributes);
if ItemIDList=nil then
ShellFolder.ParseDisplayName(Handle,nil,
StringToOleStr(FileName),pchEaten,ItemIDList,dwAttributes);
if ItemIDList=nil then ShellFolder.CreateViewObject(Handle,IID_IContextMenu,ICM)
else ShellFolder.GetUIObjectOf(Handle,1,ItemIDList,IID_IContextMenu,nil,ICM);
if ItemIDList<>nil then Malloc.Free(ItemIDList);
if ICM=nil then Exit;
P.X:=X; P.Y:=Y;
Windows.ClientToScreen(Handle,P);
Menu:=CreatePopupMenu;
try
ICM.QueryContextMenu(Menu,0,1,$7FFF,CMF_EXPLORE);
ICM.QueryInterface(IID_IContextMenu2,ICM2);
try
Command:=TrackPopupMenu(Menu,TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD,P.X,P.Y,0,Handle,nil);
finally
ICM2:=nil
end;
if Command then
begin
ICmd:=Longint(Command)-1;
FillChar(ICI,SizeOf(ICI),#0);
with ICI do
begin
ICI.cbSize:=SizeOf(ICI);
ICI.hwnd:=Handle;
ICI.lpVerb:=MakeIntResource(ICmd);
ICI.nShow:=SW_SHOWNORMAL
end;
ICM.InvokeCommand(ICI)
end
finally
DestroyMenu(Menu)
end
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then Edit1.Text:=OpenDialog1.FileName
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button2.Enabled then ShowICM(Handle,X,Y,Edit1.Text)
end;

procedure TForm1.Edit1Change(Sender: TObject);
begin
Button2.Enabled:=FileExists(Edit1.Text) or DirectoryExists(Edit1.Text)
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowICM(Handle,Edit1.Top,Edit1.Left,Edit1.Text)
end;

end.


Текст файла Uni1.dfm

object Form1: TForm1
Left = 191
Top = 114
Width = 640
Height = 91
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
OnMouseUp = FormMouseUp
PixelsPerInch = 96
TextHeight = 13
object Edit1: TEdit
Left = 4
Top = 4
Width = 625
Height = 21
TabOrder = 0
OnChange = Edit1Change
end
object Button1: TButton
Left = 4
Top = 28
Width = 75
Height = 25
Caption = #1060#1072#1081#1083
TabOrder = 1
OnClick = Button1Click
end
object Button2: TButton
Left = 80
Top = 28
Width = 75
Height = 25
Caption = #1052#1077#1085#1102
Enabled = False
TabOrder = 2
OnClick = Button2Click
end
object OpenDialog1: TOpenDialog
Left = 600
Top = 28
end
end


загрузка файла: icm_icm2.exe (SFX-архив)

размер: 50 КБ