[Back to DELPHI SWAG index]  [Back to Main SWAG index]  [Original]

     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 hresx<>0 then Exit;
     hresx:=psl.QueryInterface(IID_IPersistFile,ppf); If hresx<>0 then
     Exit;
     X3:=StrAlloc(255);
     StrPCopy(X3,S);
     MultiByteToWideChar(CP_ACP,0,X3,-1,Saver,Max_Path);
     hresx:=ppf.Load(Saver,STGM_READ);
     If hresx<>0 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 hresx<>0 then Exit; hresx:=
     psl.GetWorkingDirectory(@X1,MAX_PATH ); If hresx<>0 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 hresx<>0
     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 hresx<>0 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 hresx<>0 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 hresx<>0 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 hresx<>0 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 hresx<>0 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 hresx<>0 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 hresx<>0 then
     begin
     MessageBox(0,'Error in set path','!! Error !!',mb_IconHand or mb_ok);
     Exit;
     end;

     hresx:=psl.QueryInterface(IID_IPersistFile,ppf); if hresx<>0 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 hresx<>0 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 hresx<>0 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 hresx<>0 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;
     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

[Back to DELPHI SWAG index]  [Back to Main SWAG index]  [Original]