delphi 枚举 Windows 声音

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)
   Memo1: TMemo;
   Button1: TButton;
   procedure Button1Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}


procedure GetRegistrySounds;
var
 phkResult: HKEY;
 dwIndex: DWORD;
 HResult: Longint;
 lpName: LPWSTR;
 SubKeyNames: TStringList;
 i: Integer;
 Len: Longint;
 Buf: array[0..1023] of Char;
 dwResult: DWORD;
 ResultString: string;
begin
 SubKeyNames := TStringList.Create;
 try
   dwIndex := 0;
   lpName := StrAlloc(1024);
   HResult := RegOpenKeyEx(HKEY_CURRENT_USER, PChar('AppEvents\Schemes\Apps\.Default'), 0, KEY_READ, phkResult);
   if (HResult = ERROR_SUCCESS) then
     begin
       while (HResult = ERROR_SUCCESS) do
         begin
           HResult := RegEnumKey(phkResult, dwIndex, lpName, 1024);
           if (HResult = ERROR_SUCCESS) then
             begin
               SubKeyNames.Add(lpName);
               Inc(dwIndex);
             end;
          end;
       RegCloseKey(phkResult);
     end;
   StrDispose(lpName);
   for i := 0 to (SubKeyNames.Count - 1) do
     begin
       if (RegOpenKeyEx(HKEY_CURRENT_USER, PChar('AppEvents\Schemes\Apps\.Default\' + SubKeyNames[i] + '\.Current'), 0, KEY_READ, phkResult) = ERROR_SUCCESS) then
         begin
           Len := 1024 * SizeOf(Char);
           case RegQueryValueEx(phkResult, PChar(''), nil, nil, PByte(@Buf[0]), @Len) of
             ERROR_SUCCESS:
               SetString(ResultString, Buf, Len div SizeOf(Char) - 1);
             ERROR_MORE_DATA:
               begin
                 SetLength(ResultString, Len div SizeOf(Char) - 1);
                 if (RegQueryValueEx(phkResult, PChar(''), nil, nil, PByte(ResultString), @Len) = ERROR_SUCCESS) then
                   SetLength(ResultString, Len div SizeOf(Char) - 1)
               else
                 ResultString := '';
               end;
           end;
           RegCloseKey(phkResult);
           if (ResultString <> '') then
             begin
               dwResult := ExpandEnvironmentStrings(PChar(ResultString), buf, 1024);
               if (dwResult <> 0) then
                 ResultString := string(buf);
               // here we have a result to work with
               Form1.Memo1.Lines.Add(ResultString);
             end;
         end;
     end;
 finally
   SubKeyNames.Free;
 end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
GetRegistrySounds;
end;

end.