RealICQClient/COM/IEContext/CIEContextMenu.pas

unit CIEContextMenu;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, ActiveX, shellApi,Classes, ComObj, Shdocvw, Registry, IEContext_TLB, StdVcl;

type
  TIEContextMenu = class(TAutoObject, IIEContextMenu, IObjectSafety)
  private
    FObjectSafetyFlags: DWORD;  
  protected
    procedure AddFace(FileName: OleVariant); safecall;
    
    function GetInterfaceSafetyOptions(const IID: TIID; pdwSupportedOptions,
      pdwEnabledOptions: PDWORD): HResult; stdcall;
    function SetInterfaceSafetyOptions(const IID: TIID; dwOptionSetMask,
      dwEnabledOptions: DWORD): HResult; stdcall;
    procedure OpenUmc; safecall;
  end;

const
  AppTitle = '办公助手';
  iAtom: PChar = 'Winsoft';
  AppKey = '\Software\Winsoft\LxTalk';
  CompanyKeyValue = '\Winsoft'; //做OEM版时，此处应该改为对应公司的网址或名称

implementation

uses Variants,ComServ, Clipbrd, Dialogs, SysUtils, StrUtils, UrlMon;

//------------------------------------------------------------------------------
function TIEContextMenu.GetInterfaceSafetyOptions(const IID: TIID;
  pdwSupportedOptions, pdwEnabledOptions: PDWORD): HResult;
var
  Unk: IUnknown;
begin
  if (pdwSupportedOptions = nil) or (pdwEnabledOptions = nil) then
  begin
    Result := E_POINTER;
    Exit;
  end;
  Result := QueryInterface(IID, Unk);
  if Result = S_OK then
  begin
    pdwSupportedOptions^ := INTERFACESAFE_FOR_UNTRUSTED_CALLER or
      INTERFACESAFE_FOR_UNTRUSTED_DATA;
    pdwEnabledOptions^ := FObjectSafetyFlags and
      (INTERFACESAFE_FOR_UNTRUSTED_CALLER or INTERFACESAFE_FOR_UNTRUSTED_DATA);
  end
  else begin
    pdwSupportedOptions^ := 0;
    pdwEnabledOptions^ := 0;
  end;
end;

//------------------------------------------------------------------------------
function TIEContextMenu.SetInterfaceSafetyOptions(const IID: TIID;
  dwOptionSetMask, dwEnabledOptions: DWORD): HResult;
var
  Unk: IUnknown;
begin
  Result := QueryInterface(IID, Unk);
  if Result <> S_OK then Exit;
  FObjectSafetyFlags := dwEnabledOptions and dwOptionSetMask;
end;
//--------------------------------------------------
procedure TIEContextMenu.OpenUmc;
var  Registry: TRegistry;
     ExeFileName:String;
     Handle: HWND;
begin
    {从注册表中读取 BaseURL}
  ExeFileName:='';
  Registry := TRegistry.Create;
  try
    Registry.RootKey := HKEY_LOCAL_MACHINE;
    if Registry.OpenKey(AppKey + CompanyKeyValue, True) then
    begin
      ExeFileName := Registry.ReadString('ExeFileName');
    end;
  finally
    Registry.Free;
  end;
  Handle := openmutex(mutex_all_access, False, iAtom);
  try
    if Handle = 0 then
    begin
      ShellExecute(0, 'open', PChar('"' + ExeFileName  + '"'), nil, nil, SW_SHOWNORMAL);
      Exit;
    end;
  finally
    closeHandle(Handle);
  end;
end;
//------------------------------------------------------------------------------
procedure TIEContextMenu.AddFace(FileName: OleVariant);
var
  FVar: OleVariant;
  DestFile,
  SrcFile,ExeFileName,
  FileExt: String;
  TempFile: array[0..MAX_PATH] of char;
  Handle: HWND;
begin

  Handle := openmutex(mutex_all_access, False, iAtom);
  try
    if Handle = 0 then
    begin
      MessageBox(0, PChar(AppTitle + ' 还未启动！'), '提示', MB_ICONINFORMATION);
      Exit;
    end;
  finally
    closeHandle(Handle);
  end;

  FVar := CreateOleObject('RealICQ.RealOAMessengerAutoServer');
  try
    try
      if AnsiSameText(Copy(FileName, 1, 7), 'http://') or
         AnsiSameText(Copy(FileName, 1, 6), 'ftp://') or
         AnsiSameText(Copy(FileName, 1, 7), 'file://') then
      begin
        DestFile := AnsiReplaceStr(FileName, '\', '/');
        while AnsiPos('/', DestFile) > 0 do
        begin
          DestFile := Copy(DestFile, AnsiPos('/', DestFile) + 1, Length(DestFile));
        end;

        GetTempPath(MAX_PATH, TempFile);
        GetTempFileName(TempFile, 'IMG', GetTickCount, TempFile);
        DestFile := ExtractFilePath(TempFile) + DestFile;
        FileExt := ExtractFileExt(DestFile);

        if (AnsiSameText(Copy(FileExt, 1, 4), '.JPG')) or (AnsiSameText(Copy(FileExt, 1, 5), '.JPEG')) then
          DestFile := AnsiReplaceText(DestFile, FileExt, '.JPG')
        else if (AnsiSameText(Copy(FileExt, 1, 4), '.GIF')) then
          DestFile := AnsiReplaceText(DestFile, FileExt, '.GIF')
        else if (AnsiSameText(Copy(FileExt, 1, 4), '.BMP')) then
          DestFile := AnsiReplaceText(DestFile, FileExt, '.BMP');

        SrcFile := FileName;
        UrlDownLoadToFile(nil, PChar(SrcFile), PChar(DestFile), 0, nil);
        FileName := DestFile;
        end;
        FVar.AddFace(FileName);
      except
        on E: Exception do MessageBox(0, PChar(E.Message), '错误', MB_ICONINFORMATION);
      end;
    finally
      FVar := Unassigned;
    end;
end;

type
  TIEContextMenuFactory = class(TAutoObjectFactory)
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

procedure AddExtMenuItem(MenuText, Url: string; Contexts:DWord);
var
  reg: TRegistry;
begin
  Reg := TRegistry.Create;
  with Reg do try
    RootKey := HKEY_CURRENT_USER;
    OpenKey('\Software\Microsoft\Internet Explorer\MenuExt\' + MenuText, True);
    WriteString('', Url);
    WriteInteger('contexts', contexts);
    CloseKey;
  finally
    Free;
  end;
end;

procedure RemoveExtMenuItem(MenuText: string);
var
  reg: TRegistry;
begin
  Reg := TRegistry.Create;
  with Reg do try
    RootKey := HKEY_CURRENT_USER;
    DeleteKey('\Software\Microsoft\Internet Explorer\MenuExt\' + MenuText);
  finally
    Free;
  end;
end;

function GetDllName: string;
var
  Buffer: array[0..261] of Char;
begin
  GetModuleFileName(HInstance, Buffer, SizeOf(Buffer));
  Result := string(Buffer);
end;

procedure TIEContextMenuFactory.UpdateRegistry(Register: Boolean);
begin
  inherited;
  if Register then
    AddExtMenuItem('将此图片添加为' + AppTitle + '表情', ExtractFilePath(GetDllName)+'html\addFace.htm',2)
  else
    RemoveExtMenuItem('将此图片添加为' + AppTitle + '表情');
end;

initialization
  TIEContextMenuFactory.Create(ComServer, TIEContextMenu, Class_IEContextMenu,
    ciMultiInstance, tmApartment);
end.