createlinkfilefunc.pas

Delphi函数工厂。。。。。。。。。。。。。

unit CreateLinkFileFunc;

interface

uses SysUtils, Windows, ShlObj, ActiveX, ComObj, Registry, IniFiles;

{-----------------------------------------------------------------------------}
{
{  Procedure: CreateLink
{
{  Author:    阿文([e-mail])
{
{  Date:      2003-02-11
{
{  Arguments: const LinkFileName, ToFileName: string; const CmdLine: string = '';
{             const WorkingDir: string = ''; const Description: string = ''
{
{  Result:    Boolean
{
{  说明：     LinkFileName 是一个包含完整路径和文件名的参数，函数 CreateLink
{             将在 LinkFileName 指定的位置创建 .lnk 文件。
{             ToFileName 是被Link的文件；CmdLine 是命令行参数；WorkingDir 是
{             程序启动时的工作目录，如果给 '' 的话，工作目录将是 ToFileName
{             的目录；Description 是该 .lnk 文件的描述。
{             函数成功返回 Ture, 失败返回 False
{
{-----------------------------------------------------------------------------}
function CreateLink(const LinkFileName, ToFileName: string; const CmdLine: string = '';
  const WorkingDir: string = ''; const Description: string = ''): Boolean;

{-----------------------------------------------------------------------------}
{
{  Procedure: CreateURLLink
{
{  Author:    阿文([e-mail])
{
{  Date:      2003-02-11
{
{  Arguments: const LinkFileName, URL: string
{
{  说明：     创建一个指向URL的快捷方式。
{
{-----------------------------------------------------------------------------}
procedure CreateURLLink(const LinkFileName, URL: string);

function GetDesktopDir: string;
function GetStartMenuProgramsDir: string;
function GetRecentDir: string;
function GetStartupDir: string;
function GetFavoritesDir: string;


const
  UrlExt = '.URL';
  LnkExt = '.LNK';

implementation

const
  ksExplorerKey = 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';

////////////////////////////////////////////////////////////////////////////////
//  Tip 10 - actual code which implements creating link.
// - Notes: IUnknown, IShellLink and IPersistFile are documented in
//          the ShlObj unit.
//
////////////////////////////////////////////////////////////////////////////////


function CreateLink(const LinkFileName, ToFileName: string; const CmdLine: string = '';
  const WorkingDir: string = ''; const Description: string = ''): Boolean;
var
  IfUnknown: IUnknown;
  IfShellLnk: IShellLink;
  IfPersistFile: IPersistFile;

  DefWorkingDir: string;
  ExtStr: string;

  LnkFile: WideString;
begin
  // create a com object
  IfUnknown := CreateComObject(CLSID_ShellLink);
  // cast the IUnknown interface to a IShellLink
  IfShellLnk := IfUnknown as IShellLink;
  // cast the IUnknown interface to a IPersistFile
  IfPersistFile := IfUnknown as IPersistFile;

  // using the Interface to the Shell link call some of
  // it's methods.
  with IfShellLnk do
  begin
  //GetIconLocation(pchar(ToFileName),1,0);
    setArguments(PChar(CmdLine));
    setPath(PChar(ToFileName));
    if WorkingDir = EmptyStr then
    begin
      DefWorkingDir := ExtractFilePath(ToFileName);
      setWorkingDirectory(PChar(DefWorkingDir));
    end
    else
    begin
      setWorkingDirectory(PChar(WorkingDir));
    end;
    if Description = EmptyStr then
      setDescription(nil)
    else
      setDescription(PChar(Description));
  end;
  LnkFile := LinkFileName;
  ExtStr := UpperCase(ExtractFileExt(LinkFileName));
  if (ExtStr = EmptyStr) or (ExtStr <> LnkExt) then
    LnkFile := LnkFile + LnkExt;

  // this saves linkfile
  Result := IfPersistFile.Save(PWChar(LnkFile), False) = S_OK;
end;

procedure CreateURLLink(const LinkFileName, URL: string);
var
  Ini: TIniFile;
  ExtStr: string;
begin
  ExtStr := UpperCase(ExtractFileExt(LinkFileName));
  if (ExtStr = EmptyStr) or (ExtStr <> UrlExt) then
    Ini := TIniFile.Create(LinkFileName + UrlExt)
  else
    Ini := TIniFile.Create(LinkFileName);
  try
    Ini.WriteString('InternetShortcut', 'URL', URL);
  finally
    Ini.Free;
  end;
end;

function GetDesktopDir: string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKeyReadOnly(ksExplorerKey);
    try
      Result := Reg.ReadString('Desktop');
      if Result <> EmptyStr then Result := IncludeTrailingBackslash(Result);
    except
      Result := EmptyStr;
    end;
  finally
    Reg.free;
  end;
end;

function GetStartMenuProgramsDir: string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKeyReadOnly(ksExplorerKey);
    try
      Result := Reg.ReadString('Programs');
      if Result <> EmptyStr then Result := IncludeTrailingBackslash(Result);
    except
      Result := EmptyStr;
    end;
  finally
    Reg.free;
  end;
end;

function GetRecentDir: string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKeyReadOnly(ksExplorerKey);
    try
      Result := Reg.ReadString('Recent');
      if Result <> EmptyStr then Result := IncludeTrailingBackslash(Result);
    except
      Result := EmptyStr;
    end;
  finally
    Reg.free;
  end;
end;

function GetStartupDir: string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKeyReadOnly(ksExplorerKey);
    try
      Result := Reg.ReadString('Startup');
      if Result <> EmptyStr then Result := IncludeTrailingBackslash(Result);
    except
      Result := EmptyStr;
    end;
  finally
    Reg.free;
  end;
end;

function GetFavoritesDir: string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKeyReadOnly(ksExplorerKey);
    try
      Result := Reg.ReadString('Favorites');
      if Result <> EmptyStr then Result := IncludeTrailingBackslash(Result);
    except
      Result := EmptyStr;
    end;
  finally
    Reg.free;
  end;
end;

end.