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('Software\Microsoft\Windows\CurrentVersion\uninstall', 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 = '\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell 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.
浙公网安备 33010602011771号