Перевести код с Delphi и улучшить

Вопросы программирования и использования среды Lazarus.

Модератор: Модераторы

Перевести код с Delphi и улучшить

Сообщение BadBoyAlex » 10.05.2018 09:11:10

Здравствуйте, уважаемые форумчане! Имею работающий код Delphi, который создаёт пункт моей программы в системном контекстном меню. Его нужно как-то преобразовать, чтобы компилерся с помощью Lazarus 1.8.2. И хотелось бы несколько улучшить следующим:
  • добавить иконку;
  • добавить в верхнюю часть меню (а не под конец, как сейчас!);
  • добавить с несколькими пунктами во вложении;
  • отображать только для конкретных типов файлов (например, *.doc, *.pdf, ...).
Подскажите, пожалуйста, куда и как копать. Заранее всем огромное спасибо!


Код: Выделить всё
unit ShellUnit;
interface
uses Windows, Forms, StdCtrls, ShellApi, SysUtils, Classes, Controls, ComServ, ComObj, ShlObj, ActiveX, Dialogs, TlHelp32;
const CLSID_ContextMenu: TGUID = '{F68D582B-A418-4707-8607-85C1BDB7E996}';
type
  TFormViewContextMenu = class(TComObject, IShellExtInit, IContextMenu)
   private
    FFileName: string;
   public
    function IShellExtInit.Initialize = ShellInit;
    function ShellInit(Folder: PItemIDList; DataObject: IDataObject; ProgID: HKEY): HResult; stdcall;
    function QueryContextMenu(Menu: HMENU; Index, CmdFirst, CmdLast, Flags: UINT): HResult; stdcall;
    function GetCommandString(idCmd: UINT_PTR; uFlags: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult; stdcall;
    function InvokeCommand(var CommandInfo: TCMInvokeCommandInfo): HResult; stdcall;
   end;
implementation
uses Registry, INIFiles;
{Get sfp installed path...}
function SFPPath: string;
var Reg: TRegistry;
begin
Reg:= TRegistry.Create(KEY_READ);
with Reg do
begin
RootKey:= HKEY_LOCAL_MACHINE;
if OpenKeyReadOnly('Software\ANB\SFP_SHELL\') then
  Result:= IncludeTrailingBackslash(ReadString('sfp_dir'))
  else
  Result:= 'C:\Program Files\ANB\SFP\';
CloseKey;
end;
end;
{lang}
function GetLocalStr(const AMsgName: string): string;
var INI: TIniFile;
begin
INI:= TIniFile.Create(SFPPath + 'Languages\system.lng');
with INI do
begin
Result:= ReadString(IntToStr(GetSystemDefaultLangID), AMsgName, '<ERROR READING LOCAL STR!>');
Free;
end;
end;
{Shell}
function TFormViewContextMenu.ShellInit(Folder: PItemIDList; DataObject: IDataObject; ProgID: HKEY): HResult;
var Medium: TStgMedium;
    FE: TFormatEtc;
begin
if DataObject = nil then
begin
Result:= E_FAIL;
Exit;
end;
with FE do
begin
cfFormat:= CF_HDROP;
ptd:= nil;
dwAspect:= DVASPECT_CONTENT;
lindex:= -1;
tymed:= TYMED_HGLOBAL;
end;
Result:= DataObject.GetData(FE, Medium);
if Failed(Result) then
Exit;
try
if DragQueryFile(Medium.hGlobal, $FFFFFFFF, nil, 0) = 1 then
  begin
  SetLength(FFileName, MAX_PATH);
  DragQueryFile(Medium.hGlobal, 0, PChar(FFileName), MAX_PATH);
  Result:= NOERROR;
  end
  else
  Result:= E_FAIL;
finally
  ReleaseStgMedium(Medium);
end;
end;
function TFormViewContextMenu.QueryContextMenu(Menu: HMENU; Index, CmdFirst, CmdLast, Flags: UINT): HResult;
begin
Result:= 0;
if ((Flags and $0000000F) = CMF_NORMAL) or ((Flags and CMF_EXPLORE) <> 0) or ((Flags and CMF_VERBSONLY) <> 0) then
begin
InsertMenu(Menu, 0, MF_STRING or MF_BYPOSITION, CmdFirst, PChar(GetLocalStr('shell_open')));
Result:= 1;
end;
end;
function TFormViewContextMenu.GetCommandString(idCmd: UINT_PTR; uFlags: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult; stdcall;
begin
case idCmd of
0: begin
    if uFlags = GCS_HELPTEXT then
     begin
     StrCopy(pszName, '');
     end;
     Result:= NOERROR;
     end;
else
Result:= E_INVALIDARG;
end;
end;
function TFormViewContextMenu.InvokeCommand(var CommandInfo: TCMInvokeCommandInfo): HResult;
begin
if HiWord(Integer(CommandInfo.lpVerb)) <> 0 then
begin
Result:= E_FAIL;
Exit;
end;
case LoWord(CommandInfo.lpVerb) of
0: ShellExecute(0, 'open', pchar(SFPPath + 'tools\sfp_shell\sfp_shell_gui.exe'), pchar('/fn="' + FFileName + '"'), pchar(SFPPath), SW_SHOWNORMAL);
else
Result:= E_INVALIDARG;
end;
end;
initialization
TComObjectFactory.Create(ComServer, TFormViewContextMenu, CLSID_ContextMenu, '', '', ciMultiInstance);
end.
Аватара пользователя
BadBoyAlex
постоялец
 
Сообщения: 119
Зарегистрирован: 08.06.2010 12:42:23
Откуда: Россия, Белгород

Re: Перевести код с Delphi и улучшить

Сообщение Alex2013 » 13.05.2018 11:34:45

Для начала попробуй штатный транслятор ... :idea:
Лазарус -> меню Сервис - преобразовать проект Delpi в проект Лазарус...
Не могу сказать что 100%-тов проектов СРАЗУ после преобразования работает но автоматическая конверсия сильно упрощает перенос проектов .
Зы
По опыту рекомендую не заморачиваться с отдельной конверсией модуля! (надежнее сразу конвертировать тестовый проект(где по возможности убрано все лишнее ) целиком)
Alex2013
долгожитель
 
Сообщения: 2923
Зарегистрирован: 03.04.2013 11:59:44

Re: Перевести код с Delphi и улучшить

Сообщение BadBoyAlex » 13.05.2018 11:53:51

Alex2013, не работает. Уже пробовал. Не возможно преобразовать из-за отсутствия пакета TIHelp32.

upd: Полазил в нете, нашёл юнит JwaTlHelp32, но с ним такая вот байда:

ShellUnit.pas(9,24) Error: No matching implementation for interface method "InvokeCommand(var TCMINVOKECOMMANDINFO):LongInt; StdCall;" found
Аватара пользователя
BadBoyAlex
постоялец
 
Сообщения: 119
Зарегистрирован: 08.06.2010 12:42:23
Откуда: Россия, Белгород

Re: Перевести код с Delphi и улучшить

Сообщение wofs » 13.05.2018 13:48:51

Аватара пользователя
wofs
постоялец
 
Сообщения: 379
Зарегистрирован: 05.10.2009 10:16:55
Откуда: Астрахань

Re: Перевести код с Delphi и улучшить

Сообщение BadBoyAlex » 13.05.2018 14:50:17


Ошибка:
ShellUnit.pas(9,26) Error: No matching implementation for interface method "InvokeCommand(var TCMINVOKECOMMANDINFO):LongInt; StdCall;" found
Аватара пользователя
BadBoyAlex
постоялец
 
Сообщения: 119
Зарегистрирован: 08.06.2010 12:42:23
Откуда: Россия, Белгород

Re: Перевести код с Delphi и улучшить

Сообщение wofs » 13.05.2018 21:36:43

BadBoyAlex писал(а):Ошибка:

У меня все собралось на 1.8.2 и транке.
Код: Выделить всё
Компиляция проекта, цель: project1.exe: Успешно, предупреждений: 2, подсказок: 7
ShellUnit.pas(16,24) Hint: Parameter "Folder" not used
ShellUnit.pas(16,70) Hint: Parameter "ProgID" not used
ShellUnit.pas(17,44) Hint: Parameter "Index" not used
ShellUnit.pas(17,61) Hint: Parameter "CmdLast" not used
ShellUnit.pas(18,62) Hint: Parameter "pwReserved" not used
ShellUnit.pas(18,97) Hint: Parameter "cchMax" not used
ShellUnit.pas(108,11) Warning: Conversion between ordinals and pointers is not portable
ShellUnit.pas(113,13) Warning: Conversion between ordinals and pointers is not portable
ShellUnit.pas(8,114) Hint: Unit "TLHelp32" not used in ShellUnit

Работоспособность не проверял.
С тестовым проектом было бы гораздо лучше проверять...

И да, судя по сообщениям компилятора TLHelp32 не используется ShellUnit, хотя я и положил его в корень...
У вас нет необходимых прав для просмотра вложений в этом сообщении.
Аватара пользователя
wofs
постоялец
 
Сообщения: 379
Зарегистрирован: 05.10.2009 10:16:55
Откуда: Астрахань

Re: Перевести код с Delphi и улучшить

Сообщение BadBoyAlex » 13.05.2018 21:51:24

Как ни странно, но ваш код у меня завёлся. Осталось только в главном модуле DLL-ки подключить модуль Interfaces...

Осталось только улучшить, чтобы
  • добавить иконку;
  • добавить в верхнюю часть меню (а не под конец, как сейчас!);
  • добавить с несколькими пунктами во вложении;
  • отображать только для конкретных типов файлов (например, *.doc, *.pdf, ...).
Куда копать ума не приложу...
Аватара пользователя
BadBoyAlex
постоялец
 
Сообщения: 119
Зарегистрирован: 08.06.2010 12:42:23
Откуда: Россия, Белгород

Re: Перевести код с Delphi и улучшить

Сообщение Vadim » 14.05.2018 07:21:06

BadBoyAlex писал(а):ShellUnit.pas(9,24) Error: No matching implementation for interface method "InvokeCommand(var TCMINVOKECOMMANDINFO):LongInt; StdCall;" found

Этот метод (совместно с интерфейсом, естественно) оперделён в shlobj.
Vadim
долгожитель
 
Сообщения: 4112
Зарегистрирован: 05.10.2006 08:52:59
Откуда: Красноярск


Вернуться в Lazarus

Кто сейчас на конференции

Сейчас этот форум просматривают: Yandex [Bot] и гости: 36

Рейтинг@Mail.ru