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.