Delphi 读取软件卸载信息和桌面图标列表-木庄网络博客

本文整理自网络，侵删。
 引用的单元文件到下面链接去找：
http://www.delphitop.com/html/wenjian/2976.html

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Registry, StdCtrls, ComCtrls, IOUtils, Types;

type
  TForm2 = class(TForm)
    pgc1: TPageControl;
    ts1: TTabSheet;
    lst1: TListBox;
    btn1: TButton;
    ts2: TTabSheet;
    btn2: TButton;
    lst2: TListBox;
    procedure btn1Click(Sender: TObject);
    procedure btn2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

function GetShellFolders(strDir: string): string;
function GetTarget(const LinkFile: string): string;

implementation

uses ShlObj, ActiveX, ComObj;
{$R *.dfm}

/// 
/// 读取可卸载软件信息
/// 
/// 
procedure TForm2.btn1Click(Sender: TObject);
var
  reg: TRegistry;
  myList: TStringList;
  i: integer;
  curkey, SName: string;
  hasUn: Boolean;
begin
  reg := TRegistry.Create;
  myList := TStringList.Create;
  reg.RootKey := HKEY_LOCAL_MACHINE;
  if reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\uninstall', False)
    then
  Begin
    reg.GetKeyNames(myList);
    curkey := reg.CurrentPath;
    reg.CloseKey;
    for i := 0 to myList.Count - 1 do
      if reg.OpenKey(curkey + '\' + myList.Strings[i], False) then
      Begin
        if reg.ValueExists('DisplayName') then
          SName := reg.ReadString('DisplayName')
        else
          SName := myList.Strings[i];
        if reg.ValueExists('DisplayVersion') then
          SName := SName + ' 版本：' + reg.ReadString('DisplayVersion')
        else
          SName := myList.Strings[i];
        if reg.ValueExists('InstallSource') then
          SName := SName + ' 目录：' + reg.ReadString('InstallSource')
        else
          SName := myList.Strings[i];
        if reg.ValueExists('UnInstallString') then
        begin
          SName := SName + ' 卸载：' + reg.ReadString('UnInstallString');
          hasUn := True;
        end
        else
        begin
          SName := myList.Strings[i];
          hasUn := False;
        end;
        if hasUn then
          lst1.Items.Add(SName);
        // ShowMessage(SName);
        reg.CloseKey;
      end;
  end;
end;

function GetShellFolders(strDir: string): string;
const
  regPath = '\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
var
  reg: TRegistry;
  strFolders: string;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CURRENT_USER;
    if reg.OpenKey(regPath, False) then
    begin
      strFolders := reg.ReadString(strDir);
    end;
  finally
    reg.Free;
  end;
  result := strFolders;
end;

/// 
/// 读取桌面图标
/// 
/// 
procedure TForm2.btn2Click(Sender: TObject);
var
  path, str: string;
  files: TStringDynArray;
begin
  path := GetShellFolders('Desktop');
  files := TDirectory.GetFiles(path, '*.lnk');
  for str in files do
    lst2.Items.Add(str + ' 目标：' + GetTarget(str));
end;

function GetTarget(const LinkFile: string): string;
const
  IID_IPersistFile: TGUID = '{0000010B-0000-0000-C000-000000000046}';
var
  intfLink: IShellLink;
  IntfPersist: IPersistFile;
  pfd: _WIN32_FIND_DATA; //delphi10.4 用 _WIN32_FIND_DATAW
  bSuccess: Boolean;
begin
  result := '';
  intfLink := CreateComObject(CLSID_ShellLink) as IShellLink;
  SetString(result, nil, MAX_PATH);
  {
    Load方法的第二个参数还可以传递STGM_WRITE或STGM_READWRITE，表示对快捷方式信息的访问权限
    STGM_READ：只读
    STGM_WRITE：只写
    STGM_READWRITE：读写
    GetPath方法的第三个参数还可以传递SLGP_UNCPRIORITY或SLGP_SHORTPATH，表示返回的目标路径格式
    SLGP_UNCPRIORIT：UNC网络路径
    SLGP_SHORTPATH ：DOS 8.3格式路径
    SLGP_RAWPATH      : 长路径
    }
  bSuccess := (intfLink <> nil) and SUCCEEDED
    (intfLink.QueryInterface(IID_IPersistFile, IntfPersist)) and SUCCEEDED
    (IntfPersist.Load(PWideChar(WideString(LinkFile)), STGM_READ)) and SUCCEEDED
    (intfLink.GetPath(PChar(result), MAX_PATH, pfd, SLGP_RAWPATH));
  if not bSuccess then
    result := '';
end;

end.
Delphi 读取软件卸载信息和桌面图标列表

相关推荐

评论
