Contributor: RADEK VOLTR
This is last source code for my ShellLink component.
//******************************************************* //*
Shell Link Component for Delphi 2.0 * //*
* //* this is end version
* //*
* //* for new versions send e-mail,s-mail,fax * //*
with you name and e-mail adress to> * //*
* //*
voltr.radek/4600/epr@epr1.ccmail.x400.cez.cz * //*
* //* (c) 1996 Radek Voltr
* //* Kozeluzska 1523
* //* Kadan 43201 CZECH Republic Europe *
//* fax. 42 398 2776 * //*
note: this version is free *
//*******************************************************
unit SheLink;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Ole2;
const
SLR_NO_UI = _0001;
SLR_ANY_MATCH = _0002;
SLR_UPDATE = _0004;
SLGP_SHORTPATH = _0001;
SLGP_UNCPRIORITY = _0002;
CLSID_ShellLink: TCLSID = (D1:_00021401; D2:_0; D3:_0;
D4:(_C0,_0,_0,_0,_0,_0,_0,_46));
IID_IShellLink: TCLSID = (D1:_000214EE; D2:_0; D3:_0;
D4:(_C0,_0,_0,_0,_0,_0,_0,_46));
type
PShellLink = ^IShellLink;
IShellLink = class(IUnknown)
public
Function GetPath(pszFile:PChar;cchMaxPath:Integer;var
pfd:TWin32FindData;fFlags:DWord):HResult; virtual; stdcall; abstract;
Function GetIDList(ppidl:pointer) :HResult; virtual; stdcall;
abstract; Function SetIDList(const pidl:pointer) :HResult; virtual;
stdcall; abstract; Function
GetDescription(pszName:PChar;cchMaxName:Integer) :HResult; virtual;
stdcall; abstract;
Function SetDescription(Const pszName:PChar) :HResult; virtual;
stdcall;
abstract;
Function GetWorkingDirectory(pszDir:PChar;cchMaxPath:Integer)
:HResult;
virtual; stdcall; abstract;
Function SetWorkingDirectory(const pszDir:PChar) :HResult; virtual;
stdcall;
abstract;
Function GetArguments(pszDir:PChar;cchMaxPath:Integer) :HResult;
virtual;
stdcall; abstract;
Function SetArguments(const pszArgs:PChar) :HResult; virtual; stdcall;
abstract;
Function GetHotkey(pwHotkey:PWord) :HResult; virtual; stdcall;
abstract; Function SetHotkey(wHotkey:Word) :HResult; virtual; stdcall;
abstract; Function GetShowCmd(piShowCmd:PInteger) :HResult; virtual;
stdcall;
abstract;
Function SetShowCmd(iShowCmd:Integer) :HResult; virtual; stdcall;
abstract; Function
GetIconLocation(pszIconPath:PChar;cchIconPath:Integer;piIcon:PInteger)
:HResult; virtual; stdcall; abstract;
Function SetIconLocation(const pszIconPath:PChar;iIcon:Integer)
:HResult;
virtual; stdcall; abstract;
Function SetRelativePath(const pszPathRel:PChar;dwReserved:Dword)
:HResult;
virtual; stdcall; abstract;
Function Resolve(wnd:hWnd;fFlags:Dword) :HResult; virtual; stdcall;
abstract;
Function SetPath(Const pszFile:PChar) :HResult; virtual; stdcall;
abstract;
end;
type
TShellLink = class(TComponent)
private
{ Private declarations }
procedure fSetSelfPath(const S:String); protected
{ Protected declarations }
fUpdate:Boolean;
fPath,
fTarget,
fWorkingDir,
fDescription,
fArguments,
fIconLocation:String;
fIconNumber,
fShowCmd,
fHotKey:Word;
public
{ Public declarations }
// constructor Create;
procedure SetSelfPath(const S:String); procedure SetUpdate(const
S:Boolean); procedure CreateNew(const Path,Target:String); procedure
SaveToFile(const Path:String);
published
{ Published declarations }
property Path:String read fPath write fSetSelfPath; property
Target:String read fTarget write fTarget;
property WorkingDir:String read fWorkingDir write fWorkingDir;
property Description:String read fDescription write fDescription;
property Arguments:String read fArguments write fArguments;
property IconLocation:String read fIconLocation write fIconLocation;
property HotKey:word read fHotKey write fHotKey;
property ShowCmd:word read fShowCmd write fShowCmd;
property IconNumber:word read fIconNumber write fIconNumber; property
Update:boolean read fUpdate write SetUpdate;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Win95', [TShellLink]); end;
procedure TShellLink.SetSelfPath(const S:String); var X3:PChar;
hresx:HResult;
Psl:IShellLink;
Ppf:IPersistFile;
Saver:Array [0..Max_Path] of WideChar; X1:Array [0..255] Of Char;
Data:TWin32FindData;I,Y:INteger;W:Word;
begin
hresx:=CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,IID_I
ShellLink, psl);
If hresx0 then Exit;
hresx:=psl.QueryInterface(IID_IPersistFile,ppf); If hresx0 then
Exit;
X3:=StrAlloc(255);
StrPCopy(X3,S);
MultiByteToWideChar(CP_ACP,0,X3,-1,Saver,Max_Path);
hresx:=ppf.Load(Saver,STGM_READ);
If hresx0 then
begin
MessageBox(0,'File not found (or not link)','!! Error !!',mb_IconHand
or mb_ok); Exit;
end;
hresx:=psl.Resolve(0,SLR_ANY_MATCH); If hresx0 then Exit; hresx:=
psl.GetWorkingDirectory(@X1,MAX_PATH ); If hresx0 then begin
MessageBox(0,'Error in get WD','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
fWorkingDir:=StrPas(@X1);
hresx:= psl.GetPath( @X1,MAX_PATH,Data,SLGP_UNCPRIORITY); If hresx0
then
begin
MessageBox(0,'Error in get GP','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
fTarget:=StrPas(@X1);
hresx:=psl.GetIconLocation(@X1,MAX_PATH,@I); If hresx0 then begin
MessageBox(0,'Error in get IL','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
fIconLocation:=StrPas(@X1);
fIconNumber:=I;
hresx:= psl.GetDescription(@X1,MAX_PATH ); If hresx0 then begin
MessageBox(0,'Error in get DE','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
fDescription:=StrPas(@X1);
Y:=0;
hresx:= psl.GetShowCmd(@Y);
If hresx0 then
begin
MessageBox(0,'Error in get SC','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
fShowCmd:=Y;
W:=0;
hresx:= psl.GetHotKey(@W);
If hresx0 then
begin
MessageBox(0,'Error in get HK','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
fHotKey:=W;
hresx:= psl.GetArguments(@X1,MAX_PATH ); If hresx0 then begin
MessageBox(0,'Error in get AR','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
fArguments:=StrPas(@X1);
ppf.release;
psl.release;
StrDispose(X3);
fPath:=S;
end;
procedure TShellLink.SetUpdate(const S:Boolean); begin
SetSelfPath(fPath);
fUpdate:=True;
end;
procedure TShellLink.fSetSelfPath(const S:String); begin
SetSelfPath(S);
end;
procedure TShellLink.CreateNew(const Path,Target:String); var
X1,X3:PChar;S,S2,S3:String[255];
hresx:HResult;
Psl:IShellLink;
Ppf:IPersistFile;
Saver:Array [0..Max_Path] of WideChar; begin
hresx:=0;
hresx:=CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,IID_I
ShellLink, psl);
If hresx0 then
begin
MessageBox(0,'Error in create instance','!! Error !!',mb_IconHand or
mb_ok); Exit;
end;
X1:=StrAlloc(255);
X3:=StrAlloc(255);
try
StrPCopy(X1,Target);
hresx:=psl.SetPath(X1);
if hresx0 then
begin
MessageBox(0,'Error in set path','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
hresx:=psl.QueryInterface(IID_IPersistFile,ppf); if hresx0 then
begin
MessageBox(0,'Error in query interface','!! Error !!',mb_IconHand or
mb_ok); Exit;
end;
StrPCopy(X3,Path);
MultiByteToWideChar(CP_ACP,0,X3,-1,Saver,Max_Path);
hresx:=ppf.Save(Saver,True);
If hresx=0 then
begin
MessageBox(0,'Error in save','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
finally
ppf.release;
psl.release;
StrDispose(X1);
StrDispose(X3);
end;
End;
procedure TShellLink.SaveToFile(const Path:String); var
X1,X3:PChar;S,S2,S3:String[255];
hresx:HResult;
Psl:IShellLink;
Ppf:IPersistFile;
Saver:Array [0..Max_Path] of WideChar; begin
hresx:=0;
hresx:=CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,IID_I
ShellLink, psl);
If hresx0 then
begin
MessageBox(0,'Error in create instance','!! Error !!',mb_IconHand or
mb_ok); Exit;
end;
X1:=StrAlloc(255);
X3:=StrAlloc(255);
try
StrPCopy(X1,fTarget);
hresx:=psl.SetPath(PChar(fTarget));
If hresx0 then
begin
MessageBox(0,'Error in set path','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
StrPCopy(X1,fDescription);
hresx:=psl.SetDescription(X1);
hresx:=psl.SetWorkingDirectory(PChar(fWorkingDir));
hresx:=psl.SetArguments(PChar(fArguments));
hresx:=psl.SetHotKey(fHotKey);
hresx:=psl.SetShowCmd(fShowCmd);
hresx:=psl.SetIconLocation(PChar(fIconLocation),IconNumber);
hresx:=psl.QueryInterface(IID_IPersistFile,ppf); If hresx0 then
begin
MessageBox(0,'Error in query interface','!! Error !!',mb_IconHand or
mb_ok); Exit;
end;
StrPCopy(X3,Path);
MultiByteToWideChar(CP_ACP,0,X3,-1,Saver,Max_Path);
hresx:=ppf.Save(Saver,True);
If hresx0 then
begin
MessageBox(0,'Error in save','!! Error !!',mb_IconHand or mb_ok);
Exit;
end;
ppf.release;
finally
psl.release;
StrDispose(X1);
StrDispose(X3);
end;
End;
begin
end.
*******************************************************
and this is sample code for create link and retrieve information from
link
*******************************************************
unit test1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, SheLink, StdCtrls,Ole2;
type
TForm1 = class(TForm)
GroupBox1: TGroupBox;
Memo1: TMemo;
Button1: TButton;
Link: TShellLink;
Open1: TOpenDialog;
GroupBox2: TGroupBox;
Edit1: TEdit;
Label1: TLabel;
Button2: TButton;
Label2: TLabel;
Edit2: TEdit;
Button3: TButton;
Open2: TOpenDialog;
Save: TSaveDialog;
Button4: TButton;
procedure Button1Click(Sender: TObject); procedure
Button2Click(Sender: TObject); procedure Button3Click(Sender:
TObject); procedure Button4Click(Sender: TObject); procedure
FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{_R *.DFM}
procedure TForm1.Button1Click(Sender: TObject); begin If Not
Open1.Execute then Exit;
Link.SetSelfPath(Open1.FileName);
Memo1.Lines.Add('Arguments :'+Link.Arguments);
Memo1.Lines.Add('Description :'+Link.Description);
Memo1.Lines.Add('Hotkey :'+IntToStr(Link.Hotkey));
Memo1.Lines.Add('Target :'+Link.Target); Memo1.Lines.Add('WorkingDir
:'+Link.WorkingDir); end;
procedure TForm1.Button2Click(Sender: TObject); begin If Open2.Execute
then Edit1.Text:=Open2.FileName; end;
procedure TForm1.Button3Click(Sender: TObject); begin If Save.Execute
then Edit2.Text:=Save.FileName; end;
procedure TForm1.Button4Click(Sender: TObject); begin
Link.CreateNew(Edit2.Text,Edit1.Text); end;
procedure TForm1.FormCreate(Sender: TObject); begin CoInitialize(nil);
// required for Shell link end;
procedure TForm1.FormDestroy(Sender: TObject); begin
CoUninitialize; // required for Shell link end;
end.
a tadu je k tomu form
object Form1: TForm1
Left = 223
Top = 107
Width = 435
Height = 300
Caption = 'Shell Link Demo'
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object GroupBox1: TGroupBox
Left = 4
Top = 4
Width = 419
Height = 147
Caption = ' Get info from shell link ' TabOrder = 0 object Memo1:
TMemo
Left = 6
Top = 18
Width = 407
Height = 101
TabOrder = 0
end
object Button1: TButton
Left = 6
Top = 120
Width = 407
Height = 25
Caption = 'Get info'
TabOrder = 1
OnClick = Button1Click
end
end
object GroupBox2: TGroupBox
Left = 4
Top = 154
Width = 419
Height = 117
Caption = ' Create new link '
TabOrder = 1
object Label1: TLabel
Left = 12
Top = 14
Width = 34
Height = 13
Caption = 'Target '
end
object Label2: TLabel
Left = 12
Top = 52
Width = 82
Height = 13
Caption = 'Name of new link'
end
object Edit1: TEdit
Left = 10
Top = 30
Width = 321
Height = 21
TabOrder = 0
Text = 'C:\Autoexec.bat'
end
object Button2: TButton
Left = 338
Top = 26
Width = 75
Height = 25
Caption = 'Browse'
TabOrder = 1
OnClick = Button2Click
end
object Edit2: TEdit
Left = 10
Top = 68
Width = 321
Height = 21
TabOrder = 2
Text = 'C:\this is shortcut to Autoexec.bat.lnk' end
object Button3: TButton
Left = 338
Top = 64
Width = 75
Height = 25
Caption = 'Browse'
TabOrder = 3
OnClick = Button3Click
end
object Button4: TButton
Left = 10
Top = 90
Width = 405
Height = 25
Caption = 'Create new link (shortcut)' TabOrder = 4 OnClick =
Button4Click
end
end
object Link: TShellLink
HotKey = 0
ShowCmd = 0
IconNumber = 0
Update = True
Left = 378
Top = 24
end
object Open1: TOpenDialog
FileEditStyle = fsEdit
Filter = 'Link files|*.lnk|Pif files|*.pif' Options =
[ofNoDereferenceLinks]
Left = 378
Top = 56
end
object Open2: TOpenDialog
FileEditStyle = fsEdit
Filter = 'All files|*.*'
Left = 302
Top = 170
end
object Save: TSaveDialog
DefaultExt = '*.lnk'
FileEditStyle = fsEdit
Filter = '*.lnk|*.lnk'
Left = 302
Top = 216
end
end
Bye Radek Voltr
voltrr1@epr1.ccmail.x400.cez.cz