VPF::Иконка на рабочем столе - Форум программистов

Михалыч

Дата 14.4.2009, 10:27 (ссылка)

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

Загрузка ...

Опытный

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

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

Подскажите как програмно добавить иконку на свою программу на рабочий стол

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

За частый поиск был забанен во всех известных поисковых системах.
Обиженных комодераторов: 1

Данкинг

Дата 14.4.2009, 11:17 (ссылка)

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

Загрузка ...

Yersinia pestis

Профиль
Группа: Завсегдатай
Сообщений: 8302
Регистрация: 7.11.2006
Где: მოსკოვი

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

Код


unit Main;

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
  { Registry key where Folder information is kept }
  SFolderKey = '\Software\Microsoft\Windows\CurrentVersion\' +
    'Explorer\Shell Folders';

function GetFolderLocation(const FolderType: string): string;
{ Retrieves from registry path to folder indicated in FolderType }
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_CURRENT_USER;
    if not OpenKey(SFolderKey, False) then
      { open key where shell folder information is kept. }
      raise ERegistryException.CreateFmt('Folder key "%s" not found',
        [SFolderKey]);
    { Get path for specified folder }
    Result := ReadString(FolderType);
    if Result = '' then
      raise ERegistryException.CreateFmt('"%s" item not found in registry',
        [FolderType]);
    CloseKey;
  finally
    Free;
  end;
end;

procedure MakeNotepad;
const
  // NOTE: Assumed location for Notepad:
  AppName = 'c:\windows\notepad.exe';
var
  SL: IShellLink;
  PF: IPersistFile;
  LnkName: WideString;
begin
  OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
    IShellLink, SL));
  { IShellLink implementers are required to implement IPersistFile }
  PF := SL as IPersistFile;
  OleCheck(SL.SetPath(PChar(AppName))); // set link path to proper file
  { create a path location and filename for link file }
  LnkName := GetFolderLocation('Desktop') + '\' +
    ChangeFileExt(ExtractFileName(AppName), '.lnk');
  PF.Save(PWideChar(LnkName), True); // save link file
end;

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

end.

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

There's nothing left but silent epitaphs.

razsagal

Дата 14.4.2009, 11:50 (ссылка)

(голосов:1)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 29
Регистрация: 23.10.2007
Где: Украина, Днепродз ержинск

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

Код


uses ShlObj, ActiveX, ComObj

function GetSpecialPath(CSIDL: word): string;
var s: string;
begin
  SetLength(s, MAX_PATH);
 if not SHGetSpecialFolderPath(0, PChar(s), CSIDL, true) then
   s := '';
  result := PChar(s);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  showmessage(GetSpecialPath($0000));
end;

procedure CreateShotCut(SourceFile, ShortCutName, SourceParams: String);
var
  IUnk: IUnknown;
  ShellLink: IShellLink;
  ShellFile: IPersistFile;
  tmpShortCutName: string;
  WideStr: WideString;
  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(PWChar(WideStr),False);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  WorkTable:String;
begin
  CreateShotCut(Application.ExeName,
                GetSpecialPath($0000)+'\'+ExtractFileName(Application.ExeName),
                '');
end;

procedure CreateShotCut2(ShortCutName : string);
var
  SL: IShellLink;
  PF: IPersistFile;
  LnkName: WideString;
begin
  OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
    IShellLink, SL));
  { IShellLink implementers are required to implement IPersistFile }
  PF := SL as IPersistFile;
  OleCheck(SL.SetPath(PChar(ShortCutName))); // set link path to proper file
  { create a path location and filename for link file }
  LnkName := GetSpecialPath($0000) + '\' +
    ChangeFileExt(ExtractFileName(ShortCutName), '.lnk');
  PF.Save(PWideChar(LnkName), True); // save link file
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  CreateShotCut2(Application.ExeName);
end;

CreateShotCut - будет пытаться создать ярлык.. пока не создаст
CreateShotCut2 - создает 1 ярлык

з.ы. путь к раб столу можно узнать еще и так

Код


const
  { Registry key where Folder information is kept }
  SFolderKey = '\Software\Microsoft\Windows\CurrentVersion\' +
    'Explorer\Shell Folders';

function GetFolderLocation(const FolderType: string): string;
{ Retrieves from registry path to folder indicated in FolderType }
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_CURRENT_USER;
    if not OpenKey(SFolderKey, False) then
      { open key where shell folder information is kept. }
      raise ERegistryException.CreateFmt('Folder key "%s" not found',
        [SFolderKey]);
    { Get path for specified folder }
    Result := ReadString(FolderType);
    if Result = '' then
      raise ERegistryException.CreateFmt('"%s" item not found in registry',
        [FolderType]);
    CloseKey;
  finally
    Free;
  end;
end;

// вызов
GetFolderLocation('Desktop');

Присоединённый файл ( Кол-во скачиваний: 3 )

Link_Creation.rar 224,68 Kb

razsagal

Дата 14.4.2009, 11:51 (ссылка)

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

Загрузка ...

ах, да. работает только после 98 окна

Это сообщение отредактировал(а) razsagal - 14.4.2009, 11:52

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