серийный номер монитора

[vitalik]

Как получить модель и серийный номер монитора(firemonkey)? Нашел  класс WmiMonitorID и GetMonitorDetails и тип Dword но не пойму как приладить так чтобы выдавали  данные о по по которым можно будет идентифицировать монитор но не пойму как приладить так чтобы выдавали  данные о по по которым можно будет идентифицировать монитор 

Изменено 16 августа пользователем vitalik

[Олег Киреев]

Может так подойдёт? :

function GetWMIObject(const objectName: String): IDispatch;
  var
    chEaten: Integer;
    BindCtx: IBindCtx;
    Moniker: IMoniker;
  begin
    OleCheck(CreateBindCtx(0, bindCtx));
    OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten, Moniker));
    OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));
  end;

procedure TForm2.SpeedButton1Click(Sender: TObject);
var
  objWMIService : OLEVariant;
  colItems      : OLEVariant;
  colItem       : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin
objWMIService := GetWMIObject('winmgmts:\\localhost\root\CIMV2');
  colItems      := objWMIService.ExecQuery('SELECT * FROM Win32_DesktopMonitor','WQL',0);
  oEnum         := IUnknown(colItems._NewEnum) as IEnumVariant;
  if oEnum.Next(1, colItem, iValue) = 0 then
  begin
    Memo1.Lines.Add('Подпись     '+(colItem.Caption));
    Memo1.Lines.Add('Описание  '+(colItem.Description));
    Memo1.Lines.Add('Идентификатор устройства    '+(colItem.DeviceID));
    Memo1.Lines.Add('Manufacturer '+(colItem.MonitorManufacturer));
    Memo1.Lines.Add('Тип         '+(colItem.MonitorType));
  end;
end;
 

 

[vitalik]

В принципе работает. Но почему-то не показывает, не производителя не серийный номер.

[OnePeople]

Через реестр ищите мониторы по пути Компьютер\HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Enum\DISPLAY

Далее ищите в мониторе EDID

Далее парсите EDID structure, version 1.4 https://en.wikipedia.org/wiki/Extended_Display_Identification_Data

unit Unit3;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Layouts,
  FMX.ListBox, FMX.Controls.Presentation, FMX.StdCtrls, Winapi.Windows, Registry;

type
  TForm3 = class(TForm)
    lst1: TListBox;
    btn1: TButton;
    function GetAllMonitorName : TStringList;
    procedure btn1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

{$R *.fmx}

procedure TForm3.btn1Click(Sender: TObject);
var
 monitors: TStringList;
  I: Integer;
begin
 monitors := GetAllMonitorName;
 lst1.BeginUpdate;
 for I := 0 to monitors.Count - 1 do
  begin
    lst1.Items.Add(monitors.Strings[i]);
  end;
 lst1.EndUpdate;
end;

function TForm3.GetAllMonitorName: TStringList;
const
  Key = '\SYSTEM\CurrentControlSet\Enum\DISPLAY\';
type
  IBMString = type Ansistring(1253);
var
  Registry: TRegistry;
  H, i, j, k : Integer;
  MonitorName : IBMString;
  EDID : array [0 .. 127] of Byte;
  subKeysNames, subKeys : TStringList;
begin
  Result := TStringList.Create;

  subKeys := TStringList.Create;
  subKeysNames := TStringList.Create;
  Registry := TRegistry.Create(KEY_READ);
  Registry.RootKey := HKEY_LOCAL_MACHINE;
  try
    try
      Registry.OpenKeyReadOnly(Key);
      Registry.GetKeyNames(subKeysNames);
    finally
      Registry.CloseKey;
    end;

    for h := 0 to subKeysNames.Count - 1 do
    begin
      try
        Registry.OpenKeyReadOnly(Key + subKeysNames[h]);
        Registry.GetKeyNames(subKeys);
      finally
        Registry.CloseKey;
      end;

      for i := 0 to subKeys.Count - 1 do
      begin
        try
          if registry.OpenKeyReadOnly(Key + subKeysNames[h] + '\' + subKeys[i]) then
          begin
            if registry.OpenKeyReadOnly(Key + subKeysNames[h] + '\' + subKeys[i] + '\' + 'Device Parameters') then
            begin
              Registry.ReadBinaryData('EDID', EDID, 128);
              Registry.CloseKey;
            end;
            MonitorName := '';
            for j := 0 to 3 do
            begin
              if (EDID[54 + 18 * j] = 0) and
                 (EDID[55 + 18 * j] = 0) and
                 (EDID[56 + 18 * j] = 0) and
                 (EDID[57 + 18 * j] = $FC) and
                 (EDID[58 + 18 * j] = 0) then
              begin
                k := 0;
                while (EDID[59 + 18 * j + k] <> $A) and (k < 13) do
                  Inc(k);
                SetString(MonitorName, PAnsiChar(@EDID[59 + 18 * j]), k);
                Break;
              end;
            end;
            Result.Add(MonitorName);
          end;
        finally
          Registry.CloseKey;
        end;
      end;
    end;
  finally
    subKeys.Free;
    Registry.Free;
    subKeysNames.Free;
  end;
end;

end.

 

Изменено 21 августа пользователем OnePeople

[Олег Киреев]

СпасиБО. Это работает на Win 10. Пожалуйста напишите то же для Win 7. С Уважением.