Shell extension

unit uGetResList;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, ActiveX, Classes, Sysutils, Messages, ComObj, ShellAPI, ShlObj,
  Math, Graphics, JPEG, Registry;

type
  TGetResList = class(TComObject, IShellExtInit, IContextMenu, IContextMenu3)
  private
    FFileList: TStrings;
    FGraphic: TGraphic;
  protected
    //IShellExtInit
    function IShellExtInit.Initialize = SEInitialize;
    function SEInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
      hKeyProgID: HKEY): HResult; stdcall;
    //IContextMenu
    function QueryContextMenu(Menu: HMENU;
      indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;//before popup
    function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;//onclick
    function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
      pszName: LPSTR; cchMax: UINT): HResult; stdcall;//hint when move over
    //IContextMenu2
    function HandleMenuMsg(uMsg: UINT; WParam, LParam: Integer): HResult; stdcall;
    //IContextMenu3
    function HandleMenuMsg2(uMsg: UINT; wParam, lParam: Integer;
      var lpResult: Integer): HResult; stdcall;
  public
    procedure Initialize; override;
    destructor Destroy; override;
  end;

  TGetResListFactory = class(TComObjectFactory)
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

const
  Class_GetResList: TGUID = '{AAE1817E-34EA-4892-B6A7-8D5738BA3074}';

  //menu type
  mfString    = MF_STRING or MF_BYPOSITION;
  mfOwnerDraw = MF_OWNERDRAW or MF_BYPOSITION;
  mfSpearator = MF_SEPARATOR or MF_BYPOSITION;

  //menu ID
  idCopyAnyWhere = 0;//copy(move)
  idRegister = 5;   //registerActiveX
  idUnregister = 6; //unregisterActiveX
  idImagePreview = 10;//preview picture
  idMenuRange = 90; //

resourcestring
  //menu item name
  sCopyAnyWhere = 'Copy any where...';
  sCopyAnyWhereTip = '可将选定的文件复制到任何路径下';
  sRegister = '注册...';
  sRegisterTip = '注册GetResList插件库';
  sUnregister = '取消注册...';
  sUnregisterTip = '取消注册GetResList插件库';
  sImagePriview = '预览图片文件';
  sImagePriviewTip = '预览图片文件';

function GetFileListFromDataObject(lpdobj: IDataObject; sl: TStrings): HResult;
function IsActiveLib(const FileName: string): Boolean;
procedure RegisterActiveLib(Wnd: HWND; const FileName: string);
procedure UnregisterActiveLib(Wnd: HWND; const FileName: string);
procedure ReportWin32Error(Wnd: HWND; const Prefix: string; dwError: DWORD);
function IsImageFile(const FileName: string): Boolean;
function ImageFromFile(const FileName: string): TGraphic;
function ExecuteFile(Wnd: HWND; const FileName: string): THandle;
procedure DrawGraphic(adc: HDC; rc: TRect; State: Integer; Graphic: TGraphic);
function ImageInfoToStr(Graphic: TGraphic): string;

function Make_HResult(sev, fac, code: Word): DWORD;
procedure DoCopyAnyWhere(Wnd: HWND; sl: TStrings);


implementation

uses ComServ;

//* 根据图片对象，得到图片相关的信息
function ImageInfoToStr(Graphic: TGraphic): string;
begin
  Result := Format('%d * %d', [Graphic.Width, Graphic.Height]);
  if Graphic is TIcon then
    Result := Result + ' 图标';
  if Graphic is TBitmap then
  begin
    case TBitmap(Graphic).PixelFormat of
      pfDevice: Result := Result + ' DDB';
      pf1bit: Result := Result + ' 2色';
      pf4bit: Result := Result + ' 16色';
      pf8bit: Result := Result + '256色';
      pf15bit, pf16bit: Result := Result + ' 16位色';
      pf24bit: Result := Result + ' 24位色';
      pf32bit: Result := Result + ' 32位色';
      pfCustom: Result := Result + ' 自定义色';
    end;
    Result := Result + '位图';
  end;
  if Graphic is TMetafile then
  begin
    Result := Result + Format('(%d*%d) 元文件', [TMetafile(Graphic).MMWidth div 100,
      TMetafile(Graphic).MMHeight div 100]);
  end;
  if Graphic is TJPEGImage then
  begin
    case TJPEGImage(Graphic).PixelFormat of
      jf24Bit: Result := Result + ' 24位色 JPEG';
      jf8Bit: Result := Result + ' 8位色 JPEG';
    end;
  end;
end;

//* 画图像
procedure DrawGraphic(adc: HDC; rc: TRect; State: Integer; Graphic: TGraphic);
var
  rcImage, rcText, rcStretch: TRect;
  Canvas: TCanvas;
  nSaveDC: Integer;
  x, y: Integer;
  xScale, yScale, Scale: Double;
  xStretch, yStretch: Integer;
begin
  rcImage.Left := rc.Left + 10;
  rcImage.Right := rc.Right - 10;
  rcImage.Top := rc.Top + 10;
  rcImage.Bottom := rc.Bottom - 30;

  rcText.Left := rc.Left + 10;
  rcText.Right := rc.Right - 10;
  rcText.Top := rc.Bottom - 20;
  rcText.Bottom := rc.Bottom;

  Canvas := TCanvas.Create;
  nSaveDC := 0;
  try
    nSaveDC := SaveDC(adc);
    Canvas.Handle := adc;

    if not Assigned(Graphic) then
    begin
      Canvas.Rectangle(rcImage);
      Canvas.MoveTo(rcImage.Left, rcImage.Top);
      Canvas.LineTo(rcImage.Right, rcImage.Bottom);
      Canvas.MoveTo(rcImage.Right, rcImage.Top);
      Canvas.LineTo(rcImage.Left, rcImage.Bottom);
      DrawText(Canvas.Handle, '未知图像', -1, rcImage, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
    end
    else
    begin
      if (Graphic.Width < rcImage.Right - rcImage.Left)
        and (Graphic.Height < rcImage.Bottom - rcImage.Top) then
      begin
        x := rcImage.Left + (rcImage.Right - rcImage.Left - Graphic.Width) div 2;
        y := rcImage.Top + (rcImage.Bottom - rcImage.Top - Graphic.Height) div 2;
        Canvas.Draw(x, y, Graphic);
      end
      else
      begin
        xScale := Graphic.Width / (rcImage.Right - rcImage.Left);
        yScale := Graphic.Height / (rcImage.Bottom - rcImage.Top);
        Scale := Max(xScale, yScale);
        xStretch := Trunc(Graphic.Width / Scale);
        yStretch := Trunc(Graphic.Height / Scale);
        x := rcImage.Left + (rcImage.Right - rcImage.Left - xStretch) div 2;
        y := rcImage.Top + (rcImage.Bottom - rcImage.Top - yStretch) div 2;
        rcStretch := Rect(x, y, x + xStretch, y + yStretch);
        Canvas.StretchDraw(rcStretch, Graphic);
      end;
      Windows.FillRect(Canvas.Handle, rcText, GetSysColorBrush(COLOR_MENU));
      SetTextColor(Canvas.Handle, GetSysColor(COLOR_MENUTEXT));
      SetBkColor(Canvas.Handle, GetSysColor(COLOR_MENU));
      DrawText(Canvas.Handle, PChar(ImageInfoToStr(Graphic)), -1, rcText,
        DT_SINGLELINE or DT_CENTER or DT_VCENTER);
    end;
  finally
    Canvas.Handle := 0;
    FreeAndNil(Canvas);
    RestoreDC(adc, nSaveDC);
  end;
end;

//* 打开文件
function ExecuteFile(Wnd: HWND; const FileName: string): THandle;
var
  Path: string;
begin
  Path := ExtractFilePath(FileName);
  Result := ShellExecute(Wnd, 'open', PChar(FileName), nil, PChar(Path), SW_SHOW);
end;

//* 图片从文件载入(其实也是判断文件是否是真正的图片文件。如果是，则能正常载入)
function ImageFromFile(const FileName: string): TGraphic;
var
  Ext: string;
begin
  Ext := UpperCase(ExtractFileExt(FileName));
  Result := nil;
  if not IsImageFile(FileName) then
    Exit;
  try
    if (Ext = '.ICO') then
      Result := TIcon.Create
    else if Ext = '.BMP' then
      Result := TBitmap.Create
    else if (Ext = '.EMF') or (Ext = '.WMF') then
      Result := TMetafile.Create
    else if (Ext = '.JPG') or (Ext = '.JPEG') then
      Result := TJPEGImage.Create;
    Result.LoadFromFile(FileName);
  except
    if Assigned(Result) then
      FreeAndNil(Result);
  end;
end;

//* 判断是否是图片文件
function IsImageFile(const FileName: string): Boolean;
var
  Ext: string;
begin
  Ext := UpperCase(ExtractFileExt(FileName));
  Result := (Ext = '.ICO') or (Ext = '.BMP') or (Ext = '.EMF') or (Ext = '.WMF')
    or (Ext = '.JPG') or (Ext = '.JPEG');
end;

//* 错误报告
procedure ReportWin32Error(Wnd: HWND; const Prefix: string; dwError: DWORD);
//var
//  szError: array[0..399] of char;
//  str: string;
begin
  OutputDebugString(PChar(Prefix));
//  FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, dwError,
//    Make_LangID(LANG_NEUTRAL, SUBLANG_DEFAULT), szError, SizeOf(szError), nil);
//  str := Format('%s: %s', [Prefix, StrPas(szError)]);
//  MessageBox(Wnd, PChar(str), '错误', MB_ICONEXCLAMATION);
end;

//* 取消注册AcitveX库
procedure UnregisterActiveLib(Wnd: HWND; const FileName: string);
var
  hLib: THandle;
  fn: TDLLUnregisterServer;
  hr: HRESULT;
begin
  hLib := LoadLibrary(PChar(FileName));
  if hLib = 0 then
  begin
    ReportWin32Error(Wnd, '装载文件失败', GetLastError);
    Exit;
  end;
  try
    fn := TDLLUnregisterServer(GetProcAddress(hLib, 'DllUnregisterServer'));
    if not Assigned(fn) then
    begin
      MessageBox(Wnd, '定位函数入口点 DllUnregisterServer 失败', '错误', MB_ICONEXCLAMATION);
      Exit;
    end;
    hr := fn();
    if Failed(hr) then
    begin
      ReportWin32Error(Wnd, '取消注册动态库失败', hr);
      Exit;
    end;
    MessageBox(Wnd, '取消注册成功', '成功', MB_ICONINFORMATION);
  finally
    FreeLibrary(hLib);
  end;
end;

//* 注册ActiveX库
procedure RegisterActiveLib(Wnd: HWND; const FileName: string);
var
  hLib: THandle;
  fn: TDLLRegisterServer;
  hr: HRESULT;
begin
  hLib := LoadLibrary(PChar(FileName));
  if hLib = 0 then
  begin
    ReportWin32Error(Wnd, '装载文件失败', GetLastError);
    Exit;
  end;
  try
    fn := TDLLRegisterServer(GetProcAddress(hLib, 'DllRegisterServer'));
    if not Assigned(fn) then
    begin
      MessageBox(Wnd, '定位函数入口点 DllRegisterServer 失败', '错误', MB_ICONEXCLAMATION);
      Exit;
    end;
    hr := fn();
    if Failed(hr) then
    begin
      ReportWin32Error(Wnd, '注册动态库失败', hr);
      Exit;
    end;
    MessageBox(Wnd, '注册成功', '成功', MB_ICONINFORMATION);
  finally
    FreeLibrary(hLib);
  end;
end;

//* 检查指定的文件是否是ActiveX文件
function IsActiveLib(const FileName: string): Boolean;
var
  Ext: string;
  hLib: THandle;
begin
  Result := False;
  Ext := UpperCase(ExtractFileExt(FileName));
  if (Ext <> '.EXT') and (Ext <> '.DLL') and (Ext <> '.OCX') then
    Exit;
  hLib := LoadLibrary(PChar(FileName));
  if hLib = 0 then Exit;
  try
    Result := GetProcAddress(hLib, 'DllRegisterServer') <> nil;
  finally
    FreeLibrary(hLib);
  end;
end;

procedure DoCopyAnyWhere(Wnd: HWND; sl: TStrings);
begin
  //some code here.
end;

function Make_HResult(sev, fac, code: Word): DWORD;
begin
  Result := (sev shl 31) or (fac shl 16) or code;
end;

function GetFileListFromDataObject(lpdobj: IDataObject; sl: TStrings): HResult;
var
  fe: FormatEtc;
  sm: StgMedium;
  i, iFileCount: Integer;
  FileName: array[0..MAX_PATH - 1] of char;
begin
  Assert(lpdobj <> nil);
  Assert(sl <> nil);
  sl.Clear;

  fe.cfFormat := CF_HDROP;
  fe.ptd := nil;
  fe.dwAspect := DVASPECT_CONTENT;
  fe.lindex := -1;
  fe.tymed := TYMED_HGLOBAL;

  sm.tymed := TYMED_HGLOBAL;

  Result := lpdobj.GetData(fe, sm);
  if (FAILED(Result)) then Exit;
  iFileCount := DragQueryFile(sm.hGlobal, $FFFFFFFF, nil, 0);
  if iFileCount <= 0 then
  begin
    ReleaseStgMedium(sm);
    Result := E_INVALIDARG;
    Exit;
  end;
  for i := 0 to iFileCount - 1 do
  begin
    DragQueryFile(sm.hGlobal, i, FileName, Sizeof(FileName));
    sl.Add(FileName);
  end;
  ReleaseStgMedium(sm);
  Result := S_OK;
end;

{ TGetResListFactory }

procedure TGetResListFactory.UpdateRegistry(Register: Boolean);
  procedure DeleteRegValue(const Path, ValueName: string; Root: DWORD = HKEY_CLASSES_ROOT);
  var
    reg: TRegistry;
  begin
    reg := TRegistry.Create;
    try
      reg.RootKey := Root;
      if reg.OpenKey(Path, False) then
      begin
        if reg.ValueExists(ValueName) then
          reg.DeleteValue(ValueName);
        reg.CloseKey;
      end;
    finally
      FreeAndNil(reg);
    end;
  end;
const
  RegPath = '*\shellex\ContextMenuHandlers\GetResList';
  ApprovedPath = 'Software\Microsoft\Windows\CurrentVersion\ShellExtensions\Approved';
var
  strGUID: string;
begin
  inherited;
  strGUID := GUIDToString(Class_GetResList);
  if Register then
  begin
    CreateRegKey(RegPath, '', strGUID);
    CreateRegKey(ApprovedPath, strGUID, 'GetResList的外壳扩展', HKEY_LOCAL_MACHINE);
  end
  else
  begin
    DeleteRegKey(RegPath);
    DeleteRegValue(ApprovedPath, strGUID, HKEY_LOCAL_MACHINE);
  end;
end;

{ TGetResList }

destructor TGetResList.Destroy;
begin
  OutputDebugString('TGetResList::Destroy'#13#10);
  if Assigned(FGraphic) then
    FreeAndNil(FGraphic);
  FreeAndNil(FFileList);
  inherited;
end;

function TGetResList.GetCommandString(idCmd, uType: UINT;
  pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
var
  strTip: string;
  wstrTip: WideString;
begin
  strTip := '';
  Result := E_INVALIDARG;
  if (uType and GCS_HELPTEXT) <> GCS_HELPTEXT then Exit;
  case idCmd of
    idCopyAnyWhere: strTip := sCopyAnyWhereTip;
    idRegister: strTip := sRegisterTip;
    idUnregister: strTip := sUnregisterTip;
    idImagePreview: strTip := sImagePriviewTip;
  end;
  if strTip <> '' then
  begin
    if (uType and GCS_UNICODE) = 0 then
    begin//Ansi
      lstrcpynA(pszName, PChar(strTip), cchMax);
    end
    else
    begin//Unicode
      wstrTip := strTip;
      lstrcpynW(PWideChar(pszName), PWideChar(wstrTip), cchMax);
    end;
    Result := S_OK;
  end;
end;

function TGetResList.HandleMenuMsg(uMsg: UINT; WParam,
  LParam: Integer): HResult;
var
  Ret: Integer;
begin
  Ret := 0;
  Result := HandleMenuMsg2(uMsg, WParam, LParam, Ret);
end;

function TGetResList.HandleMenuMsg2(uMsg: UINT; wParam, lParam: Integer;
  var lpResult: Integer): HResult;
var
  pmis: PMeasureItemStruct;
  pdis: PDrawItemStruct;
begin
  Result := S_OK;
  case uMsg of
    WM_MEASUREITEM:
      begin
        pmis := PMeasureItemStruct(lParam);
        if not Assigned(FGraphic) then
        begin
          pmis.itemWidth := 120;
          pmis.itemHeight := 120;
          Exit;
        end;
        //如果图片小于120 * 120，则按实际显示，否则缩放到120*120
        if (FGraphic.Width <= 120) and (FGraphic.Height <= 120) then
        begin
          pmis.itemWidth := FGraphic.Width;
          pmis.itemHeight := FGraphic.Height;
        end;
      end;
    WM_DRAWITEM:
      begin
        pdis := PDrawItemStruct(lParam);
        DrawGraphic(pdis.hDC, pdis.rcItem, pdis.itemState, FGraphic);
      end;
  end;
end;

procedure TGetResList.Initialize;
begin
  OutputDebugString('TGetResList::Initialize'#13#10);
  inherited;
  FFileList := TStringList.Create;
  FGraphic := nil; 
end;

function TGetResList.InvokeCommand(
  var lpici: TCMInvokeCommandInfo): HResult;
begin
  Result := E_INVALIDARG;
  if HiWord(Integer(lpici.lpVerb)) <> 0 then Exit;
  case LoWord(Integer(lpici.lpVerb)) of
    idCopyAnyWhere: DoCopyAnyWhere(lpici.hwnd, FFileList);
    idRegister: RegisterActiveLib(lpici.hwnd, FFileList[0]);
    idUnregister: UnregisterActiveLib(lpici.hwnd, FFileList[0]);
    idImagePreview: ExecuteFile(lpici.hwnd, FFileList[0]);
  end;
  Result := NOERROR;
end;

function TGetResList.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
  idCmdLast, uFlags: UINT): HResult;
var
  Added: UINT;
  hbmReg, hbmUnreg: HBITMAP;
begin
  if (uFlags and CMF_DEFAULTONLY) = (CMF_DEFAULTONLY) then
  begin
    Result := Make_HResult(SEVERITY_SUCCESS, FACILITY_NULL, 0);
    Exit;
  end;
  Added := 0;
  //加入CopyAnyWhere菜单项
  InsertMenu(Menu, indexMenu, mfSpearator, 0, nil);
  InsertMenu(Menu, indexMenu, mfString, idCmdFirst + idCopyAnyWhere, PChar(sCopyAnyWhere));
  InsertMenu(Menu, indexMenu, mfSpearator, 0, nil);
  Inc(Added, 3);

  if FFileList.Count = 1 then
  begin//单一文件
    if IsActiveLib(FFileList[0]) then
    begin
      InsertMenu(Menu, indexMenu + Added, mfSpearator, 0, nil);
      InsertMenu(Menu, indexMenu + Added, mfString, idCmdFirst + idUnregister, PChar(sUnregister));
      InsertMenu(Menu, indexMenu + Added, mfString, idCmdFirst + idRegister, PChar(sRegister));
      InsertMenu(Menu, indexMenu + Added, mfSpearator, 0, nil);
      Inc(Added, 4);
      hbmReg := LoadImage(HInstance, MakeIntResource(101), IMAGE_BITMAP, 0, 0, LR_LOADMAP3DCOLORS);
      hbmUnreg := LoadImage(HInstance, MakeIntResource(102), IMAGE_BITMAP, 0, 0, LR_LOADMAP3DCOLORS);
      SetMenuItemBitmaps(Menu, idCmdFirst + idRegister, MF_BYCOMMAND, hbmReg, hbmReg);
      SetMenuItemBitmaps(Menu, idCmdFirst + idUnregister, MF_BYCOMMAND, hbmUnreg, hbmUnreg);
    end;
    if {IsImageFile(FFileList[0])} False then
    begin//图片文件
      FGraphic := ImageFromFile(FFileList[0]);
      if Assigned(FGraphic) then
      begin
        InsertMenu(Menu, indexMenu + Added, mfSpearator, 0, nil);
        InsertMenu(Menu, indexMenu + Added, mfOwnerDraw, idCmdFirst + idImagePreview, nil);
        InsertMenu(Menu, indexMenu + Added, mfSpearator, 0, nil);
        //Inc(Added, 3);
      end;
    end;
  end
  else
    Result := Make_HResult(SEVERITY_SUCCESS, FACILITY_NULL, idMenuRange);

  Result := Make_HResult(SEVERITY_SUCCESS, FACILITY_NULL, idMenuRange);
end;

function TGetResList.SEInitialize(pidlFolder: PItemIDList;
  lpdobj: IDataObject; hKeyProgID: HKEY): HResult;
begin
  Result := GetFileListFromDataObject(lpdobj, FFileList);
end;

initialization
  TComObjectFactory.Create(ComServer, TGetResList, Class_GetResList,
    'GetResList', 'Get Select File List Main Unit', ciMultiInstance, tmApartment);
end.