[opel431]

Не знаю Ваши планы, но я бы решал задачу так вместо завтрака и отдыха после ночной, оставляя Вашу основу:

Unit1.pas

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, XPMan, ShellApi, ShlObj, ActiveX, ComObj,
  ExtCtrls;

type
  TForm1 = class(TForm)
    GroupBox1: TGroupBox;
    XPManifest1: TXPManifest;
    CheckBox1: TCheckBox;
    GroupBox2: TGroupBox;
    Edit1: TEdit;
    Button1: TButton;
    Button2: TButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;

    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  FullFileName, FolderName: string;

implementation

{$R *.dfm}

procedure CreateShortCut(SourceFile, ShortCutName, SourceParams: String);
var
  IUnk: IUnknown;
  ShellLink: IShellLink;
  ShellFile: IPersistFile;
  WideStr: WideString;
  tmpShortCutName: string;
  i: Integer;
begin
  IUnk := CreateComObject(CLSID_ShellLink);
  ShellLink := IUnk as IShellLink;
  ShellFile := IUnk as IPersistFile;

  ShellLink.SetPath(PChar(SourceFile));
  ShellLink.SetArguments(PChar(SourceParams));
  ShellLink.SetWorkingDirectory(PChar(ExtractFilePath(SourceFile)));

  ShortCutName := ChangeFileExt(ShortCutName, '.lnk');
  if fileexists(ShortCutName) then
  begin
    ShortCutName := copy(ShortCutName, 1, length(ShortCutName) - 4);
    i := 1;
    repeat
      tmpShortCutName := ShortCutName + '(' + inttostr(i) + ').lnk';
      inc(i);
    until not fileexists(tmpShortCutName);
    WideStr := tmpShortCutName;
  end
  else
    WideStr := ShortCutName;
  ShellFile.Save(PWideChar(WideStr), False);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  sExt, StrTemp: string;
begin
  OpenDialog1.InitialDir := 'C:\';
  if OpenDialog1.Execute then
  begin
    FullFileName := OpenDialog1.FileName;
    FolderName := ExtractFilePath(FullFileName); // путь к папке источнику
    sExt := ExtractFileExt(FullFileName); // расширение файла источника
    // получаем имя последнего каталога пути к файлу, не весь же путь тащить в имя нового файла
    StrTemp := ChangeFileExt(ExtractFileDir(FullFileName), '');
    while pos('\', StrTemp) > 0 do
      StrTemp := copy(ChangeFileExt(StrTemp, ''), pos('\', StrTemp) + 1,
        length(ChangeFileExt(StrTemp, '')) - pos('\', StrTemp));
    // выводим в поле имя папки + новое имя файла+восстанавливаем расширение
    Edit1.Text := StrTemp + '_NewFile' + sExt;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  Pst: PChar;
  CommDesk, NewName: string;
begin
  // имя файла до или после редактирования в поле
  NewName := Edit1.Text;

  // выбор, а вдруг передумал создавать
  if Application.MessageBox(PChar(FolderName + NewName),
    'Создать новый файл и ярлык', MB_OKCANCEL + MB_ICONQUESTION) = IDOK then
  begin
    // копируем файл с новым именем
    CopyFile(PChar(FullFileName), PChar(FolderName + NewName), False);

    // создаем ярлык
    GetMem(Pst, MAX_PATH + 1);
    try
      SHGetSpecialFolderPath(0, Pst, CSIDL_COMMON_DESKTOPDIRECTORY, False);
      CommDesk := String(Pst);
      CreateShortCut(FolderName + NewName,
        CommDesk + '\' + ExtractFileName(NewName) + '.lnk', '');
    finally
      FreeMem(Pst);
    end;
  end;
end;

end.

.