Crear un "acceso directo"

[dec]

Deben poner ActiveX, ComObj, ShlObj en la clausula uses.


const
IID_IPersistFile: TGUID =
(D1:$0000010B;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

function CrearAccesoDirecto(PathObj, PathLink, Desc: string): boolean;
var
sLink: IShellLink;
PersFile: IPersistFile;
begin
Result := false;
if SUCCEEDED(CoCreateInstance(CLSID_ShellLink, nil,
CLSCTX_INPROC_SERVER, IID_IShellLinkA, sLink)) then
begin
sLink.SetPath(PChar(PathObj));
sLink.SetDescription(PChar(Desc));
if SUCCEEDED(sLink.QueryInterface(IID_IPersistFile, PersFile)) then
begin
PersFile.Save(StringToOLEStr(PathLink), TRUE);
Result := true;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if not CrearAccesoDirecto('command.com',
'c:\mi liga.lnk',
'Este es un Acceso Directo a Command.com') then
//crea mi liga.lnk en el directorio C:\
begin
ShowMessage('No se pudo crear el Acceso Directo');
end;
end;