[Razor12911]

try this one, you can remove the DXGI code if you having issues and just use the registry. Should produce the same results.

uses
Winapi.Windows, Winapi.DXGI, System.Win.Registry;

type
  TGPUInfo = record
    FName: String;
    FSize: Integer;
  end;

  TGPUs = array of TGPUInfo;

procedure GetGPUs(out V: TGPUs; UseDXGI: Boolean);
  function Align(Value, Size: Integer): Integer;
  begin
    if Value mod Size <> 0 then
      Result := Succ(Max(0, Value div Size)) * Size
    else
      Result := Value;
  end;

const
  RegPath = 'SOFTWARE\Microsoft\DirectX\';
var
  GPUInfo: TGPUInfo;
  i, j, k, l: Integer;
  x: Int64;
  riid: TGUID;
  hr: HRESULT;
  pFactory: IDXGIFactory;
  pAdapter: IDXGIAdapter;
  dxAdapterDesc: DXGI_ADAPTER_DESC;
  Reg1: TRegIniFile;
  Reg2: TRegistry;
  SL: TStringList;
  mybool: Boolean;
begin
  Reg1 := TRegIniFile.Create(KEY_READ or KEY_WOW64_64KEY);
  SL := TStringList.Create;
  Reg1.RootKey := HKEY_LOCAL_MACHINE;
  if Reg1.OpenKey(RegPath, False) then
    Reg1.ReadSections(SL);
  Reg1.Free;
  Reg2 := TRegistry.Create(KEY_READ or KEY_WOW64_64KEY);
  Reg2.RootKey := HKEY_LOCAL_MACHINE;
  if UseDXGI then
  begin
    riid := StringToGUID('{7b7166ec-21c7-44ae-b21a-c9ae321ae369}');
    pFactory := nil;
    hr := CreateDXGIFactory(riid, pFactory);
    if (hr = S_OK) and Assigned(pFactory) then
    begin
      pAdapter := nil;
      i := 0;
      while (pFactory.EnumAdapters(i, pAdapter) = S_OK) do
      begin
        FillChar(dxAdapterDesc, SizeOf(DXGI_ADAPTER_DESC), 0);
        hr := pAdapter.GetDesc(dxAdapterDesc);
        if hr = S_OK then
        begin
          GPUInfo.FName := dxAdapterDesc.Description;
          GPUInfo.FSize := IfThen(dxAdapterDesc.DedicatedVideoMemory = 0,
            dxAdapterDesc.DedicatedSystemMemory,
            dxAdapterDesc.DedicatedVideoMemory) shr 20;
          if dxAdapterDesc.DedicatedSystemMemory = 0 then
            for j := 0 to SL.Count - 1 do
            begin
              if Reg2.OpenKey(RegPath + SL[j], False) then
              begin
                if (Reg2.ReadString('Description') = GPUInfo.FName) then
                  if Reg2.ReadBinaryData('DedicatedVideoMemory', x, x.Size) = x.Size
                  then
                  begin
                    GPUInfo.FSize := x shr 20;
                    break;
                  end;
                Reg2.CloseKey;
              end;
            end;
          GPUInfo.FSize := Align(GPUInfo.FSize, IfThen(GPUInfo.FSize < 512,
            32, 512));
          Insert(GPUInfo, V, Length(V));
        end;
        inc(i);
      end;
    end;
  end;
  for j := 0 to SL.Count - 1 do
  begin
    if Reg2.OpenKey(RegPath + SL[j], False) then
    begin
      mybool := True;
      for i := Low(V) to High(V) do
      begin
        if (Reg2.ReadString('Description') = V[i].FName) then
        begin
          mybool := False;
          break;
        end;
      end;
      if mybool then
      begin
        GPUInfo.FName := Reg2.ReadString('Description');
        x := 0;
        if Reg2.ReadBinaryData('DedicatedVideoMemory', x, x.Size) = x.Size then
          x := x shr 20;
        if x = 0 then
          if Reg2.ReadBinaryData('DedicatedSystemMemory', x, x.Size) = x.Size
          then
            x := x shr 20;
        GPUInfo.FSize := x;
        GPUInfo.FSize := Align(GPUInfo.FSize, IfThen(GPUInfo.FSize < 512,
          32, 512));
        Insert(GPUInfo, V, Length(V));
      end;
    end;
    Reg2.CloseKey;
  end;
  SL.Free;
  Reg2.Free;
  for i := Low(V) to High(V) do
  begin
    k := 0;
    for j := Low(V) to High(V) do
      if V[j].FSize >= k then
      begin
        k := V[i].FSize;
        l := j
      end;
    GPUInfo := V[i];
    V[i] := V[l];
    V[l] := GPUInfo;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
  MyGPUs: TGPUs;
begin
  Memo1.Lines.Clear;
  GetGPUs(MyGPUs, True);
  for i := Low(MyGPUs) to High(MyGPUs) do
    Memo1.Lines.Add(MyGPUs[i].FName + ' (' + MyGPUs[i].FSize.ToString + ' MB)');
end;