[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]