1 unit Main; 2 3 interface 4 5 uses 6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 Dialogs, Registry, StdCtrls, ComCtrls, IOUtils, Types; 8 9 type 10 TForm2 = class(TForm) 11 pgc1: TPageControl; 12 ts1: TTabSheet; 13 lst1: TListBox; 14 btn1: TButton; 15 ts2: TTabSheet; 16 btn2: TButton; 17 lst2: TListBox; 18 procedure btn1Click(Sender: TObject); 19 procedure btn2Click(Sender: TObject); 20 private 21 { Private declarations } 22 public 23 { Public declarations } 24 end; 25 26 var 27 Form2: TForm2; 28 29 function GetShellFolders(strDir: string): string; 30 function GetTarget(const LinkFile: string): string; 31 32 implementation 33 34 uses ShlObj, ActiveX, ComObj; 35 {$R *.dfm} 36 37 /// <summary> 38 /// 读取可卸载软件信息 39 /// </summary> 40 /// <param name="Sender"></param> 41 procedure TForm2.btn1Click(Sender: TObject); 42 var 43 reg: TRegistry; 44 myList: TStringList; 45 i: integer; 46 curkey, SName: string; 47 hasUn: Boolean; 48 begin 49 reg := TRegistry.Create; 50 myList := TStringList.Create; 51 reg.RootKey := HKEY_LOCAL_MACHINE; 52 if reg.OpenKey('SoftwareMicrosoftWindowsCurrentVersionuninstall', False) 53 then 54 Begin 55 reg.GetKeyNames(myList); 56 curkey := reg.CurrentPath; 57 reg.CloseKey; 58 for i := 0 to myList.Count - 1 do 59 if reg.OpenKey(curkey + '' + myList.Strings[i], False) then 60 Begin 61 if reg.ValueExists('DisplayName') then 62 SName := reg.ReadString('DisplayName') 63 else 64 SName := myList.Strings[i]; 65 if reg.ValueExists('DisplayVersion') then 66 SName := SName + ' 版本：' + reg.ReadString('DisplayVersion') 67 else 68 SName := myList.Strings[i]; 69 if reg.ValueExists('InstallSource') then 70 SName := SName + ' 目录：' + reg.ReadString('InstallSource') 71 else 72 SName := myList.Strings[i]; 73 if reg.ValueExists('UnInstallString') then 74 begin 75 SName := SName + ' 卸载：' + reg.ReadString('UnInstallString'); 76 hasUn := True; 77 end 78 else 79 begin 80 SName := myList.Strings[i]; 81 hasUn := False; 82 end; 83 if hasUn then 84 lst1.Items.Add(SName); 85 // ShowMessage(SName); 86 reg.CloseKey; 87 end; 88 end; 89 end; 90 91 function GetShellFolders(strDir: string): string; 92 const 93 regPath = 'SoftwareMicrosoftWindowsCurrentVersionExplorerShell Folders'; 94 var 95 reg: TRegistry; 96 strFolders: string; 97 begin 98 reg := TRegistry.Create; 99 try 100 reg.RootKey := HKEY_CURRENT_USER; 101 if reg.OpenKey(regPath, False) then 102 begin 103 strFolders := reg.ReadString(strDir); 104 end; 105 finally 106 reg.Free; 107 end; 108 result := strFolders; 109 end; 110 111 /// <summary> 112 /// 读取桌面图标 113 /// </summary> 114 /// <param name="Sender"></param> 115 procedure TForm2.btn2Click(Sender: TObject); 116 var 117 path, str: string; 118 files: TStringDynArray; 119 begin 120 path := GetShellFolders('Desktop'); 121 files := TDirectory.GetFiles(path, '*.lnk'); 122 for str in files do 123 lst2.Items.Add(str + ' 目标：' + GetTarget(str)); 124 end; 125 126 function GetTarget(const LinkFile: string): string; 127 const 128 IID_IPersistFile: TGUID = '{0000010B-0000-0000-C000-000000000046}'; 129 var 130 intfLink: IShellLink; 131 IntfPersist: IPersistFile; 132 pfd: _WIN32_FIND_DATA; 133 bSuccess: Boolean; 134 begin 135 result := ''; 136 intfLink := CreateComObject(CLSID_ShellLink) as IShellLink; 137 SetString(result, nil, MAX_PATH); 138 { 139 Load方法的第二个参数还可以传递STGM_WRITE或STGM_READWRITE，表示对快捷方式信息的访问权限 140 STGM_READ：只读 141 STGM_WRITE：只写 142 STGM_READWRITE：读写 143 GetPath方法的第三个参数还可以传递SLGP_UNCPRIORITY或SLGP_SHORTPATH，表示返回的目标路径格式 144 SLGP_UNCPRIORIT：UNC网络路径 145 SLGP_SHORTPATH ：DOS 8.3格式路径 146 SLGP_RAWPATH : 长路径 147 } 148 bSuccess := (intfLink <> nil) and SUCCEEDED 149 (intfLink.QueryInterface(IID_IPersistFile, IntfPersist)) and SUCCEEDED 150 (IntfPersist.Load(PWideChar(WideString(LinkFile)), STGM_READ)) and SUCCEEDED 151 (intfLink.GetPath(PChar(result), MAX_PATH, pfd, SLGP_RAWPATH)); 152 if not bSuccess then 153 result := ''; 154 end; 155 156 end.