大哥!紧急求救!如何在桌面上生成快捷方式!!在线等待! (300分)

  • 主题发起人 主题发起人 topboy
  • 开始时间 开始时间
T

topboy

Unregistered / Unconfirmed
GUEST, unregistred user!
在delphi中写代码,让我的文件(比如:c:/y.exe)在桌面上自动生成快捷方式!!
还有,如何删除桌面的快捷方式》?
 
借花献佛,来自他人。
//在桌面上建立快捷方式
procedure TForm1.Button1Click(Sender: TObject);
var
tmpObject : IUnknown;
tmpSLink : IShellLink;
tmpPFile : IPersistFile;
PIDL : PItemIDList;
StartupDirectory : array[0..MAX_PATH] of Char;
StartupFilename : String;
LinkFilename : WideString;
begin
StartupFilename := 'c:/windows/notepad.exe';
tmpObject := CreateComObject(CLSID_ShellLink);//创建建立快捷方式的外壳扩展
tmpSLink := tmpObject as IShellLink;//取得接口
tmpPFile := tmpObject as IPersistFile;//用来储存*.lnk文件的接口
tmpSLink.SetPath(pChar(StartupFilename));//设定notepad.exe所在路径
tmpSLink.SetWorkingDirectory(pChar(ExtractFilePath(StartupFilename)));//设定工作目录
SHGetSpecialFolderLocation(0,
CSIDL_DESKTOPDIRECTORY,
PIDL);//获得桌面的Itemidlist
SHGetPathFromIDList(PIDL,
StartupDirectory);//获得桌面路径
LinkFilename := StartupDirectory + '/MyNotepad.lnk';
tmpPFile.Save(pWChar(LinkFilename),FALSE);//保存*.lnk文件
end;
 
uses activeX,comobj,shlobj;

const
IID_IPersistFile: TGUID =
(D1:$0000010B;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

function CreateLink(aPathObj,aPathLink,aDesc: string): boolean;
var sLink: IShellLink;
PersFile: IPersistFile;

begin
Result := false;
if SUCCEEDED(CoCreateInstance(CLSID_ShellLink, nil,
CLSCTX_INPROC_SERVER, IID_IShellLinkA, sLink)) then
begin
sLink.SetPath(PChar(aPathObj));
sLink.SetDescription(PChar(aDesc));
if SUCCEEDED(sLink.QueryInterface(IID_IPersistFile,PersFile)) then
begin
PersFile.Save(StringToOLEStr(aPathLink),TRUE);
Result := true;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if not CreateLink('command.com',
'c:/temp/mylink.lnk','description...') then
begin
// errorhandling
end;
end;
 
需引用单元shiobj
function PutselfToDesktop(TargetName,Mycaption,DispInfo:String):boolean;
{________________________________________________
| Mycaption:快捷方式标题 |
| TargetName:快捷方式指向的文件,需包含完整路径| |
| DispInfo:快捷方式提示信息 可为空 |
| win2000指向快捷方式时可显示win98下无用 |
|________________________________________________}
var
IObject : IUnknown;
ISLink : IShellLink;
IPFile : IPersistFile;
PIDL : PItemIDList;
InFolder : array[0..MAX_PATH] of Char;
TargetName : String;
LinkName : WideString;
begin
if not fileexists(TargetName) then Exit;
if mycaption='' then Exit;
IObject := CreateComObject(CLSID_ShellLink);
ISLink := IObject as IShellLink;
IPFile := IObject as IPersistFile;
with ISLink do begin
SetPath(pChar(TargetName));
SetWorkingDirectory
(pChar(ExtractFilePath(TargetName)));
SetDescription(pchar(DispInfo));
end;
// 在桌面上建立
SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL);
SHGetPathFromIDList(PIDL, InFolder);
LinkName := InFolder + '/'+mycaption+'.lnk';
IPFile.Save(PWChar(LinkName), false);
//在程序组中建立
SHGetSpecialFolderLocation(0,CSIDL_STARTMENU , PIDL);
SHGetPathFromIDList(PIDL, InFolder);
LinkName := InFolder + '/程序/'+mycaption+'.lnk';
IPFile.Save(PWChar(LinkName), false);
result:=true;
end;
 
我的这个保证能用,不能用不要给分哟:)))))))
uses
Registry,
ActiveX,
ComObj,
ShlObj;

type
ShortcutType = (_DESKTOP, _QUICKLAUNCH, _SENDTO, _STARTMENU, _OTHERFOLDER);

function CreateShortcut(SourceFileName: string; // the file the shortcut points to
Location: ShortcutType; // shortcut location
SubFolder, // subfolder of location
WorkingDir, // working directory property of the shortcut
Parameters,
Description: string): // description property of the shortcut
string;
const
SHELL_FOLDERS_ROOT = 'Software/MicroSoft/Windows/CurrentVersion/Explorer';
QUICK_LAUNCH_ROOT = 'Software/MicroSoft/Windows/CurrentVersion/GrpConv';
var
MyObject: IUnknown;
MySLink: IShellLink;
MyPFile: IPersistFile;
Directory, LinkName: string;
WFileName: WideString;
Reg: TRegIniFile;
begin

MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;

MySLink.SetPath(PChar(SourceFileName));
MySLink.SetArguments(PChar(Parameters));
MySLink.SetDescription(PChar(Description));

LinkName := ChangeFileExt(SourceFileName, '.lnk');
LinkName := ExtractFileName(LinkName);

// Quicklauch
if Location = _QUICKLAUNCH then
begin
Reg := TRegIniFile.Create(QUICK_LAUNCH_ROOT);
try
Directory := Reg.ReadString('MapGroups', 'Quick Launch', '');
finally
Reg.Free;
end;
end
else
// Other locations
begin
Reg := TRegIniFile.Create(SHELL_FOLDERS_ROOT);
try
case Location of
_OTHERFOLDER : Directory := SubFolder;
_DESKTOP : Directory := Reg.ReadString('Shell Folders', 'Desktop', '');
_STARTMENU : Directory := Reg.ReadString('Shell Folders', 'Start Menu', '');
_SENDTO : Directory := Reg.ReadString('Shell Folders', 'SendTo', '');
end;
finally
Reg.Free;
end;
end;

if Directory <> '' then
begin
if (SubFolder <> '') and (Location <> _OTHERFOLDER) then
WFileName := Directory + '/' + SubFolder + '/' + LinkName
else
WFileName := Directory + '/' + LinkName;

if WorkingDir = '' then
MySLink.SetWorkingDirectory(PChar(ExtractFilePath(SourceFileName)));

MyPFile.Save(PWChar(WFileName), False);
Result := WFileName;
end;
end;

function GetProgramDir: string;
var
reg: TRegistry;
begin
reg := TRegistry.Create;
try
reg.RootKey := HKEY_CURRENT_USER;
reg.OpenKey('Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders', False);
Result := reg.ReadString('Programs');
reg.CloseKey;
finally
reg.Free;
end;
end;

// Some examples:

procedure TForm1.Button1Click(Sender: TObject);
const
PROGR = 'c:/YourProgram.exe';
var
resPath: string;
begin
//Create a Shortcut in the Quckick launch toolbar
CreateShortcut(PROGR, _QUICKLAUNCH, '','','','Description');

//Create a Shortcut on the Desktop
CreateShortcut(PROGR, _DESKTOP, '','','','Description');

//Create a Shortcut in the Startmenu /"Programs"-Folder
resPath := CreateShortcut(PROGR, _OTHERFOLDER, GetProgramDir,'','','Description');
if resPath <> '' then
begin
ShowMessage('Shortcut Successfully created in: ' + resPath);
end;
end;








 
为什么不认IShellLink;IPersistFile;
我加了shlobj...
是不是要加什么单元????????
 
需要加入uses shlobj;
删除其实是删掉个你建立的那个.lnk文件.
 
to topboy
用我的方法绝对没有问题!别忘了把分分给我就是了!:))))
我的专家分好少呀!555555555555555555555555555
 
IPersistFile 在ACTIVEX单元;
 
shlobj单元
 
接受答案!每人都有分!
谢谢!
 

Similar threads

S
回复
0
查看
3K
SUNSTONE的Delphi笔记
S
S
回复
0
查看
2K
SUNSTONE的Delphi笔记
S
D
回复
0
查看
2K
DelphiTeacher的专栏
D
后退
顶部