用Delphi添加菜单条到桌面右键菜单中

Question

请教各位大侠,能不能用Delphi添加菜单条到桌面右键菜单中,望回复,急用谢谢! [email protected]

Answer 1

uses
  SysUtils,
  Windows,
  Classes, Messages;{$R *.res}
var
  hNextHook: HWND;procedure ShowMsg(Msg: string);
begin
  MessageBox(GetActiveWindow, Pchar(Msg), 'Info', MB_OK + MB_ICONINFORMATION);
end;function CallWndProc(nCode: integer; wParam: WPARAM; lParam: LPARAM): Longint; stdcall;
var
  Msg: PCWPStruct;
begin
  Msg := pointer(lParam);
  case Msg.message of
    WM_INITMENUPOPUP:
      begin
        InsertMenu(Msg.wParam, 0, MF_BYCOMMAND or MF_STRING, 100, 'Test');
      end;
    WM_MENUCOMMAND,WM_SYSCOMMAND:
      begin
        if Lo(Msg.wParam) = 100 then Beep(500,100);
      end;
  end;
  Result := CallNextHookEx(hNextHook, nCode, wParam, lParam);
end;procedure Hook; stdcall;
begin
  hNextHook := SetWindowsHookEx(WH_CALLWNDPROC, @CallWndProc, HInstance, 0);
end;procedure UnHook; stdcall;
begin
  if hNextHook <> 0 then
    UnhookWindowsHookEx(hNextHook);
end;exports
  Hook, UnHook;begin
  hNextHook := 0;
end.//////////////
调用代码：
unit Unit1;interfaceuses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;var
  Form1: TForm1;implementation{$R *.dfm}procedure Hook; stdcall;external 'project2.dll';
procedure UnHook; stdcall;external 'project2.dll';procedure TForm1.FormCreate(Sender: TObject);
begin
  Hook;
end;procedure TForm1.FormDestroy(Sender: TObject);
begin
  UnHook;
end;end.
效果圖片：http://www.eping.net/fourm/UploadFile/200362316553182637.jpg

Answer 2

你要的是桌面右键菜单的吧？那得用到shell编程，找本相关的资料看看，我这儿有一个实现文件管理器上的右键菜单代码，贴给你：
第一个：conextmenu_TLB.pas
unit contextmenu_TLB;// ************************************************************************ //
// WARNING                                                                    
// -------                                                                    
// The types declared in this file were generated from data read from a       
// Type Library. If this type library is explicitly or indirectly (via        
// another type library referring to this type library) re-imported, or the   
// 'Refresh' command of the Type Library Editor activated while editing the   
// Type Library, the contents of this file will be regenerated and all        
// manual modifications will be lost.                                         
// ************************************************************************ //// PASTLWTR : $Revision:   1.130  $
// File generated on 2003-5-10 0:29:30 from Type Library described below.// ************************************************************************  //
// Type Lib: F:\TELECOM\ContextMenu\contextmenu.tlb (1)
// LIBID: {5F6B1CC4-1752-491B-A689-5C19331A3364}
// LCID: 0
// Helpfile: 
// DepndLst: 
//   (1) v2.0 stdole, (C:\WINDOWS\System32\stdole2.tlb)
// ************************************************************************ //
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. 
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}interfaceuses ActiveX, Classes, Graphics, StdVCL, Variants, Windows;
  // *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:        
//   Type Libraries     : LIBID_xxxx                                      
//   CoClasses          : CLASS_xxxx                                      
//   DISPInterfaces     : DIID_xxxx                                       
//   Non-DISP interfaces: IID_xxxx                                        
// *********************************************************************//
const
  // TypeLibrary Major and minor versions
  contextmenuMajorVersion = 1;
  contextmenuMinorVersion = 0;  LIBID_contextmenu: TGUID = '{5F6B1CC4-1752-491B-A689-5C19331A3364}';
implementationuses ComObj;end.

Answer 3

第二个：contextmenuhandle.pas
unit contextmenuhandle;interfaceuses Windows,ActiveX,ComObj,ShlObj,Classes;type
  TContextMenu = class(TComObject,IShellExtInit,IContextMenu)
private
  FFileName: array[0..MAX_PATH] of Char;
protected
  function IShellExtInit.Initialize = SEIInitialize; // Avoid compiler warning
  function SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
                          hKeyProgID: HKEY): HResult; stdcall;
  function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
                          uFlags: UINT): HResult; stdcall;
  function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
  function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
                          pszName: LPSTR; cchMax: UINT): HResult; stdcall;
  function IsValidFileType(FileName: String):Boolean;
end;const
  Class_ContextMenu: TGUID = '{19770906-C300-11D1-8233-0020AF3E97A0}';
  {全局唯一标识符(GUID)是一个16字节（128为）的值，它唯一地标识一个接口(interface)}var
  FileName: String;
  FileNumber: Integer;implementationuses ComServ, SysUtils, ShellApi, Registry, opwindow;function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
                                    hKeyProgID: HKEY): HResult;
var
  StgMedium: TStgMedium;
  FormatEtc: TFormatEtc;
begin
  //如果lpdobj等于Nil，则本调用失败
  if (lpdobj = nil) then begin
    Result := E_INVALIDARG;
    Exit;
  end;
  //首先初始化并清空FileList以添加文件 (duduwolf修改，取消FileList)
  //FileList:=TStringList.Create;
  //FileList.Clear;
  FileName:= '';
  //初始化剪贴版格式文件
  with FormatEtc do begin
    cfFormat := CF_HDROP;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;
  Result := lpdobj.GetData(FormatEtc, StgMedium);
  if Failed(Result) then Exit;
  //首先查询用户选中的文件的个数
  FileNumber := DragQueryFile(StgMedium.hGlobal,$FFFFFFFF,nil,0);
  //循环读取，将所有用户选中的文件保存到FileList中  (duduwolf修改)
  //如果文件个数大于1就返回
  {for i:=0 to FileNumber-1 do begin
    DragQueryFile(StgMedium.hGlobal, i, FFileName, SizeOf(FFileName));
    FileList.Add(FFileName);
    Result := NOERROR;
  end;}
  if FileNumber = 1 then
  begin
    DragQueryFile(StgMedium.hGlobal, 0, FFileName, SizeOf(FFileName));
    FileName:= FFileName;
    Result:= NOERROR;
  end;
  ReleaseStgMedium(StgMedium);
end;function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
                    idCmdLast, uFlags: UINT): HResult;
var
  bmp1: HBITMAP;
begin
  Result := 0;
  if ((uFlags and $0000000F) = CMF_NORMAL) or
  ((uFlags and CMF_EXPLORE) <> 0) then begin
    if (FileNumber = 1) and (IsValidFileType(FileName) = true) then begin
      InsertMenu(Menu,indexMenu+1, MF_SEPARATOR or MF_BYPOSITION,idCmdLast,nil);
      InsertMenu(Menu, indexMenu+2, MF_STRING or MF_BYPOSITION,
              idCmdFirst,PChar('Telecom - 发送报表'));
      InsertMenu(Menu,indexMenu+3, MF_SEPARATOR or MF_BYPOSITION,idCmdLast,nil);
      // 往Context Menu中加入一个菜单项 ,菜单项的标题为察看位图文件
      bmp1:= LoadBitmap(hInstance,'B1');
      SetMenuItemBitmaps(Menu,indexMenu+2,MF_BYPOSITION,bmp1,0);
      // 返回增加菜单项的个数
      Result := 3;
    end;
  end;
end;function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
var
  frmOP:TFrmContextMenu;
begin
// 首先确定该过程是被系统而不是被一个程序所调用
  if (HiWord(Integer(lpici.lpVerb)) <> 0) then
  begin
    Result := E_FAIL;
    Exit;
  end;
  // 确定传递的参数的有效性
  if (LoWord(lpici.lpVerb) <> 0) then begin
    Result := E_INVALIDARG;
    Exit;
  end;
  //建立文件操作窗口
  frmOP:=TFrmContextMenu.Create(nil);
  //将所有的文件列表添加到文件操作窗口的列表中
  frmOP.Edit1.Text := FileName;
  frmOP.Show;
  Result := NOERROR;
end;function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
              pszName: LPSTR; cchMax: UINT): HRESULT;
begin
  if (idCmd = 0) then begin
    if (uType = GCS_HELPTEXT) then
  {返回该菜单项的帮助信息，此帮助信息将在用户把鼠标
  移动到该菜单项时出现在状态条上。}
  StrCopy(pszName, PChar('Telecom商品管理软件报表发送'));
  Result := NOERROR;
  end
  else
    Result := E_INVALIDARG;
  end;
type
  TContextMenuFactory =class(TComObjectFactory)publicprocedure UpdateRegistry(Register: Boolean); override;end;procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
var
  ClassID: string;
begin
  if Register then begin
    inherited UpdateRegistry(Register);
    ClassID := GUIDToString(Class_ContextMenu);
    //当注册扩展库文件时，添加库到注册表中
    CreateRegKey('*\shellex', '', '');
    CreateRegKey('*\shellex\ContextMenuHandlers', '', '');
    CreateRegKey('*\shellex\ContextMenuHandlers\FileOpreation', '', ClassID);
    //如果操作系统为Windows NT的话
    if (Win32Platform = VER_PLATFORM_WIN32_NT) then
      with TRegistry.Create do
        try
          RootKey := HKEY_LOCAL_MACHINE;
          OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True);
          OpenKey('Approved', True);
          WriteString(ClassID, 'Telecom Send Reports ContextMenu');
        finally
          Free;
        end;
      end
    else begin
      DeleteRegKey('*\shellex\ContextMenuHandlers\FileOpreation');
      inherited UpdateRegistry(Register);
    end;
end;function TContextMenu.IsValidFileType(FileName: String): Boolean;
begin  Result:= false;
  if FileExists(FileName) then
  begin
    if UpperCase(ExtractFileExt(FileName)) = '.XLS' then Result:= true
    else if UpperCase(ExtractFileExt(Filename)) = '.DOC' then Result:= true
    else Result:= false;
  end;
end;initialization
  TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,'', 'Telecom Send Reports ContextMenu', ciMultiInstance,tmApartment);
end.

Answer 4

第三个：点击右键显示的窗体部分opwindow.pas
unit opwindow;interface 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls,ActiveX, ComCtrls, IniFiles, Registry, DB, ADODB, StrUtils;
type
  TFrmContextMenu = class(TForm)
  Button1: TButton;
  Button2: TButton;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    Label5: TLabel;
    RichEdit1: TRichEdit;
    Aqy: TADOQuery;
    Label3: TLabel;
    Edit1: TEdit;
    Label6: TLabel;
    Label7: TLabel;
    Edit3: TEdit;
    Edit4: TEdit;
    Label4: TLabel;
    Edit2: TEdit;
    CheckBox1: TCheckBox;
    Label1: TLabel;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);private
  { Private declarations }
  function GetListUser(SourceStr: String):String;
  function GetFileType(FileName: String):Integer;
public
  FileList:TStringList;
  { Public declarations }
end;var
  FrmContextMenu: TFrmContextMenu;
  sUserName, sConnectString: String;implementation
{$R *.DFM}procedure TFrmContextMenu.FormCreate(Sender: TObject);
var
  Reg: TRegistry;
  IpAddress, sLastUser: String;
begin
  //从注册表中取出数据库的计算机局域网IP地址  Reg:= TRegistry.Create(HKEY_LOCAL_MACHINE);
  Reg.RootKey:= HKEY_LOCAL_MACHINE;
  if (Reg.OpenKey('SOFTWARE\Telecom', False)) then begin
    sLastUser:= Reg.ReadString('LastUser');
    IpAddress:= Reg.ReadString('ServerIpAddress');
    Edit3.Text:= sLastUser;
  end
  else begin
    MessageBox(Self.Handle,'Telecom没有安装或者软件安装有错误，请联系系统管理员！','错误',MB_ICONERROR);
    Reg.Free;
    Exit;
  end;
  Reg.Free;
  //初始化数据库连接字符串
  if Trim(IpAddress) <> '' then
  begin
    sConnectString:= 'Provider=SQLOLEDB.1;Password=I am DuDuWolf@I Love JYX Forever;Persist Security Info=True;User ID=sa;Initial Catalog=TELECOM;';
    sConnectString:= sConnectString + 'Data Source='+Trim(IpAddress);
    Aqy.ConnectionString:= sConnectString;
  end else begin
    MessageBox(Self.Handle,'Telecom软件安装有错误，请联系系统管理员！','错误',MB_ICONERROR);
    Exit;
  end;
  Self.Show;
end;procedure TFrmContextMenu.Button1Click(Sender: TObject);
var
  FileNo, i: Integer;
  tb: TADOTable;
  pField: TBlobField;
  UserList: TStringList;
  SendMan: String;
begin
  //发送报表
  if Trim(Edit3.Text) = '' then begin
    MessageBox(Self.Handle,'用户名不能为空！','错误',MB_ICONERROR);
    ExIT;
  end;
  Aqy.Close;
  Aqy.SQL.Clear;
  Aqy.SQL.Add('select * from oper where 操作员工号='''+Edit3.Text+'''');
  Aqy.SQL.Add(' and 密码='''+Edit4.Text+'''');
  Aqy.Open;
  if Aqy.Eof then begin
    MessageBox(Self.Handle,'用户名或者密码输入错误！','错误',MB_ICONERROR);
    Exit;
  end else begin
    sUserName:= Edit3.Text;
  end;
  if Trim(Edit2.Text) = '' then
  begin
    MessageBox(Self.Handle,'没有输入发送标题，无法发送！','错误',MB_ICONERROR);
    Exit;
  end;
  if not FileExists(Edit1.Text) then
  begin
    MessageBox(Self.Handle,PChar('选择的文件名'''+Edit2.Text+'''不存在，请重新选择！'),'错误',MB_ICONERROR);
    Exit;
  end;
  //得到发送人的报表发送权限和接受人列表
  Aqy.Close;
  Aqy.SQL.Clear;
  Aqy.SQL.Add('select SendMan from oa_power where oper='''+sUserName+''' ');
  Aqy.Open;
  if(Aqy.Eof) then begin
    MessageBox(Self.Handle,PChar('操作员'''+sUserName+'''没有发送报表的权限'),'错误',MB_ICONERROR);
    Exit;
  end else begin
    UserList:= TStringList.Create;
    SendMan:= Aqy.Fields.Fields[0].AsString;
    while Length(SendMan)>0 do
    begin
      UserList.Add(Copy(SendMan,2,3));
      Delete(SendMan,1,5);
    end;
  end;  //得到全文列表中的新的ID标示号
  FileNo:= 0;
  Aqy.Close;
  Aqy.SQL.Clear;
  Aqy.SQL.Add('SELECT MAX(FileID) FROM oa_file');
  Aqy.Open;
  if not Aqy.Eof then
    FileNo:= Aqy.Fields.Fields[0].AsInteger + 1;  //首先插入OA_FILE表
  tb:= TADOTable.Create(nil);
  tb.ConnectionString := sConnectString;
  tb.TableName := 'OA_FILE';
  tb.Open;
  tb.Insert;
  tb.FieldByName('FileID').AsInteger := FileNo;
  tb.FieldByName('FileType').AsInteger := GetFileType(Edit1.Text);
  tb.FieldByName('FileName').AsString := ExtractFileName(Edit1.Text);
  pField:= tb.FieldByName('FileBuffer') as TBlobField;
  //((TBlobField )tb.FieldByName('FileBuffer')).LoadFromFile(Edit1.Text);
  pField.LoadFromFile(Edit1.Text);
  tb.Post;
  tb.Free;
  //插入OA_MAIN表
  Aqy.Close;
  Aqy.SQL.Clear;
  for i:=0 to UserList.Count - 1 do
  if Edit3.Text <> GetListUser(UserList.Strings[i]) then
  begin
    Aqy.SQL.Add('INSERT INTO OA_MAIN(SendMan,RecvMan,FileID,Title,');
    Aqy.SQL.Add('Message,ReadWriteTag,SendTime,Comment) ');
    Aqy.SQL.Add('VALUES('''+sUserName+''',');
    Aqy.SQL.Add(''''+GetListUser(UserList.Strings[i])+''','+IntToStr(FileNo)+',');
    Aqy.SQL.Add(''''+Edit2.Text+''',');
    Aqy.SQL.Add(''''+AnsiReplaceStr(RichEdit1.Text,'''','''')+''',');
    if CheckBox1.Checked then
      Aqy.SQL.Add('0,')
    else Aqy.SQL.Add('1,');
    Aqy.SQL.Add(''''+FormatDateTime('yyyy-MM-dd hh:mm:ss',Now())+''','''') ');
  end;
  if Trim(Aqy.SQL.Text) <> '' then
    Aqy.ExecSQL;
  MessageBox(Self.Handle,'发送成功！','成功',MB_ICONINFORMATION);
  Self.Close;
end;procedure TFrmContextMenu.Button2Click(Sender: TObject);
begin
  Self.Close;
end;function TFrmContextMenu.GetListUser(SourceStr: String): String;
begin
  Result:= Copy(SourceStr, Length(SourceStr)-3, 3);
end;function TFrmContextMenu.GetFileType(FileName: String): Integer;
var
  FileType: Integer;
begin
  FileType:= 0;
  if FileExists(FileName) then
  begin
    if UpperCase(ExtractFileExt(FileName)) = '.XLS' then FileType := 1
    else if UpperCase(ExtractFileExt(Filename)) = '.DOC' then FileType := 2
    else if UpperCase(ExtractFileExt(Filename)) = '.TXT' then FileType := 3
    else FileType := 4;
  end;
  Result:= FileType
end;end.

Answer 5

jackie168(玉面書生) 老兄的例子不知能不能介绍一下，单击菜单条后是怎么响应？
 duduwolf(嘟嘟狼) 老兄的好象太复杂了！

Answer 6

对啊。
我的想法是找到桌面的那个窗口
用FindWindow('progman', 'Program Manager')，
然后再用GetSystemMenu来取得这个窗口的系统菜单，但是为什么不行啊。
我可以把这个窗口给隐藏或显示（就是把桌面的图标显示或隐藏），但是取得的系统菜单为什么不是这个啊。

Answer 7

要實現個com接口, 實現說難不難, 但也有一堆代碼, 貼出來太煩了!

Answer 8

不复杂啊！如果你直想用FindWindows函数，你可以尝试取得Explorer.exe这个文件所在进程对应的窗口句柄，不过我想用GetSystemMenu是无法得到桌面右键菜单的！

Answer 9

用API忝加？？？？不是吧！那下次系统一启动菜单项又不见了！

Answer 10

不管是江民还是winrar，全部都是通过winshell的com接口添加菜单的，用注册表的方法可以实现的（比如windows优化大师就可以自定义右键菜单），不过好像我见过的软件都是通过com接口实现的:)