unit ULink;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ComCtrls, AppEvnts;

type
  TForm1 = class(TForm)
    GroupBox1: TGroupBox;
    BCreate: TButton;
    OpenDialog1: TOpenDialog;
    Edit1: TEdit;
    BFindFile: TButton;
    BFindFolder: TButton;
    Edit2: TEdit;
    RadioGroup1: TRadioGroup;
    Label1: TLabel;
    Label2: TLabel;
    OpenDialog2: TOpenDialog;
    GroupBox2: TGroupBox;
    Edit3: TEdit;
    BInf: TButton;
    BFindLnk: TButton;
    RichEdit1: TRichEdit;
    Label3: TLabel;
    ApplicationEvents1: TApplicationEvents;
    BFindFolder2: TButton;
    Edit4: TEdit;
    Label4: TLabel;
    procedure BCreateClick(Sender: TObject);
    procedure BFindFileClick(Sender: TObject);
    procedure BInfClick(Sender: TObject);
    procedure BFindLnkClick(Sender: TObject);
    procedure BFindFolderClick(Sender: TObject);
    procedure ApplicationEvents1ShowHint(var HintStr: String;
      var CanShow: Boolean; var HintInfo: THintInfo);
    procedure BFindFolder2Click(Sender: TObject);
  private
    { Private declarations }
    procedure InfLink(const Path: string);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
uses ShlObj, ComObj, ActiveX, Menus, FileCtrl;

procedure CreateLink(const PathObj, WorkDir, PathLink, Description, Arguments: string;
                     ShowCmd: Integer);
var NewLink: IShellLink;
begin
 NewLink := CreateComObject(CLSID_ShellLink) as IShellLink;
 with NewLink do
 begin
  SetPath(PChar(PathObj));
  SetWorkingDirectory(PChar(WorkDir));
  SetDescription(PChar(Description));
  SetArguments(PChar(Arguments));
  SetShowCmd(ShowCmd);
 end;
 (NewLink as IPersistFile).Save(PWChar(WideString(PathLink)), false);
end;

procedure TForm1.InfLink(const Path: string);
var Link: IShellLink;
    S: array[0..255] of char;
    pfd: TWin32FindData;
    fFlags: DWord;
    Hotkey: Word;
    ShowCmd: integer;
begin
 Link := CreateComObject(CLSID_ShellLink) as IShellLink;
 if ((Link as IPersistFile).Load(PWChar(WideString(Path)), 0) = S_OK )
 then begin
  RichEdit1.Clear;
  with Link do with RichEdit1.Lines do
  begin
   Add('Ярлык - ' + Path);
   GetPath(S, 256, pfd, fFlags);
   Add('Связан с объектом - ' + S);
   GetDescription(S, 256);
   Add('Описание - ' + S);
   GetWorkingDirectory(S, 256);
   Add('Рабочий каталог - ' + S);
   GetArguments(S, 256);
   if S = ''
    then Add('Аргументы отсутствуют')
    else Add('Аргументы - ' + S);
   GetHotkey(Hotkey);
   if Hotkey = 0
    then Add('Горячие клавиши не назначены')
    else Add('Горячие клавиши ' + ShortCutToText(Hotkey));
   GetShowCmd(ShowCmd);
   case ShowCmd of
    SW_SHOWNORMAL: Add('Обычный размер окна');
    SW_MAXIMIZE: Add('Окно развертывается на весь экран');
    SW_MINIMIZE: Add('Окно свертывается в значок');
   end;
  end;
 end;
end;

procedure TForm1.BCreateClick(Sender: TObject);
var PathObj, WorkDir, PathLink, Description: string;
    ShowCmd: Integer;
begin
 PathObj := Trim(Edit1.Text);
 if PathObj = ''
  then PathObj := ParamStr(0);
 WorkDir := ExtractFilePath(PathObj);
 PathLink := Trim(Edit4.Text);
 if (PathLink <> '') and(PathLink[Length(PathLink)] <> '\')
  then PathLink := PathLink + '\';
 PathLink := PathLink + ExtractFileName(PathObj)+ '.lnk';
 Description := Trim(Edit2.Text);
 if Description = ''
  then Description := 'ярлык ' + ExtractFileName(PathObj);
 case RadioGroup1.ItemIndex of
  0: ShowCmd := SW_SHOWNORMAL;
  1: ShowCmd := SW_SHOWMINNOACTIVE;
  2: ShowCmd := SW_SHOWMAXIMIZED;
 end;
 CreateLink(PathObj, WorkDir, PathLink, Description, '', ShowCmd);
end;

procedure TForm1.BFindFileClick(Sender: TObject);
begin
 if OpenDialog1.Execute
  then begin
   Edit1.Text := OpenDialog1.FileName;
   Edit2.Text := 'ярлык ' + ExtractFileName(Edit1.Text);
  end;
end;

procedure TForm1.BInfClick(Sender: TObject);
begin
 InfLink(Edit3.Text);
end;

procedure TForm1.BFindLnkClick(Sender: TObject);
begin
  if OpenDialog2.Execute
  then Edit3.Text := OpenDialog2.FileName;
end;

procedure TForm1.BFindFolderClick(Sender: TObject);
var Dir: string;
begin
 if SelectDirectory('Выберите папку, для которой создаете ярлык', '', Dir)
  then begin
   Edit1.Text := Dir;
   Edit2.Text := 'ярлык ' + Dir;
  end;
end;

procedure TForm1.ApplicationEvents1ShowHint(var HintStr: String;
  var CanShow: Boolean; var HintInfo: THintInfo);
begin
if (HintInfo.HintControl.ClassName = 'TEdit')
  then if (Label1.Canvas.TextWidth(
              (HintInfo.HintControl as TEdit).Text) >
              (HintInfo.HintControl as TEdit).ClientWidth)
  then begin
    HintStr:=(HintInfo.HintControl as TEdit).Text;
    ApplicationEvents1.CancelDispatch;
  end;
end;

procedure TForm1.BFindFolder2Click(Sender: TObject);
var Dir: string;
begin
 if SelectDirectory('Выберите папку, в которую надо поместить ярлых', '', Dir)
  then Edit4.Text := Dir;
end;

end.
