Узнать путь на который указывает ссылка

[manas_anarov]

Есть вирус который делает ярлыками папки и файлы, чтобы поупражняться хочу вылечить его. Для этого нада узнать на какой файл указывает ярлык, как сделать это в лазарусе, в делфи это делается так,

Код: Выделить всё

function GetFileNamefromLink(LinkFileName: string): string;
var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  FileInfo: TWin32FINDDATA;
  WidePath: array[0..MAX_PATH] of WideChar;
  Buff: array[0..MAX_PATH] of Char;
begin
  Result := '';
  if (fileexists(Linkfilename) = false) then
    exit;
  MyObject := CreateComObject(CLSID_ShellLink);
  MyPFile := MyObject as IPersistFile;
  MySLink := MyObject as IShellLink;
  StringToWideChar(LinkFileName, WidePath, SizeOf(WidePath));
  MyPFile.Load(WidePath, STGM_READ);
  MySLink.GetPath(Buff, Max_PATH, FileInfo, SLGP_UNCPRIORITY);
  Result := buff;
end;

только лазарус на это ругается.

[Vadim]

только лазарус на это ругается.

Он не на "это" ругается, а на то, что Вы забыли модуль Windows и, наверное, ShlObj подключить.
И было бы хорошо, если бы Вы текст ругательства приводили, а то о чём Вы говорите - совершенно непонятно.

[manas_anarov]

Vadim вот что какой код у меня получился сейчас

Код: Выделить всё

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  zlibfunc, ShlObj, Windows;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation
  const
    CLSID_ShellLink: TGUID = (
      D1: $00021401; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00,
      $46));
  type
  {$EXTERNALSYM _SHITEMID}
    _SHITEMID = record
      cb: Word; { Size of the ID (including cb itself) }
      abID: array[0..0] of Byte; { The item ID (variable length) }
    end;
    TSHItemID = _SHITEMID;
  {$EXTERNALSYM SHITEMID}
    SHITEMID = _SHITEMID;
    PItemIDList = ^TItemIDList;
  {$EXTERNALSYM _ITEMIDLIST}
    _ITEMIDLIST = record
      mkid: TSHItemID;
    end;
    TItemIDList = _ITEMIDLIST;
  {$EXTERNALSYM IShellLinkA}
    IShellLinkA = interface(IUnknown) { sl }
      ['{000214EE-0000-0000-C000-000000000046}']
      function GetPath(pszFile: PAnsiChar; cchMaxPath: Integer;
        var pfd: TWin32FindData; fFlags: DWORD): HResult; stdcall;
      function GetIDList(var ppidl: PItemIDList): HResult; stdcall;
      function SetIDList(pidl: PItemIDList): HResult; stdcall;
      function GetDescription(pszName: PAnsiChar; cchMaxName: Integer): HResult;
        stdcall;
      function SetDescription(pszName: PAnsiChar): HResult; stdcall;
      function GetWorkingDirectory(pszDir: PAnsiChar; cchMaxPath: Integer):
        HResult; stdcall;
      function SetWorkingDirectory(pszDir: PAnsiChar): HResult; stdcall;
      function GetArguments(pszArgs: PAnsiChar; cchMaxPath: Integer): HResult;
        stdcall;
      function SetArguments(pszArgs: PAnsiChar): HResult; stdcall;
      function GetHotkey(var pwHotkey: Word): HResult; stdcall;
      function SetHotkey(wHotkey: Word): HResult; stdcall;
      function GetShowCmd(out piShowCmd: Integer): HResult; stdcall;
      function SetShowCmd(iShowCmd: Integer): HResult; stdcall;
      function GetIconLocation(pszIconPath: PAnsiChar; cchIconPath: Integer;
        out piIcon: Integer): HResult; stdcall;
      function SetIconLocation(pszIconPath: PAnsiChar; iIcon: Integer): HResult;
        stdcall;
      function SetRelativePath(pszPathRel: PAnsiChar; dwReserved: DWORD): HResult;
        stdcall;
      function Resolve(Wnd: HWND; fFlags: DWORD): HResult; stdcall;
      function SetPath(pszFile: PAnsiChar): HResult; stdcall;
    end;
  {$EXTERNALSYM IShellLink}
    IShellLink = IShellLinkA;
    /////////////////////////////////// End of cuts from ShlObj

    /////////////////////////////////// cuts from ActiveX
  type
  {$EXTERNALSYM IPersist}
    IPersist = interface(IUnknown)
      ['{0000010C-0000-0000-C000-000000000046}']
      function GetClassID(out classID: TGUID): HResult; stdcall;
    end;
  {$EXTERNALSYM IPersistFile}
    IPersistFile = interface(IPersist)
      ['{0000010B-0000-0000-C000-000000000046}']
      function IsDirty: HResult; stdcall;
      function Load(pszFileName: PWideChar; dwMode: Longint): HResult;
        stdcall;
      function Save(pszFileName: PWideChar; fRemember: BOOL): HResult;
        stdcall;
      function SaveCompleted(pszFileName: PWideChar): HResult;
        stdcall;
      function GetCurFile(out pszFileName: PWideChar): HResult;
        stdcall;
    end;
{$R *.lfm}

{ TForm1 }

function GetFileNamefromLink(LinkFileName: string): string;
var
  MyObject: IUnknown;
  MySLink: IShellLink;
 MyPFile: IPersistFile;
  FileInfo: TWin32FINDDATA;
  WidePath: array[0..MAX_PATH] of WideChar;
  Buff: array[0..MAX_PATH] of Char;
begin
  Result := '';
  if (fileexists(Linkfilename) = false) then
    exit;
  MyObject := CreateComObject(CLSID_ShellLink);
  MyPFile := MyObject as IPersistFile;
  MySLink := MyObject as IShellLink;
  StringToWideChar(LinkFileName, WidePath, SizeOf(WidePath));
  MyPFile.Load(WidePath, STGM_READ);
  MySLink.GetPath(Buff, Max_PATH, FileInfo, SLGP_UNCPRIORITY);
  Result := buff;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
    
end;

end.

почему код стал таким большим? до этого лазарус не знал что такое IPersistFile, я в гугле нашел статью и прикрутил их код к себе эти статьи касались IPersistFile, теперь лазарь выдает другие ошибки.

Код: Выделить всё

unit1.pas(116,30) Error: Identifier not found "CreateComObject"
unit1.pas(120,35) Error: Identifier not found "STGM_READ"
unit1.pas(121,43) Hint: Local variable "FileInfo" does not seem to be initialized
unit1.pas(131) Fatal: There were 2 errors compiling module, stopping

[Vadim]

CreateComObject находится в модуле ComObj.
STGM_READ находится в модуле ActiveX.

почему код стал таким большим?

Потому что Вы в свой код занесли то, что уже объявлено в тех модулях, о которых я Вам написал выше.

[manas_anarov]

Спасибо за ответ пример заработал, убрал лишнее, добавил те 2 модуля которые вы посоветовали, тему можно закрывать. вот исходник заработавшей программы

Код: Выделить всё

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls
  ,ShlObj, Windows,ComObj,ActiveX;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }
function GetFileNamefromLink(LinkFileName: string): string;
var
  MyObject: IUnknown;
  MySLink: IShellLink;
MyPFile: IPersistFile;
  FileInfo: TWin32FINDDATA;
  WidePath: array[0..MAX_PATH] of WideChar;
  Buff: array[0..MAX_PATH] of Char;
begin
  Result := '';
  if (fileexists(Linkfilename) = false) then
    exit;
  MyObject := CreateComObject(CLSID_ShellLink);
  MyPFile := MyObject as IPersistFile;
  MySLink := MyObject as IShellLink;
  StringToWideChar(LinkFileName, WidePath, SizeOf(WidePath));
  MyPFile.Load(WidePath, STGM_READ);
  MySLink.GetPath(Buff, Max_PATH, FileInfo, SLGP_UNCPRIORITY);
  Result := buff;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  res:string;
  GetFileName:string;
begin
   GetFileName:= 'E:\text.lnk';
   res:=GetFileNamefromLink(GetFileName);
   ShowMessage(res);
end;

end.