delphi修改QQ快捷方式的目标地址达到在启动QQ的同时也能运行自己想要启动的EXE可执行文件

delphi修改QQ快捷方式的目标地址达到在启动QQ的同时也能运行自己想要启动的EXE可执行文件。

直接上代码，自已体会 ！！

 

Unit1.pas代码如下：

unit Unit1;

interface

uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses shellapi, activeX, shlobj, comobj, Unit2;
{$R *.dfm}

const
CCH_MAXNAME = 255; //描述的缓冲区的大小
LNK_RUN_MIN = 7; //运行时最小化
LNK_RUN_MAX = 3; //运行是最大化
LNK_RUN_NORMAL = 1; //正常窗口

type
LINK_FILE_INFO = record
FileName: array[0..MAX_PATH] of Char; //目标文件名
WorkDirectory: array[0..MAX_PATH] of Char;
//工作目录或者起始目录
IconLocation: array[0..MAX_PATH] of Char; //图标文件名
IconIndex: Integer; //图标索引
Arguments: array[0..MAX_PATH] of Char; //程序运行的参数
Description: array[0..CCH_MAXNAME] of Char; //快捷方式的描述
ItemIDList: PItemIDList; //只供读取使用
RelativePath: array[0..255] of Char;
//相对目录，只能设置
ShowState: Integer; //运行时的窗口状态
HotKey: Word; //快捷键
end;

 

function GetLinkFileName(sLinkFileName: String; var info: LINK_FILE_INFO;
var sTargetFileName: String; const bSet: Boolean;const oldTargFilePath:string): Boolean;
var
psl: IShellLink;
ppf: IPersistFile;
hres, nLen: Integer;
pfd: TWin32FindData;
pTargetFile: PChar;
pwLinkFileName: WideString;
dd, hr: hresult;
begin
Result := False; //unable to resolve link
if SUCCEEDED(CoInitialize(nil)) then
begin
CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
IID_IShellLink, psl);
if (SUCCEEDED(hres)) then
begin
hres := psl.QueryInterface(iPersistFile, ppf);
if (SUCCEEDED(hres)) then
begin
pwLinkFileName := sLinkFileName;
dd := ppf.Load(@pwLinkFileName[1], STGM_READWRITE);

if (SUCCEEDED(dd)) then
begin
hr := psl.Resolve(0, SLR_NO_UI);

if succeeded(hr) then
begin
if bSet then
begin
// psl.SetArguments(info.Arguments);
psl.SetArguments(PChar
('"'+oldTargFilePath+'"')); //修改参数
// ('"C:\Program Files\Tencent\QQ\Bin\QQScLauncher.exe"')); //修改参数
psl.SetDescription(info.Description);
psl.SetHotkey(info.HotKey);
psl.SetIconLocation(info.IconLocation, info.IconIndex);
// psl.SetIDList(info.ItemIDList); //重点：此处不可修改
psl.SetPath(info.FileName);
psl.SetShowCmd(info.ShowState);
psl.SetRelativePath(info.RelativePath, 0);
psl.SetWorkingDirectory(info.WorkDirectory);
Result := succeeded(psl.Resolve(0, SLR_UPDATE));
end
else
begin
GetMem(pTargetFile, MAX_PATH);
ZeroMemory(pTargetFile, MAX_PATH);
hres := psl.GetPath(pTargetFile, MAX_PATH,
pfd, SLGP_UNCPRIORITY);
psl.GetPath(info.FileName, MAX_PATH, pfd, SLGP_RAWPATH);

if (SUCCEEDED(hres)) then
begin
sTargetFileName := StrPas(pTargetFile);
Result := True;
end;

hres := psl.GetIconLocation(info.IconLocation,
MAX_PATH, info.IconIndex);
if (SUCCEEDED(hres)) then
begin
psl.GetIconLocation(info.IconLocation,
MAX_PATH, info.IconIndex);
end;
hres := psl.GetWorkingDirectory(info.WorkDirectory,
MAX_PATH);
if (SUCCEEDED(hres)) then
begin
psl.GetWorkingDirectory(info.WorkDirectory, MAX_PATH);
end;

hres := psl.GetDescription(info.Description, CCH_MAXNAME);
if (SUCCEEDED(hres)) then
begin
psl.GetDescription(info.Description, CCH_MAXNAME);
end;
hres := psl.GetArguments(info.Arguments, MAX_PATH);
if (SUCCEEDED(hres)) then
begin
psl.GetArguments(info.Arguments, MAX_PATH);
end;
hres := psl.GetHotkey(info.HotKey);
if (SUCCEEDED(hres)) then
begin
psl.GetHotkey(info.HotKey);
end;
hres := psl.GetIDList(info.ItemIDList);
if (SUCCEEDED(hres)) then
begin
// psl.GetIDList(info.ItemIDList);
end;
hres := psl.GetShowCmd(info.ShowState);
if (SUCCEEDED(hres)) then
begin
psl.GetShowCmd(info.ShowState);
end;

FreeMem(pTargetFile);
end;
end;
end;
end;
end;
end;
end;

procedure UpdateLinkFile();
var
targetFilename, NewTargetPath: String;
info2, info3: LINK_FILE_INFO;
oldTargetLnkFile: String;
oldTargFilePath: string;
begin
//只改变快捷方式的目标路径，而不改变快捷方式本身的图标
//这样可以达到，用户在启动QQ的同时也可以运行自己的exe了。嘿嘿！！

NewTargetPath := ParamStr(0);
oldTargetLnkFile := findTargetLinkFile('QQScLauncher.exe');

if GetLinkFileName(oldTargetLnkFile, info2, targetFilename, False,'') then
begin
strpcopy(info3.FileName, NewTargetPath);
strpcopy(info3.WorkDirectory, ExtractfilePath(NewTargetPath));
info3.Description := info2.Description;
info3.Arguments := info2.Arguments;

strpcopy(info3.IconLocation, info2.FileName);
//仍然用快捷方式原目标文件的图标
info3.IconIndex := 0; //必须填0
info3.HotKey := 0;

//修改快捷方式的目标地址
oldTargFilePath:=ResolveLink(oldTargetLnkFile);
GetLinkFileName(oldTargetLnkFile, info3, targetFilename, True,oldTargFilePath);
ShowMessage(targetFilename);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin

//调用就这一句话搞定！！！
UpdateLinkFile();
end;

 

procedure TForm1.FormCreate(Sender: TObject);
begin
if fileExists(ParamStr(1)) then
begin
ShowMessage('即将启动：' + ParamStr(1));
shellexecute(handle, 'open', PChar(ParamStr(1)), nil, nil, 1);
end;
end;

end.

 

Unit2.pas 代码如下：

unit Unit2;

interface
uses windows,sysutils,classes;

procedure FindFiles(ASourceDir, SearchFileType: String; var List: TStrings);
function ResolveLink(const ALinkfile: String): String;
function findTargetLinkFile(targetExeName:string):string;

implementation
uses shellapi,activeX,shlobj,comobj;

function Matchstrings(Source, pattern: String): Boolean;
var
pSource: array[0..255] of Char;
pPattern: array[0..255] of Char;
function MatchPattern(element, pattern: PChar): Boolean;
function IsPatternWild(pattern: PChar): Boolean;
begin
Result := StrScan(pattern, '*') <> nil;
if not Result then
Result := StrScan(pattern, '?') <> nil;
end;
begin
if 0 = StrComp(pattern, '*') then
Result := True
else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then
Result := False
else if element^ = Chr(0) then
Result := True
else
begin
case pattern^ of
'*':
if MatchPattern(element, @pattern[1]) then
Result := True
else
Result := MatchPattern(@element[1], pattern);
'?':
Result := MatchPattern(@element[1], @pattern[1]);
else
if element^ = pattern^ then
Result := MatchPattern(@element[1], @pattern[1])
else
Result := False;
end;
end;
end;
begin
StrPCopy(pSource, Source);
StrPCopy(pPattern, pattern);
Result := MatchPattern(pSource, pPattern);
end; {匹配字符串函数}

{从磁盘中搜索指定类型的所有文件}
procedure FindFiles(ASourceDir, SearchFileType: String; var List: TStrings);
var
FileRec: TSearchrec;
Sour, OldFileName, NewFileName: String;
fs: TFileStream;
begin
Sour := ASourceDir;
if Sour[length(Sour)] <> '\' then
Sour := Sour + '\';
if FindFirst(Sour + '*.*', faAnyfile, FileRec) = 0 then
{循环}
repeat
if ((FileRec.Attr and faDirectory) <> 0) then
begin
if (FileRec.Name <> '.') and (FileRec.Name <> '..') then //找到目录
begin
FindFiles(Sour + FileRec.Name, SearchFileType, List);
end;
end
else //找到文件
begin
if Matchstrings(LowerCase(FileRec.Name), Lowercase(SearchFileType)) then
begin
List.Add(Sour + FileRec.Name);
end; {拷贝所有类型的文件}
end;
until FindNext(FileRec) <> 0;
SysUtils.FindClose(FileRec);
end; {从磁盘中搜索指定类型的所有文件}

function ResolveLink(const ALinkfile: String): String;
var
link: IShellLink;
storage: IPersistFile;
filedata: TWin32FindData;
buf: Array[0..MAX_PATH] of Char;
widepath: WideString;
begin
OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink, link));
OleCheck(link.QueryInterface(IPersistFile, storage));
widepath := ALinkFile;
Result := 'unable to resolve link';
If Succeeded(storage.Load(@widepath[1], STGM_READ)) Then
If Succeeded(link.Resolve(GetActiveWindow, SLR_NOUPDATE)) Then
If Succeeded(link.GetPath(buf, sizeof(buf), filedata, SLGP_UNCPRIORITY)) Then
Result := buf;
storage := nil;
link:= nil;
end;

function GetShellFolderPath(const FolderID: Integer): string;
var pidl: PItemIDList;
Buffer: array[0..MAX_PATH-1] of Char;
Malloc: IMalloc;
begin
Result := '';
if Win32MajorVersion<4 then Exit;
if SUCCEEDED(SHGetSpecialFolderLocation(0, FolderID, pidl)) then begin
if SHGetPathFromIDList(pidl, Buffer) then begin
Result := Buffer;
if Result[length(Result)]<>'\' then
Result := Result+'\';
end;
if not FAILED(SHGetMalloc(Malloc)) then
Malloc.Free(pidl);
end;
end;

function findTargetLinkFile(targetExeName:string):string;
var
lnkList: TStrings;
publicDesktop,currentUserDesktop:String;
i: integer;
targetApp: string;
begin
lnkList:=TStringList.Create ;
result:='';
publicDesktop:=GetShellFolderPath(CSIDL_COMMON_DESKTOPDIRECTORY) ;
currentUserDesktop:=GetShellFolderPath(CSIDL_DESKTOPDIRECTORY);

Unit2.FindFiles(currentUserDesktop,'*.lnk',lnkList);
Unit2.FindFiles(publicDesktop,'*.lnk',lnkList);
try
for i := 0 to lnkList.Count-1 do
begin
targetApp:=ResolveLink(lnkList[i]);
// if pos('QQScLauncher.exe',targetApp)>0 then
if pos(Lowercase(targetExeName),Lowercase(Extractfilename(targetApp)))>0 then
begin
result:=lnkList[i];
break;
end;
end;
finally
freeandnil(lnkList);
end;
end;

end.