怎样编程实现在桌面上创建一个快捷方式

他人的。
写成了一个控件
源码如下：
{******************************************************************}
{unit Name: LQShortcut                                             }
{Author: LinQiang                                                       }
{Description:一个创建快捷方式的VCL,简单方便.只需简单调用CreateShor_}
{Cut方法就可创建符合要求的快捷方式.                                }
{Code Tool:Borland Delphi Enterprise 6 Updata 2                    }
{Date:2003,09,11                                                   }
{Version:0.2.9                                                     }
{******************************************************************}
unit LQShortCut;interfaceuses
  Windows,Messages,SysUtils, Classes,ActiveX,ComCtrls,ShlObj,Registry;Const
  IID_IPersistFile:TGUID='{0000010B-0000-0000-C000-000000000046}';type  TWindowState = (SW_SHOWNORMAL,SW_SHOWMINNOACTIVE,SW_SHOWMAXIMIZED);
  TShellFolder=(sfDesktop,sfAppData,sfFavorites,sfFonts,sfPersonal,sfPrograms,
    sfHistory,sfNetHood,sfRecent,sfSendTo,sfStartMenu,sfStartup,sfTemplates);
  THotKeys =(Null,F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12);  TErrorEvent=Procedure(Sender:TObject;ErrorMsg:String;ErrorIndex:Integer)
    Of Object;
  //ShellLink接口定义
  IShellLink=Interface(IUnknown)
    ['{000214EE-0000-0000-C000-000000000046}']
    Function GetPath(pszFile:PChar;cchMaxPath:Integer;Var
      pfd:TWin32FindData;fFlags:DWORD):HRESULT; Stdcall;
    Function GetIDList(ppidl:Pointer):HRESULT; Stdcall;
    Function SetIDList(Const pidl:Pointer):HRESULT; Stdcall;
    Function GetDescription(pszName:PChar;cchMaxName:Integer):HRESULT;
      Stdcall;
    Function SetDescription(Const pszName:PChar):HRESULT; Stdcall;
    Function GetWorkingDirectory(pszDir:PChar;cchMaxPath:Integer):HRESULT;
      Stdcall;
    Function SetWorkingDirectory(Const pszDir:PChar):HRESULT; Stdcall;
    Function GetArguments(pszDir:PChar;cchMaxPath:Integer):HRESULT;
      Stdcall;
    Function SetArguments(Const pszArgs:PChar):HRESULT; Stdcall;
    Function GetHotkey(pwHotkey:PWORD):HRESULT; Stdcall;
    Function SetHotkey(wHotkey:Word):HRESULT; Stdcall;
    Function GetShowCmd(piShowCmd:PInteger):HRESULT; Stdcall;
    Function SetShowCmd(iShowCmd:Integer):HRESULT; Stdcall;
    Function
      GetIconLocation(pszIconPath:PChar;cchIconPath:Integer;piIcon:PInteger):HRESULT; Stdcall;
    Function SetIconLocation(Const
      pszIconPath:PChar;iIcon:Integer):HRESULT; Stdcall;
    Function SetRelativePath(Const
      pszPathRel:PChar;dwReserved:DWORD):HRESULT; Stdcall;
    Function Resolve(Wnd:HWND;fFlags:DWORD):HRESULT; Stdcall;
    Function SetPath(Const pszFile:PChar):HRESULT; Stdcall;
  End;  TLQShortCut = class(TComponent)
  private
    { Private declarations }
    FAuto:Boolean;              //是否自动处理(自动完成文件名,工作目录)
    ShellPath:String;           //创建到的路径
    FFileName:String;           //快捷方式文件名;
    FFilePath:String;           //快捷方式指向的文件;
    FDescription:String;        //描述;
    FWorkingDirectory:String;   //运行目录;
    FArguments:String;          //叁数;
    FHotKey:THotKeys;          //热键(键值);
    FWindowState:TWindowState;  //初始窗口;
    FIconLocation:String;       //图标;
    FShellFolder:TShellFolder;  //创建到的目录;
    FErrorEvent:TErrorEvent;
    Procedure AutoProc;
    Procedure SetAuto(Const Value:Boolean);
    Procedure SetDescription(Const Value:String);
    Procedure SetFilePath(Const Value:String);
    Procedure SetHotKey(Const Value:THotKeys);
    Procedure SetIconLocation(Const Value:String);
    Procedure SetWindowState(Const Value:TWindowState);
    Procedure SetWorkingDirectory(Const Value:String);
    Procedure SetArgumentsl(Const Value:String);
    Procedure SetShellFolder(Const Value:TShellFolder);
    Procedure SetFileName(Const Value:String);
    Procedure DoErrorEvent(Const ErrorIndex:Integer);
  protected
    { Protected declarations }
  public
    { Public declarations }
    Constructor Create(AOwner:TComponent); Override;
    Destructor Destroy; Override;
  published
    { Published declarations }
    Property Auto:Boolean Read FAuto Write SetAuto Default False;
    Property FilePath:String Read FFilePath Write SetFilePath;
    Property Description:String Read FDescription Write SetDescription;
    Property WorkingDirectory:String Read FWorkingDirectory Write
      SetWorkingDirectory;
    Property Arguments:String Read FArguments Write SetArgumentsl;
    Property HotKey:THotKeys Read FHotKey Write SetHotKey Default Null;
    Property WindowState:TWindowState Read FWindowState Write
      SetWindowState Default SW_SHOWNORMAL;
    Property IconLocation:String Read FIconLocation Write SetIconLocation;
    Property ShellFolder:TShellFolder Read FShellFolder Write
      SetShellFolder Default sfDesktop;
    Property OnError:TErrorEvent Read FErrorEvent Write
      FErrorEvent Default Nil;
    Property ShortCutFileName:String Read FFileName Write SetFileName;
    Procedure CreateShortCut;
  end;procedure Register;implementationprocedure Register;
begin
  RegisterComponents('LQ', [TLQShortCut]);
end;{ TLQShortCut }procedure TLQShortCut.AutoProc;
begin
  if FFilePath ='' Then Exit;
  If FFileName ='' Then
    FFileName :=ExtractFileName(FFilePath);
  If FWorkingDirectory='' Then
    FWorkingDirectory:=ExtractFileDir(FFilePath);
end;constructor TLQShortCut.Create(AOwner: TComponent);
begin
  inherited;
  CoInitialize(Nil);
  FAuto:=False;
end;

procedure TLQShortCut.CreateShortCut;
Var
  ISC:IShellLink;
  Ipf:IPersistFile;
  sFileName:String;
  wFileName:Array[0..MAX_PATH] Of WideChar;
  Reg:TRegistry;
  AHotKey : Word;
Begin
  Try
    If (FFilePath='') Then
      DoErrorEvent(1);
    Reg:=TRegistry.Create;
    Try
      Try
        //读取注册表中的系统相关路径
        Reg.RootKey:=HKEY_CURRENT_USER;
        Reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',False);
        Case Ord(FShellFolder) Of
          0:ShellPath:='Desktop';
          1:ShellPath:='AppData';
          2:ShellPath:='Favorites';
          3:ShellPath:='Fonts';
          4:ShellPath:='Personal';
          5:ShellPath:='Programs';
          6:ShellPath:='History';
          7:ShellPath:='NetHood';
          8:ShellPath:='Recent';
          9:ShellPath:='SendTo';
          10:ShellPath:='StartMenu';
          11:ShellPath:='Startup';
          12:ShellPath:='Templates';
        End;
        ShellPath:=Reg.ReadString(ShellPath);
      Finally
        Reg.Free;
      End;
    Except
      DoErrorEvent(5);
      ShellPath:='';
    End;
    If FAuto Then AutoProc;
    If
      Failed(CoCreateInstance(CLSID_ShellLink,Nil,CLSCTX_INPROC_SERVER,IID_IShellLinkA,ISC)) Then
      DoErrorEvent(2);
    sFileName:=ChangeFileExt(ExtractFileName(FFileName),'.LNK');
    SFileName:=ShellPath+'\'+sFileName;
    ISC.SetPath(PChar(FFilePath));
    ISC.SetDescription(PChar(FDescription));
    ISC.SetWorkingDirectory(PChar(FWorkingDirectory));
    ISC.SetArguments(PChar(FArguments));
    if Ord(FHotKey) <> 0 then AHotKey := Ord(FHotKey) + 111
    else AHotKey := 0;

    ISC.SetHotkey(AHotKey);
    ISC.SetShowCmd(Ord(FWindowState)+1);
    ISC.SetIconLocation(PChar(FIconLocation),0);
    If
      Failed(ISC.QueryInterface(IID_IPersistFile,Ipf)) Then
      DoErrorEvent(3);
    //字节型转换为WideChar
    MultiByteToWideChar(CP_ACP,0,PChar(sFileName),-1,wFileName,MAX_PATH);
    If Failed(Ipf.Save(wFileName,True)) Then
      DoErrorEvent(4);
  Except
    DoErrorEvent(6);
  End;End;destructor TLQShortCut.Destroy;
begin
  CoUninitialize;
  inherited;
end;procedure TLQShortCut.DoErrorEvent(const ErrorIndex: Integer);
begin
  if Not(Assigned(FErrorEvent)) Then Exit;
  Case ErrorIndex Of
    1:FErrorEvent(Self,'FilePath is null',ErrorIndex);
    2:FErrorEvent(Self,'Create ShortCut Instance Error!',ErrorIndex);
    3:FErrorEvent(Self,'Create Interface Error!',ErrorIndex);
    4:FErrorEvent(Self,'Create ShortCut File Error!',ErrorIndex);
    5:FErrorEvent(Self,'Get ShellPath Error!',ErrorIndex);
    6:FErrorEvent(Self,'UnKnow Error!',ErrorIndex);
  End;
end;procedure TLQShortCut.SetArgumentsl(const Value: String);
begin
  If FArguments<>Value Then FArguments:=Value;
end;procedure TLQShortCut.SetAuto(const Value: Boolean);
begin
  If FAuto<>Value Then FAuto:=Value;
end;procedure TLQShortCut.SetDescription(const Value: String);
begin
  If FDescription<>Value Then FDescription:=Value;
end;procedure TLQShortCut.SetFileName(const Value: String);
begin
  If FFileName<>Value Then FFileName:=Value;
end;procedure TLQShortCut.SetFilePath(const Value: String);
begin
  If FFilePath<>Value Then FFilePath:=Value;
end;procedure TLQShortCut.SetHotKey(const Value: THotKeys);
begin
  If FHotKey<>Value Then FHotKey:=Value;
end;procedure TLQShortCut.SetIconLocation(const Value: String);
begin
  If FIconLocation<>Value Then FIconLocation:=Value;
end;procedure TLQShortCut.SetShellFolder(const Value: TShellFolder);
begin
  If FShellFolder<>Value Then FShellFolder:=Value;
end;procedure TLQShortCut.SetWindowState(const Value: TWindowState);
begin
  If FWindowState<>Value Then FWindowState:=Value;
end;procedure TLQShortCut.SetWorkingDirectory(const Value: String);
begin
  If FWorkingDirectory<>Value Then FWorkingDirectory:=Value;
end;end.

抄了一段，稍微有点改动
uses
  ...,ActiveX, ComObj, ShlObj;procedure TForm1.FormCreate(Sender: TObject);
var
  ShLink: IShellLink;
  PFile: IPersistFile;
  FileName: WideString;
begin
  FileName := ExtractFilePath(Application.ExeName) + '快捷方式 '
    + ExtractFileName(Application.ExeName) + '.lnk';
  if FileExists(FileName) then Exit;
  ShLink := CreateComObject (CLSID_ShellLink) as IShellLink;
  PFile := ShLink as IPersistFile;
  ShLink.SetPath(PChar(Application.ExeName));
  ShLink.SetWorkingDirectory(PChar(ExtractFilePath(Application.ExeName)));
  PFile.Save(PWChar(FileName), False);
end;

我Kao~~上了个WC，回来这么多回帖的 hehe^^ 都会找资料抢分了，哎~~~ 以后不好混啦....

调试易

怎样编程实现在桌面上创建一个快捷方式

解决方案 »