VPF::Как создать ярлык на рабочем столе?

Black_Joker

Дата 21.1.2006, 17:14 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 212
Регистрация: 9.11.2002
Где: Таганрог

Репутация: нет
Всего: нет

Как создать ярлык на рабочем столе?

Guedda

Дата 21.1.2006, 17:21 (ссылка)

(нет голосов)

Загрузка ...

Подрывник

Профиль
Группа: Завсегдатай
Сообщений: 3137
Регистрация: 27.12.2005
Где: Ростов-на-Дону

Репутация: нет
Всего: 78

Код


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses ComObj, ActiveX, ShlObj, Registry;

const
  SFolderKey = '\Software\Microsoft\Windows\CurrentVersion\' +
    'Explorer\Shell Folders';

function GetFolderLocation(const FolderType: string): string;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_CURRENT_USER;
    if not OpenKey(SFolderKey, False) then
      raise ERegistryException.CreateFmt('Folder key "%s" not found',
        [SFolderKey]);
    Result := ReadString(FolderType);
    if Result = '' then
      raise ERegistryException.CreateFmt('"%s" item not found in registry',
        [FolderType]);
    CloseKey;
  finally
    Free;
  end;
end;

procedure MakeLink;
const
  AppName = 'c:\yourprog.exe'; //твоя программа
var
  SL: IShellLink;
  PF: IPersistFile;
  LnkName: WideString;
begin
  OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
    IShellLink, SL));
  PF := SL as IPersistFile;
  OleCheck(SL.SetPath(PChar(AppName)));
  LnkName := GetFolderLocation('Desktop') + '\' +
    ChangeFileExt(ExtractFileName(AppName), '.lnk');
  PF.Save(PWideChar(LnkName), True);
end;

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

end.

Это сообщение отредактировал(а) Guedda - 21.1.2006, 17:23

--------------------

Ll 2

Max111

Дата 22.1.2006, 20:03 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 28
Регистрация: 18.1.2006

Репутация: нет
Всего: нет

Доброе утро

1)

Код


uses
  ShlObj, ComObj, ActiveX;

procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
var
  IObject: IUnknown;
  SLink: IShellLink;
  PFile: IPersistFile;
begin
  IObject := CreateComObject(CLSID_ShellLink);
  SLink := IObject as IShellLink;
  PFile := IObject as IPersistFile;
  with SLink do
  begin
    SetArguments(PChar(Param));
    SetDescription(PChar(Desc));
    SetPath(PChar(PathObj));
  end;
  PFile.Save(PWChar(WideString(PathLink)), FALSE);
end;

Код


uses...ShlObj, ComObj, ActiveX, shellapi, ComCtrls

procedure SetShortCut(path, cmd, icon, wd, name, arg: string);
var
  ShellObject: IUnknown;
  LinkFile: IPersistFile;
  ShellLink: IShellLink;
begin
  try
    CoInitialize(nil);
    ShellObject := CreateComObject(CLSID_ShellLink);
    LinkFile := ShellObject as IPersistFile;
    ShellLink := ShellObject as IShellLink;
    ShellLink.SetPath(@cmd[1]);
    ShellLink.SetWorkingDirectory(@wd[1]);
    ShellLink.SetIconLocation(@icon[1], 0);
    ShellLink.SetDescription(@name[1]);
    ShellLink.SetArguments(@arg[1]);
    LinkFile.Save(PWChar(WideString(path)), true);
  finally
    ShellObject := Unassigned;
    CoUninitialize;
  end;
end;

Код


function CreateShortcut(const CmdLine, Args, WorkDir, LinkFile: string):
  IPersistFile;
var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  WideFile: WideString;
begin
  MyObject := CreateComObject(CLSID_ShellLink);
  MySLink := MyObject as IShellLink;
  MyPFile := MyObject as IPersistFile;
  with MySLink do
  begin
    SetPath(PChar(CmdLine));
    SetArguments(PChar(Args));
    SetWorkingDirectory(PChar(WorkDir));
  end;
  WideFile := LinkFile;
  MyPFile.Save(PWChar(WideFile), False);
  Result := MyPFile;
end;

procedure CreateShortcuts;
var
  Directory, ExecDir: string;
  MyReg: TRegIniFile;
begin
  MyReg := TRegIniFile.Create(
    'Software\MicroSoft\Windows\CurrentVersion\Explorer');

  ExecDir := ExtractFilePath(ParamStr(0));
  Directory := MyReg.ReadString('Shell Folders', 'Programs', '') + '\' +
    ProgramMenu;

  CreateDir(Directory);
  MyReg.Free;

  CreateShortcut(ExecDir + 'Autorun.exe', '', ExecDir,
    Directory + '\Demonstration.lnk');
  CreateShortcut(ExecDir + 'Readme.txt', '', ExecDir,
    Directory + '\Installation notes.lnk');
  CreateShortcut(ExecDir + 'WinSys\ivi_nt95.exe', '', ExecDir,
    Directory + '\Install Intel Video Interactive.lnk');
end;

Guedda

Дата 22.1.2006, 20:07 (ссылка)

(нет голосов)

Загрузка ...

Подрывник

Профиль
Группа: Завсегдатай
Сообщений: 3137
Регистрация: 27.12.2005
Где: Ростов-на-Дону

Репутация: нет
Всего: 78

А не можешь все это в "код" занести?
Читабельней будет, однако...

--------------------

Ll 2

MIX55

Дата 22.1.2006, 20:16 (ссылка)

(нет голосов)

Загрузка ...

много работы

Профиль
Группа: Awaiting Authorisation
Сообщений: 208
Регистрация: 23.10.2005
Где: Здесь

Репутация: нет
Всего: 4

1.Зависимости: shlObj, activeX, SysUtils, filectrl, comObj, UBPFD.ExtractFileNameEX

Код


function CreateLink(FileName, DestDirectory: string; OverwriteExisting,
  AddNumberIfExists: Boolean): string;

var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  WFileName: WideString;
  X: INTEGER;
begin
  //Изначально RESULT = ''
  Result := '';
  //Если фиайла, для которого создаётся ярлык не существует, или же не
  // существует директории, где должен быть создан ярлык файла, то EXIT
  if (FileExists(FileName) = FALSE) or (DirectoryExists(DestDirectory) = FALSE)
    then
    exit;
  MyObject := CreateComObject(CLSID_SHELLLINK);
  MyPFile := MyObject as IPersistFile;
  MySLink := MyObject as IShellLink;
  with MySLink do
  begin
    SetArguments('');
    SetPath(PChar(FileName));
    SetWorkingDirectory(PChar(ExtractFilePath(FileName)));
  end;

  //Гарантирование проставление завершающего '\' в пути директории
  //расположения создаваемого ярлыка
  if DestDirectory[length(DestDirectory)] <> '\' then
    DestDirectory := DestDirectory + '\';
  // Первичное определене будующего имени ярлыка
  WFileName := DestDirectory + ExtractFileNameEx(FileName, FALSE) + '.lnk';
  //Если ярлык с таким именем уже существует, то
  if (FileExists(WFileName)) then
  begin
    // Если не надо переписывать существующий ярлык, а надо добавить
    // порядковый номер существования к имени создаваемого ярлыка, например
    // blobby1.lnk, blobby2.lnk
    if (OverwriteExisting = FALSE) and (AddNumberIfExists = TRUE) then
    begin
      // Определяем какой именно порядковый номер надо добавить к
      // имени ярлыка
      X := 0;
      repeat
        X := X + 1;
        WFileName := DestDirectory + ExtractFileNameEx(FileName, FALSE)
          + IntToStr(X) + '.lnk';
      until FileExists(WFileName) = FALSE;
      // И сохраняем ярлык
      MyPFile.Save(PWChar(WFileName), FALSE);
      Result := WFileName;
    end;
    //Если надо переписывать существующий ярлык
    if OverwriteExisting = TRUE then
    begin
      //..., то переписываем его :)
      MyPFile.Save(PWChar(WFileName), FALSE);
      Result := WFileName;
    end;
  end
  else
  begin
    //В случае, если ярлыка с подобным имененм ещё нет в папке
    //назначения, то создаём ярлык
    MyPFile.Save(PWChar(WFileName), FALSE);
    Result := WFileName;
  end;
end;

2.Зависимости: ShlObj, ActiveX, ComObj

Код


procedure CreateShortcut(const FilePath, ShortcutPath,
  WorkDir, Description, Params: string);
var
  obj: IUnknown;
  isl: IShellLink;
  ipf: IPersistFile;
begin
  obj := CreateComObject(CLSID_ShellLink);
  isl := obj as IShellLink;
  ipf := obj as IPersistFile;
  with isl do
  begin
    SetPath(PChar(FilePath));
    SetArguments(PChar(Params));
    SetDescription(PChar(Description));
    SetWorkingDirectory(PChar(WorkDir));
  end;
  ipf.Save(PWChar(WideString(ShortcutPath)), False);
end;
Пример использования: 

// пример создания ярлыка на рабочем столе
var
  UserDesktop: string;
  R: TRegIniFile;
begin
  R := TRegIniFile.Create('');
  with R do
  begin
    RootKey := HKEY_CURRENT_USER;
    UserDesktop :=
      ReadString('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',
      'desktop', '');
    Free;
  end;

  CreateShortcut(Application.ExeName, UserDesktop +
    '\Название ярлыка.lnk', '', '', '');
end;

--------------------

Hарод, а как в дельфи писать паскалевские проги....?*********************************************Жизнь слишком коротка, чтобы писать на Assembler'e

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: ActiveX/СОМ/CORBA \| Следующая тема »