home *** CD-ROM | disk | FTP | other *** search
/ Chip: Shareware for Win 95 / Chip-Shareware-Win95.bin / ostatni / delphi / delphi2 / shelink.exe / rar / SHELINK.PAS < prev   
Pascal/Delphi Source File  |  1996-06-19  |  9KB  |  322 lines
  1. //*******************************************************
  2. //*       Shell Link Component for Delphi 2.0           *
  3. //*                                                     *
  4. //*   this is end version                               *
  5. //*                                                     *
  6. //*   for new versions send e-mail,s-mail,fax           *
  7. //*   with you name and e-mail adress to >              *
  8. //*                                                     *
  9. //*    voltr.radek/4600/epr@epr1.ccmail.x400.cez.cz     *
  10. //*                                                     *
  11. //*    (c) 1996 Radek Voltr                             *
  12. //*             Kozeluzska 1523                         *
  13. //*             Kadan 43201    CZECH Republic   Europe  *
  14. //*             fax. 42 398 2776                        *
  15. //*      note: this version is free                     *
  16. //*******************************************************
  17.  
  18. unit SheLink;
  19.  
  20. interface
  21.  
  22. uses
  23.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Ole2;
  24.  
  25. const
  26.     SLR_NO_UI        = $0001;
  27.     SLR_ANY_MATCH    = $0002;
  28.     SLR_UPDATE          = $0004;
  29.  
  30.     SLGP_SHORTPATH    = $0001;
  31.     SLGP_UNCPRIORITY    = $0002;
  32.  
  33.     CLSID_ShellLink:    TCLSID = (D1:$00021401; D2:$0; D3:$0; D4:($C0,$0,$0,$0,$0,$0,$0,$46));
  34.     IID_IShellLink:      TCLSID = (D1:$000214EE; D2:$0; D3:$0; D4:($C0,$0,$0,$0,$0,$0,$0,$46));
  35.  
  36. type
  37. PShellLink = ^IShellLink;
  38. IShellLink = class(IUnknown)
  39.   public
  40.     Function GetPath(pszFile:PChar;cchMaxPath:Integer;var pfd:TWin32FindData;fFlags:DWord):HResult; virtual; stdcall; abstract;
  41.     Function GetIDList(ppidl:pointer) :HResult; virtual; stdcall; abstract;
  42.     Function SetIDList(const pidl:pointer) :HResult; virtual; stdcall; abstract;
  43.     Function GetDescription(pszName:PChar;cchMaxName:Integer) :HResult; virtual; stdcall; abstract;
  44.     Function SetDescription(Const pszName:PChar) :HResult; virtual; stdcall; abstract;
  45.     Function GetWorkingDirectory(pszDir:PChar;cchMaxPath:Integer) :HResult; virtual; stdcall; abstract;
  46.     Function SetWorkingDirectory(const pszDir:PChar) :HResult; virtual; stdcall; abstract;
  47.     Function GetArguments(pszDir:PChar;cchMaxPath:Integer) :HResult; virtual; stdcall; abstract;
  48.     Function SetArguments(const pszArgs:PChar) :HResult; virtual; stdcall; abstract;
  49.     Function GetHotkey(pwHotkey:PWord) :HResult; virtual; stdcall; abstract;
  50.     Function SetHotkey(wHotkey:Word) :HResult; virtual; stdcall; abstract;
  51.     Function GetShowCmd(piShowCmd:PInteger) :HResult; virtual; stdcall; abstract;
  52.     Function SetShowCmd(iShowCmd:Integer) :HResult; virtual; stdcall; abstract;
  53.     Function GetIconLocation(pszIconPath:PChar;cchIconPath:Integer;piIcon:PInteger) :HResult; virtual; stdcall; abstract;
  54.     Function SetIconLocation(const pszIconPath:PChar;iIcon:Integer) :HResult; virtual; stdcall; abstract;
  55.     Function SetRelativePath(const pszPathRel:PChar;dwReserved:Dword) :HResult; virtual; stdcall; abstract;
  56.     Function Resolve(wnd:hWnd;fFlags:Dword) :HResult; virtual; stdcall; abstract;
  57.     Function SetPath(Const pszFile:PChar) :HResult; virtual; stdcall; abstract;
  58. end;
  59.  
  60.  
  61. type
  62.   TShellLink = class(TComponent)
  63.   private
  64.     { Private declarations }
  65.     procedure fSetSelfPath(const S:String);
  66.   protected
  67.     { Protected declarations }
  68.     fUpdate:Boolean;
  69.     fPath,
  70.     fTarget,
  71.     fWorkingDir,
  72.     fDescription,
  73.     fArguments,
  74.     fIconLocation:String;
  75.     fIconNumber,
  76.     fShowCmd,
  77.     fHotKey:Word;
  78.   public
  79.     { Public declarations }
  80. //    constructor Create;
  81.     procedure SetSelfPath(const S:String);
  82.     procedure SetUpdate(const S:Boolean);
  83.     procedure CreateNew(const Path,Target:String);
  84.     procedure SaveToFile(const Path:String);
  85.   published
  86.     { Published declarations }
  87.     property Path:String read fPath write fSetSelfPath;
  88.     property Target:String read fTarget write fTarget;
  89.     property WorkingDir:String read fWorkingDir write fWorkingDir;
  90.     property Description:String read fDescription write fDescription;
  91.     property Arguments:String read fArguments write fArguments;
  92.     property IconLocation:String read fIconLocation write fIconLocation;
  93.     property HotKey:word read fHotKey write fHotKey;
  94.     property ShowCmd:word read fShowCmd write fShowCmd;
  95.     property IconNumber:word read fIconNumber write fIconNumber;
  96.     property Update:boolean read fUpdate write SetUpdate;
  97.   end;
  98.  
  99. procedure Register;
  100.  
  101. implementation
  102.  
  103. procedure Register;
  104. begin
  105.   RegisterComponents('Win95', [TShellLink]);
  106. end;
  107.  
  108.  
  109. procedure TShellLink.SetSelfPath(const S:String);
  110. var X3:PChar;
  111.     hresx:HResult;
  112.     Psl:IShellLink;
  113.     Ppf:IPersistFile;
  114.     Saver:Array [0..Max_Path] of WideChar;
  115.     X1:Array [0..255] Of Char;
  116.     Data:TWin32FindData;I,Y:INteger;W:Word;
  117. begin
  118. hresx:=CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,IID_IShellLink,psl);
  119. If hresx<>0 then Exit;
  120. hresx:=psl.QueryInterface(IID_IPersistFile,ppf);
  121. If hresx<>0 then Exit;
  122. X3:=StrAlloc(255);
  123. StrPCopy(X3,S);
  124. MultiByteToWideChar(CP_ACP,0,X3,-1,Saver,Max_Path);
  125. hresx:=ppf.Load(Saver,STGM_READ);
  126. If hresx<>0 then
  127. begin
  128. MessageBox(0,'File not found (or not link)','!! Error !!',mb_IconHand or mb_ok);
  129. Exit;
  130. end;
  131. hresx:=psl.Resolve(0,SLR_ANY_MATCH);
  132. If hresx<>0 then Exit;
  133. hresx:= psl.GetWorkingDirectory(@X1,MAX_PATH );
  134. If hresx<>0 then
  135. begin
  136. MessageBox(0,'Error in get WD','!! Error !!',mb_IconHand or mb_ok);
  137. Exit;
  138. end;
  139. fWorkingDir:=StrPas(@X1);
  140.  
  141. hresx:= psl.GetPath( @X1,MAX_PATH,Data,SLGP_UNCPRIORITY);
  142. If hresx<>0 then
  143. begin
  144. MessageBox(0,'Error in get GP','!! Error !!',mb_IconHand or mb_ok);
  145. Exit;
  146. end;
  147. fTarget:=StrPas(@X1);
  148.  
  149. hresx:=psl.GetIconLocation(@X1,MAX_PATH,@I);
  150. If hresx<>0 then
  151. begin
  152. MessageBox(0,'Error in get IL','!! Error !!',mb_IconHand or mb_ok);
  153. Exit;
  154. end;
  155. fIconLocation:=StrPas(@X1);
  156. fIconNumber:=I;
  157.  
  158. hresx:= psl.GetDescription(@X1,MAX_PATH );
  159. If hresx<>0 then
  160. begin
  161. MessageBox(0,'Error in get DE','!! Error !!',mb_IconHand or mb_ok);
  162. Exit;
  163. end;
  164. fDescription:=StrPas(@X1);
  165.  
  166. Y:=0;
  167. hresx:= psl.GetShowCmd(@Y);
  168. If hresx<>0 then
  169. begin
  170. MessageBox(0,'Error in get SC','!! Error !!',mb_IconHand or mb_ok);
  171. Exit;
  172. end;
  173. fShowCmd:=Y;
  174.  
  175. W:=0;
  176. hresx:= psl.GetHotKey(@W);
  177. If hresx<>0 then
  178. begin
  179. MessageBox(0,'Error in get HK','!! Error !!',mb_IconHand or mb_ok);
  180. Exit;
  181. end;
  182. fHotKey:=W;
  183.  
  184. hresx:= psl.GetArguments(@X1,MAX_PATH );
  185. If hresx<>0 then
  186. begin
  187. MessageBox(0,'Error in get AR','!! Error !!',mb_IconHand or mb_ok);
  188. Exit;
  189. end;
  190. fArguments:=StrPas(@X1);
  191.  
  192. ppf.release;
  193. psl.release;
  194. StrDispose(X3);
  195. fPath:=S;
  196. end;
  197.  
  198. procedure TShellLink.SetUpdate(const S:Boolean);
  199. begin
  200. SetSelfPath(fPath);
  201. fUpdate:=True;
  202. end;
  203.  
  204. procedure TShellLink.fSetSelfPath(const S:String);
  205.           begin
  206.           SetSelfPath(S);
  207.           end;
  208.  
  209. procedure TShellLink.CreateNew(const Path,Target:String);
  210. var X1,X3:PChar;S,S2,S3:String[255];
  211.     hresx:HResult;
  212.     Psl:IShellLink;
  213.     Ppf:IPersistFile;
  214.     Saver:Array [0..Max_Path] of WideChar;
  215. begin
  216. hresx:=0;
  217. hresx:=CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,IID_IShellLink,psl);
  218. If hresx<>0 then
  219. begin
  220. MessageBox(0,'Error in create instance','!! Error !!',mb_IconHand or mb_ok);
  221. Exit;
  222. end;
  223.  
  224. X1:=StrAlloc(255);
  225. X3:=StrAlloc(255);
  226. try
  227. StrPCopy(X1,Target);
  228. hresx:=psl.SetPath(X1);
  229. begin
  230. MessageBox(0,'Error in set path','!! Error !!',mb_IconHand or mb_ok);
  231. Exit;
  232. end;
  233.  
  234. hresx:=psl.QueryInterface(IID_IPersistFile,ppf);
  235. begin
  236. MessageBox(0,'Error in query interface','!! Error !!',mb_IconHand or mb_ok);
  237. Exit;
  238. end;
  239.  
  240. StrPCopy(X3,Path);
  241.  
  242. MultiByteToWideChar(CP_ACP,0,X3,-1,Saver,Max_Path);
  243.  
  244. hresx:=ppf.Save(Saver,True);
  245. begin
  246. MessageBox(0,'Error in save','!! Error !!',mb_IconHand or mb_ok);
  247. Exit;
  248. end;
  249.  
  250. finally
  251.     ppf.release;
  252.     psl.release;
  253.     StrDispose(X1);
  254.     StrDispose(X3);
  255. end;
  256. End;
  257.  
  258. procedure TShellLink.SaveToFile(const Path:String);
  259. var X1,X3:PChar;S,S2,S3:String[255];
  260.     hresx:HResult;
  261.     Psl:IShellLink;
  262.     Ppf:IPersistFile;
  263.     Saver:Array [0..Max_Path] of WideChar;
  264. begin
  265. hresx:=0;
  266. hresx:=CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,IID_IShellLink,psl);
  267. If hresx<>0 then
  268. begin
  269. MessageBox(0,'Error in create instance','!! Error !!',mb_IconHand or mb_ok);
  270. Exit;
  271. end;
  272.  
  273. X1:=StrAlloc(255);
  274. X3:=StrAlloc(255);
  275. try
  276. StrPCopy(X1,fTarget);
  277. hresx:=psl.SetPath(PChar(fTarget));
  278. If hresx<>0 then
  279. begin
  280. MessageBox(0,'Error in set path','!! Error !!',mb_IconHand or mb_ok);
  281. Exit;
  282. end;
  283.  
  284. StrPCopy(X1,fDescription);
  285. hresx:=psl.SetDescription(X1);
  286. hresx:=psl.SetWorkingDirectory(PChar(fWorkingDir));
  287. hresx:=psl.SetArguments(PChar(fArguments));
  288. hresx:=psl.SetHotKey(fHotKey);
  289. hresx:=psl.SetShowCmd(fShowCmd);
  290. hresx:=psl.SetIconLocation(PChar(fIconLocation),IconNumber);
  291.  
  292.  
  293. hresx:=psl.QueryInterface(IID_IPersistFile,ppf);
  294. If hresx<>0 then
  295. begin
  296. MessageBox(0,'Error in query interface','!! Error !!',mb_IconHand or mb_ok);
  297. Exit;
  298. end;
  299.  
  300. StrPCopy(X3,Path);
  301.  
  302. MultiByteToWideChar(CP_ACP,0,X3,-1,Saver,Max_Path);
  303.  
  304. hresx:=ppf.Save(Saver,True);
  305.  
  306. If hresx<>0 then
  307. begin
  308. MessageBox(0,'Error in save','!! Error !!',mb_IconHand or mb_ok);
  309. Exit;
  310. end;
  311.     ppf.release;
  312. finally
  313.     psl.release;
  314.     StrDispose(X1);
  315.     StrDispose(X3);
  316. end;
  317. End;
  318.  
  319.  
  320. begin
  321. end.
  322.