MiTec/MSICS/MSI_Devices.pas

{*******************************************************}
{       MiTeC System Information Component Suite        }
{                Devices Detection Part                 }
{                version 14.5.0                         }
{                                                       }
{        Copyright (c) 1997-2021 Michal Mutl            }
{                                                       }
{*******************************************************}

{$INCLUDE Compilers.inc}


unit MSI_Devices;

interface

uses {$IFDEF RAD9PLUS}
     WinAPI.Windows, System.SysUtils, System.Classes,
     WinAPI.ActiveX, System.Win.ComObj, MiTeC_SS,
     {$ELSE}
     Windows, SysUtils, Classes, ActiveX, ComObj, MiTeC_SS,
     {$ENDIF}
     MSI_Common, MSI_Defs, MiTeC_NTDDK;

const
  StorageFolderName = 'Devices';

type
  TDevice = record
    ClassGUID: TGUID;
    Name,
    ClassName,
    ClassDesc,
    ClassIcon,
    FriendlyName,
    Description,
    GUID,
    Manufacturer,
    Location: String;
    PCINumber,
    DeviceNumber,
    FunctionNumber,
    UINumber: Integer;
    HardwareID,
    SymbolicLink,
    Subkey,
    Parent,
    DeviceParam,
    Driver,
    DriverDate,
    DriverVersion,
    DriverProvider,
    DriverKey: string;
    InfPath,
    Service,
    ServiceName,
    ServiceGroup: string;
    ServiceType: integer;
    ImagePath: string;
    RegKey: string;
    ResourceListKey,
    ResourceListValue: string;
    VendorID,
    DeviceID,
    SubSysID,
    Revision: Cardinal;
    DriverDatetime,
    InstallDate,
    FirstInstallDate,
    LastArrivalDate,
    LastRemovalDate: TDateTime;
    InstallID,
    IconPath: string;
  end;

  TDeviceList = array of TDevice;

  TResourceItem = record
    Resource: string;
    Share: CM_SHARE_DISPOSITION;
    Device: string;
    DeviceClassGUID :TGUID;
  end;

  TResourceList = array of TResourceItem;

  {$IFDEF RAD9PLUS} [ComponentPlatformsAttribute(pidWin32 or pidWin64)] {$ENDIF}
  TMiTeC_Devices = class(TMiTeC_Component)
  private
    FCount: integer;
    FDeviceList: TDeviceList;
    FCheckControl: Boolean;
    FComputer: string;
    FSC: string;
    function GetCount: integer;
    function GetDevice(Index: integer): TDevice;
    function GetDeviceCount: integer;
    //procedure ScanDevices_Registry(var ADeviceList: TDeviceList);
    procedure ScanDevices_CfgMgr(var ADeviceList: TDeviceList);
    procedure ClearList;
    function Add(ARecord: TDevice): Integer;
    function GetDeviceByName(AName: string): TDevice;
    procedure Sort;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Clear; override;
    procedure RefreshData(AScanObjects: TScanObjects = soAll); override;
    procedure SaveToStorage(const AFilename: string; var AWriteHeader: Boolean; AFormat: integer = 0; const AComment: string=''; ACodeStream: TCodeStreamProcedure = nil); override;
    function LoadFromStorage(const AFilename: string; var AReadHeader: boolean; ACodeStream: TCodeStreamProcedure = nil): boolean; override;
    procedure GetResourceList(var RL: TResourceList);
    function GetDeviceByHardwareID(AHWID: string): Integer;
    function GetDeviceByHardwareIDAndDriver(AHWID,ADriver: string): Integer;
    property Devices[Index: integer]: TDevice read GetDevice;
    property DeviceByName[AName: string]: TDevice read GetDeviceByName;
  published
    property CheckControl: Boolean read FCheckControl write FCheckControl;
    property DeviceCount: integer read GetCount stored False;

    property Computer: string read FComputer stored False;
    property SoundCard: string read FSC stored False;
  end;

procedure GetDeviceResources(ADevice: TDevice; var DR: TDeviceResources);

implementation

uses {$IFDEF RAD9PLUS}
     System.Win.Registry,
     {$ELSE}
     Registry,
     {$ENDIF}
     MiTeC_Routines, MiTeC_StrUtils, MiTeC_Datetime, MiTeC_RegUtils, MiTeC_CfgMgrSetupAPI;

procedure GetDeviceResources(ADevice: TDevice; var DR: TDeviceResources);
begin
  with OpenRegistryReadOnly do
    try
      RootKey:=HKEY_LOCAL_MACHINE;
      if OpenKey(Adevice.ResourceListKey,False) then begin
        ReadDeviceResourcesFromRegistry(CurrentKey,ADevice.ResourceListValue,DR);
        CloseKey;
      end;
    finally
      Free;
    end;
end;

procedure GetDeviceService(AGUID :string; var AName, AGroup, AImage: string; var AType: integer);
var
  s: string;
  rc: Integer;
const
  rvName = 'DisplayName';
  rvGroup = 'Group';
  rvType = 'Type';
  rvImage = 'ImagePath';
  rkClass = {HKEY_LOCAL_MACHINE}'\SYSTEM\CurrentControlSet\Services';
begin
  if AGUID='' then
    Exit;
  AName:=ReadRegistryValueAsString(HKEY_LOCAL_MACHINE,rkClass+'\'+AGUID,rvName,False);
  if Pos(';',AName)>0 then
    AName:=Copy(Aname,Pos(';',Aname)+1,1024);
  AGroup:=ReadRegistryValueAsString(HKEY_LOCAL_MACHINE,rkClass+'\'+AGUID,rvGroup,False);
  AImage:=ReadRegistryValueAsString(HKEY_LOCAL_MACHINE,rkClass+'\'+AGUID,rvImage,False);
  s:=ReadRegistryValueAsString(HKEY_LOCAL_MACHINE,rkClass+'\'+AGUID,rvType,False);
  Val(s,AType,rc);
end;

function GetDeviceLastArrival(AKey: string): TDatetime;
var
  rki: TRegKeyInfo;
begin
  Result:=0;
  with OpenRegistryReadOnly do
    try
      RootKey:=HKEY_LOCAL_MACHINE;
      if OpenKey(IncludeTrailingPathDelimiter(AKey)+'Control',False) then begin
        GetKeyInfo(rki);
        Result:={$IFNDEF FPC}FileTimeTodateTime{$ENDIF}(rki.FileTime);
        REsult:=UTCToSystemTime(Result);
        CloseKey;
      end;
    finally
      Free;
    end;
end;

procedure GetDeviceDriver(AGUID :string; var ARecord: TDevice);
var
  rkClass: string;
const
  rkClassNT = {HKEY_LOCAL_MACHINE}'\SYSTEM\CurrentControlSet\Control\Class';
  rvDate = 'DriverDate';
  rvVersion = 'DriverVersion';
  rvProvider = 'ProviderName';
  rvINFPath = 'InfPath';
begin
  rkClass:=rkClassNT;
  AGUID:=StringReplace(AGUID,'\\','\',[rfReplaceAll,rfIgnoreCase]);
  with OpenRegistryReadOnly do
    try
      RootKey:=HKEY_LOCAL_MACHINE;
      if OpenKey(rkClass+'\'+AGUID,False) then begin
        ARecord.DriverDate:=ReadString(rvDate);
        ARecord.DriverVersion:=ReadString(rvVersion);
        ARecord.DriverProvider:=ReadString(rvProvider);
        ARecord.InfPath:=ReadString(rvInfPath);
        CloseKey;
      end;
    finally
      Free;
    end;
end;

{ TMiTeC_Devices }

constructor TMiTeC_Devices.Create;
begin
  inherited Create(AOwner);
  FCheckControl:=OS<osWin8;
  FComputer:='';
  FSC:='';
end;

destructor TMiTeC_Devices.Destroy;
begin
  ClearList;
  inherited;
end;

function TMiTeC_Devices.GetCount: integer;
begin
  Result:=Length(FDeviceList);
end;

function TMiTeC_Devices.GetDevice(Index: integer): TDevice;
begin
  Result:=FDeviceList[Index];
end;

function TMiTeC_Devices.GetDeviceByHardwareID(AHWID: string): Integer;
var
  i: Integer;
begin
  Result:=-1;
  for i:=0 to High(FDeviceList) do
    if SameText(FDeviceList[i].HardwareID,AHWID) then begin
      Result:=i;
      Break;
    end;
end;

function TMiTeC_Devices.GetDeviceByHardwareIDAndDriver(AHWID,
  ADriver: string): Integer;
var
  i: Integer;
begin
  Result:=-1;
  for i:=0 to High(FDeviceList) do
    if SameText(FDeviceList[i].HardwareID,AHWID) and SameText(FDeviceList[i].Driver,ADriver) then begin
      Result:=i;
      Break;
    end;
end;

function TMiTeC_Devices.GetDeviceByName(AName: string): TDevice;
var
  i,j: Integer;
begin
  j:=-1;
  ResetMemory(Result,SizeOf(Result));
  for i:=0 to High(FDeviceList) do begin
    if SameText(FDeviceList[i].Name,AName) then begin
      Result:=FDeviceList[i];
      Break;
    end;
    if SameText(FDeviceList[i].Driver,AName) then
      j:=i;
  end;
  if (Result.Name='') and (j>-1) then
    Result:=FDeviceList[j];
end;

function TMiTeC_Devices.GetDeviceCount: integer;
begin
  Result:=Length(FDeviceList);
end;

procedure TMiTeC_Devices.RefreshData;
var
  i,k,p: Integer;
begin
  inherited;
  ScanDevices_CfgMgr(FDeviceList);
  Sort;
  FCount:=GetDeviceCount;
  FComputer:='';
  FSC:='';
  k:=-1;
  for i:=0 to DeviceCount-1 do begin
    if SameText(Devices[i].ClassName,'Computer') and (FComputer='') then
      FComputer:=Devices[i].Name;

    if SameText(Devices[i].ClassName,'Media') then begin
      p:=Pos('AUDIO',Devices[i].HardwareID);
      if (Devices[i].PCINumber>-1) or (p>0) then
        if (Devices[i].FunctionNumber<k) or (p>0) then begin
          k:=Devices[i].FunctionNumber;
          FSC:=Devices[i].Name;
        end;
    end;
  end;

  SetDataAvail(True);
end;

procedure TMiTeC_Devices.SaveToStorage;
var
  stg: IStorage;
  SS: TStructuredStorage;
  Sub: TStructuredStorage;

procedure WriteToStream(AIndex: Integer);
var
  strm: TStorageStream;
  sl: TStringList;
begin
    sl:=TStringList.Create;
    try
      WriteStrProperty(sl,'Name',Self.Devices[AIndex].Name);
      WriteStrProperty(sl,'ClassName',Self.Devices[AIndex].ClassName);
      WriteStrProperty(sl,'ClassDesc',Self.Devices[AIndex].ClassDesc);
      WriteStrProperty(sl,'ClassIcon',Self.Devices[AIndex].ClassIcon);
      WriteStrProperty(sl,'FriendlyName',Self.Devices[AIndex].FriendlyName);
      WriteStrProperty(sl,'Description',Self.Devices[AIndex].Description);
      WriteStrProperty(sl,'GUID',Self.Devices[AIndex].GUID);
      WriteStrProperty(sl,'Manufacturer',Self.Devices[AIndex].Manufacturer);
      WriteStrProperty(sl,'Location',Self.Devices[AIndex].Location);
      WriteStrProperty(sl,'HardwareID',Self.Devices[AIndex].HardwareID);
      WriteStrProperty(sl,'Parent',Self.Devices[AIndex].Parent);
      WriteStrProperty(sl,'SymbolicLink',Self.Devices[AIndex].SymbolicLink);
      WriteStrProperty(sl,'DeviceParam',Self.Devices[AIndex].DeviceParam);
      WriteStrProperty(sl,'Driver',Self.Devices[AIndex].Driver);
      WriteStrProperty(sl,'DriverDate',Self.Devices[AIndex].DriverDate);
      WriteStrProperty(sl,'DriverVersion',Self.Devices[AIndex].DriverVersion);
      WriteStrProperty(sl,'DriverProvider',Self.Devices[AIndex].DriverProvider);
      WriteStrProperty(sl,'InfPath',Self.Devices[AIndex].InfPath);
      WriteStrProperty(sl,'Service',Self.Devices[AIndex].Service);
      WriteStrProperty(sl,'ServiceName',Self.Devices[AIndex].ServiceName);
      WriteStrProperty(sl,'ServiceGroup',Self.Devices[AIndex].ServiceGroup);
      WriteIntProperty(sl,'ServiceType',Self.Devices[AIndex].ServiceType);
      WriteStrProperty(sl,'RegKey',Self.Devices[AIndex].RegKey);
      WriteStrProperty(sl,'ResourceListKey',Self.Devices[AIndex].ResourceListKey);
      WriteStrProperty(sl,'ResourceListValue',Self.Devices[AIndex].ResourceListValue);
      WriteIntProperty(sl,'PCINumber',Self.Devices[AIndex].PCINumber);
      WriteIntProperty(sl,'DeviceNumber',Self.Devices[AIndex].DeviceNumber);
      WriteIntProperty(sl,'FunctionNumber',Self.Devices[AIndex].FunctionNumber);
      WriteIntProperty(sl,'UINumber',Self.Devices[AIndex].UINumber);
      WriteIntProperty(sl,'VendorID',Self.Devices[AIndex].VendorID);
      WriteIntProperty(sl,'DeviceID',Self.Devices[AIndex].DeviceID);
      WriteIntProperty(sl,'SubSysID',Self.Devices[AIndex].SubSysID);
      WriteIntProperty(sl,'Revision',Self.Devices[AIndex].Revision);
      WriteDtProperty(sl,'LastArrivalDate',Self.Devices[AIndex].LastRemovalDate);
      strm:=Sub.OpenStream(Format(strm_Item,[AIndex]),STG_OPEN,True);
      try
        SaveToEncodedStream(sl,strm,ACodeStream);
      finally
        strm.Free;
      end;
    finally
      sl.Free;
    end;
end;

var
  i: Integer;
begin
  inherited SaveToStorage(AFilename,AWriteHeader,AFormat,AComment,ACodeStream);
  if StgIsStorageFile(PWideChar(WideString(AFileName)))<>S_OK then
    OleCheck(StgCreateDocFile(PWideChar(WideString(AFileName)),STG_CREATE_OPEN,0,stg))
  else
    OleCheck(StgOpenStorage(PWideChar(WideString(AFileName)),nil,STG_OPEN,nil,LongInt(nil),stg));
  SS:=TStructuredStorage.Create(nil,stg);
  try
    SS.DeleteElement(StorageFolderName);
    Sub:=SS.OpenSubStorage(StorageFolderName,STG_OPEN,True);
    try
      for i:=0 to Self.DeviceCount-1 do
        WriteToStream(i);
    finally
      Sub.Free;
    end;
  finally
    SS.Free;
  end;
end;

procedure TMiTeC_Devices.ScanDevices_CfgMgr(var ADeviceList: TDeviceList);
var
  dinfo: TSPDevInfoData;
  intf: TSPDeviceInterfaceData;
  pdidd: PSPDeviceInterfaceDetailData;
  n,pt: Cardinal;
  i: Integer;
  hdev: HDEVINFO;
  g: TGUID;
  ft: TFiletime;
  buf: array[0..{$IFDEF UNICODE}512{$ELSE}255{$ENDIF}] of byte;
  wbuf: array[0..512] of byte;
  dr: TDevice;
  hid: string;
begin
  Clear;
  hdev:=SetupDiGetClassDevs(nil,nil,0,DIGCF_ALLCLASSES or DIGCF_PRESENT or DIGCF_PROFILE);
  if (INVALID_HANDLE_VALUE<>THandle(hdev)) then
    try
      i:=0;
      pt:=0;
      dinfo.cbSize:=sizeof(TSPDevInfoData);
      while SetupDiEnumDeviceInfo(hDev,i,dinfo) do begin
        ResetMemory(dr,sizeof(dr));
        dr.UINumber:=-1;
        Zeromemory(@buf,sizeof(buf));
        hid:='';
        intf.cbSize:=sizeof(TSPDeviceInterfaceData);
        if SetupDiCreateDeviceInterface(hDev,dinfo,dinfo.ClassGuid,nil,0,@intf) then begin
          n:=0;
          SetupDiGetDeviceInterfaceDetail(hdev,@intf,nil,0,n,nil);
          if (GetLastError=ERROR_INSUFFICIENT_BUFFER) then begin
            pdidd:=AllocMem(n);
            try
              pdidd.cbSize:=SizeOf(TSPDeviceInterfaceDetailData);
              dinfo.cbSize:=sizeof(TSPDevInfoData);
              if (SetupDiGetDeviceInterfaceDetail(hdev,@intf,pdidd,n,n,@dinfo)) then begin
                dr.SymbolicLink:=PChar(@(pdidd.DevicePath));
                hid:=UpperCase(FastStringReplace(Copy(dr.SymbolicLink,5,Pos('{',dr.SymbolicLink)-5),'#','\'));
                dr.RegKey:='\SYSTEM\CurrentControlSet\Enum\'+hid;

                dr.ClassName:=GetString(hdev,dinfo,SPDRP_CLASS);
                dr.ClassGUID:=GetGUID(hdev,dinfo,SPDRP_CLASSGUID);
                dr.GUID:=GUIDToString(dr.ClassGUID);
                dr.Description:=GetString(hdev,dinfo,SPDRP_DEVICEDESC);
                dr.HardwareID:=ExtractFilename(GetString(hdev,dinfo,SPDRP_HARDWAREID));
                dr.Manufacturer:=GetString(hdev,dinfo,SPDRP_MFG);
                dr.FriendlyName:=GetString(hdev,dinfo,SPDRP_FRIENDLYNAME);
                dr.Location:=GetString(hdev,dinfo,SPDRP_LOCATION_INFORMATION);
                dr.Service:=GetString(hdev,dinfo,SPDRP_SERVICE);
                dr.DriverKey:=GetString(hdev,dinfo,SPDRP_DRIVER);
                dr.UINumber:=GetDWORD(hdev,dinfo,SPDRP_UI_NUMBER);
              end;
              finally
                FreeMem(pdidd);
              end;
            end;
        end else
          dr.ClassGUID:=dinfo.ClassGuid;

        Zeromemory(@buf,sizeof(buf));
        SetupDiGetClassDescription(dr.ClassGUID,@buf,sizeof(buf),@n);
        dr.ClassDesc:=string(PChar(@buf));
        if Assigned(SetupDiGetDeviceProperty) then begin
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_Class,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.ClassName:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_ClassGuid,pt,@wbuf,sizeof(wbuf),nil,0);
          Move(wbuf[0],g,sizeof(g));
          dr.ClassGUID:=g;
          dr.GUID:=GUIDToString(g);
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_FriendlyName,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.FriendlyName:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_DeviceDesc,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.Description:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_Manufacturer,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.Manufacturer:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_HardwareIds,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.HardwareID:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_UINumber,pt,@wbuf,sizeof(wbuf),nil,0);
          if GetLastError=0 then
            Move(wbuf[0],dr.UINumber,sizeof(Cardinal));

          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_Parent,pt,@wbuf,sizeof(wbuf),nil,0);
          if GetLastError=0 then
            dr.Parent:=IncludeTrailingPathDelimiter({$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf))));

          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_Service,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.Service:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_LocationInfo,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.Location:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));

          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_Driver,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.DriverKey:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_DriverDesc,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.Driver:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_DriverVersion,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.DriverVersion:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_DriverProvider,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.DriverProvider:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_DriverDate,pt,@wbuf,sizeof(wbuf),nil,0);
          Move(wbuf[0],ft,sizeof(ft));
          dr.DriverDatetime:=FileTimeTodatetime(ft);
          dr.DriverDate:=DateTimeToStr(dr.DriverDatetime);

          Zeromemory(@wbuf,sizeof(wbuf));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_InstanceId,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.InstallID:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_InstallDate,pt,@wbuf,sizeof(wbuf),nil,0);
          Move(wbuf[0],ft,sizeof(ft));
          dr.InstallDate:=FileTimeTodatetime(ft,True);
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_FirstInstallDate,pt,@wbuf,sizeof(wbuf),nil,0);
          Move(wbuf[0],ft,sizeof(ft));
          dr.FirstInstallDate:=FileTimeTodatetime(ft,True);
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_LastArrivalDate,pt,@wbuf,sizeof(wbuf),nil,0);
          Move(wbuf[0],ft,sizeof(ft));
          dr.LastArrivalDate:=FileTimeTodatetime(ft,True);
          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_Device_LastRemovalDate,pt,@wbuf,sizeof(wbuf),nil,0);
          Move(wbuf[0],ft,sizeof(ft));
          dr.LastRemovalDate:=FileTimeTodatetime(ft,True);

          SetupDiGetDeviceProperty(hDev,@dinfo,@DEVPKEY_DeviceClass_Icon,pt,@wbuf,sizeof(wbuf),nil,0);
          dr.IconPath:={$IFNDEF UNICODE}WideToAnsi{$ENDIF}(WideString(PWideChar(@wbuf)));

          if (dr.SymbolicLink='') and (dr.InstallID<>'') then begin
            dr.SymbolicLink:='\\?\'+FastStringReplace(dr.InstallID,'\','#')+'#'+dr.GUID;
            dr.RegKey:='\SYSTEM\CurrentControlSet\Enum\'+dr.InstallID;
          end;
        end;

        if Trim(dr.FriendlyName)='' then
          dr.Name:=dr.Description
        else
          dr.Name:=dr.FriendlyName;
        GetDeviceService(dr.Service,dr.ServiceName,dr.ServiceGroup,dr.ImagePath,dr.ServiceType);
        if Assigned(SetupDiGetDeviceProperty) then
          ParseHardwareID(dr.HardwareID,dr.VendorID,dr.DeviceID,dr.SubSysID,dr.Revision)
        else begin
          ParseHardwareID(hid,dr.VendorID,dr.DeviceID,dr.SubSysID,dr.Revision);
          GetDeviceDriver(dr.DriverKey,dr);
          dr.LastArrivalDate:=GetDeviceLastArrival(dr.RegKey);
        end;
        GetLocation(dr.Location,dr.PCINumber,dr.DeviceNumber,dr.FunctionNumber);
        GetResourceListLocation(dr.RegKey,dr.ResourceListKey,dr.ResourceListValue);
        if hid<>'' then
          dr.HardwareID:=hid;

        if dr.ClassDesc='' then
          dr.ClassDesc:='Other devices';
        if (dr.Name<>'') then
          Add(dr);
        inc(i);
      end;
    finally
      SetupDiDestroyDeviceInfoList(hdev);
    end;
end;

(*
procedure TMiTeC_Devices.ScanDevices_Registry(var ADeviceList: TDeviceList);

const
  rkClassNT = {HKEY_LOCAL_MACHINE}'\SYSTEM\CurrentControlSet\Control\Class';

function GetSymbolicLink(AHwId,ASubkey: string): string;
const
  rk = {HKEY_LOCAL_MACHINE\}'SYSTEM\CurrentControlSet\Control\DeviceClasses';
  rvSN = 'SymbolicLink';
var
  i: Integer;
  sl1: TStringList;
  s,d: string;
begin
  Result:='';
  with OpenRegistryReadOnly do
    try
      RootKey:=HKEY_LOCAL_MACHINE;
      if OpenKey(rk,False) then begin
        sl1:=TStringList.Create;
        try
          d:='#';
          s:='?';
          sl1.Text:=AHwId;
          if sl1.Count>0 then
            AHwId:=StringReplace(sl1[0],'\',d,[rfReplaceAll,rfIgnoreCase])
          else
            Exit;
          s:=Format('##%s#%s#%s',[s,AHwId,ASubkey]);
          sl1.Clear;
          GetKeynames(sl1);
          CloseKey;
          for i:=0 to sl1.Count-1 do begin
            d:=Format('%s\%s\%s%',[rk,sl1[i],s])+'#'+sl1[i]+'\#';
            if OpenKey(d,False) then begin
              if ValueExists(rvSN) then begin
                Result:=ReadString(rvSN);

              end;
              CloseKey;
              Break;
           end;
         end;
        finally
          sl1.Free;
        end;
      end;
    finally
      Free;
    end;
end;

procedure GetDeviceClassName(const AGUID :string; var ARecord: TDevice);
var
  i,p :integer;
  sl :TStringList;
  s,rkClass: string;
const
  rvClass = 'Class';
  rvIcon = 'Icon';
  rvLink = 'Link';
  rvClassDesc = 'ClassDesc';
begin
  rkClass:=rkClassNT;
  with OpenRegistryReadOnly do begin
    RootKey:=HKEY_LOCAL_MACHINE;
    if OpenKey(rkClass,False) then begin
      sl:=TStringList.Create;
      GetKeyNames(sl);
      CloseKey;
      i:=sl.IndexOf(AGUID);
      if i>-1 then
        if OpenKey(rkClass+'\'+sl[i],False) then begin
          ARecord.ClassName:=ReadString(rvClass);
          case GetDataType(rvIcon) of
            rdString, rdExpandString: ARecord.ClassIcon:=ReadString(rvIcon);
            rdInteger: ARecord.ClassIcon:=IntToStr(ReadInteger(rvIcon));
            else  ARecord.ClassIcon:='';
          end;
          ARecord.ClassDesc:=ReadString('');
          if ARecord.ClassDesc='' then
            ARecord.ClassDesc:=ReadString(rvClassDesc);
          if (Pos('@',ARecord.ClassDesc)=1) then begin
            s:=Copy(ARecord.ClassDesc,2,Length(ARecord.ClassDesc));
            p:=Pos(',',s);
            if p>0 then begin
              ARecord.ClassDesc:=Copy(s,1,p-1);
              ARecord.ClassDesc:=ExpandEnvVars(ARecord.ClassDesc);
              s:=Copy(s,p+1,255);
              try
                ARecord.ClassDesc:=LoadResourceString(ARecord.ClassDesc,Cardinal(StrToInt(s)));
              except
                ARecord.ClassDesc:=s;
                if Pos(';',ARecord.ClassDesc)>0 then
                  ARecord.ClassDesc:=Copy(ARecord.ClassDesc,Pos(';',ARecord.ClassDesc)+1,1024);
              end;
            end;
          end;
          CloseKey;
        end;
      sl.Free;
    end;
    Free;
  end;
end;

var
  i,j,k,l :integer;
  sl1,sl2,sl3,sl4 :TStringList;
  dr: TDevice;
  rkEnum: string;
  Data: PChar;
  rki: TRegKeyInfo;
const
  rvClass = 'Class';
  rvGUID = 'ClassGUID';
  rvDesc = 'DeviceDesc';
  rvFriend = 'FriendlyName';
  rvMfg = 'Mfg';
  rvService = 'Service';
  rvLoc = 'LocationInformation';
  rvDriver = 'Driver';
  rvHID = 'HardwareID';
  rvHWKey = 'HardwareKey';

  rkEnumNT = {HKEY_LOCAL_MACHINE}'\SYSTEM\CurrentControlSet\Enum';
  rkConfigManager = {HKEY_DYN_DATA}'\Config Manager\Enum';

  rkControl = 'Control';
  rkDeviceParams = 'Device Parameters';

begin
  Clear;
  sl1:=TStringList.Create;
  sl2:=TStringList.Create;
  sl3:=TStringList.Create;
  sl4:=TStringList.Create;
  Data:=Allocmem(255);

  try

  rkEnum:=rkEnumNT;
  with OpenRegistryReadOnly do
    try
      RootKey:=HKEY_LOCAL_MACHINE;
      if OpenKey(rkEnumNT,False) then begin
        GetKeyNames(sl1);
        CloseKey;
        for i:=0 to sl1.Count-1 do
          if OpenKey(rkEnum+'\'+sl1[i],False) then begin
            GetKeyNames(sl2);
            CloseKey;
            for j:=0 to sl2.count-1 do
              if OpenKey(rkEnum+'\'+sl1[i]+'\'+sl2[j],False) then begin
                GetKeyNames(sl3);
                CloseKey;
                for k:=0 to sl3.count-1 do
                  if OpenKey(rkEnum+'\'+sl1[i]+'\'+sl2[j]+'\'+sl3[k],False) then begin
                    if not FCheckControl or KeyExists(rkControl) then begin
                      ResetMemory(dr,SizeOf(dr));
                      with dr do begin
                        GUID:=UpperCase(ReadString(rvGUID));
                        FriendlyName:=ReadString(rvFriend);
                        if Pos(';',FriendlyName)>0 then
                          FriendlyName:=Copy(FriendlyName,Pos(';',FriendlyName)+1,1024);
                        Description:=ReadString(rvDesc);
                        if Pos(';',Description)>0 then
                          Description:=Copy(Description,Pos(';',Description)+1,1024);
                        if Trim(FriendlyName)='' then
                          Name:=Description
                        else
                          Name:=FriendlyName;
                        Manufacturer:=ReadString(rvMfg);
                        if Pos(';',Manufacturer)>0 then
                          Manufacturer:=Copy(Manufacturer,Pos(';',Manufacturer)+1,1024);
                        Service:=ReadString(rvService);
                        Location:=ReadString(rvLoc);
                        GetLocation(Location,PCINumber,DeviceNumber,FunctionNumber);
                        if Location='' then
                          GetDeviceService(sl1[i],Location,ServiceGroup,ImagePath,ServiceType);
                        GetDeviceClassName(GUID,dr);
                        if dr.ClassName='' then
                          dr.ClassName:=ReadString(rvClass);
                        Driver:=ReadString(rvDriver);
                        GetDeviceDriver(Driver,dr);
                        GetDeviceService(Service,ServiceName,ServiceGroup,ImagePath,ServiceType);
                        RegKey:=rkEnum+'\'+sl1[i]+'\'+sl2[j]+'\'+sl3[k];
                        Subkey:=sl3[k];
                        HardwareID:=ReadRegistryValueAsString(HKEY_LOCAL_MACHINE,rkEnum+'\'+sl1[i]+'\'+sl2[j]+'\'+sl3[k],rvHID,False);
                        ParseHardwareID(HardwareID,VendorID,DeviceID,SubSysID,Revision);
                        GetResourceListLocation(RegKey,ResourceListKey,ResourceListValue);
                        SymbolicLink:=GetSymbolicLink(HardwareId,Subkey);
                        CloseKey;
                        if OpenKey(rkEnum+'\'+sl1[i]+'\'+sl2[j]+'\'+sl3[k]+'\'+rkControl,False) then begin
                          GetKeyInfo(rki);
                          TimeStamp:={$IFNDEF FPC}FileTimeTodateTime{$ENDIF}(rki.FileTime);
                          if ConvertTimeToLocal then
                            TimeStamp:=UTCToSystemTime(TimeStamp);
                          CloseKey;
                        end;
                        if OpenKey(rkEnum+'\'+sl1[i]+'\'+sl2[j]+'\'+sl3[k]+'\'+rkDeviceParams,False) then begin
                          GetValueNames(sl4);
                          for l:=0 to sl4.Count-1 do
                            if (sl4[l]<>'') and (GetDataType(sl4[l])=rdString) then begin
                              Deviceparam:=ReadString(sl4[l]);
                              Break;
                            end;
                          CloseKey;
                        end;
                      end;
                      if (Trim(dr.ClassName)<>'') and (GetDeviceByHardwareIDAndDriver(dr.HardwareID,dr.Driver)=-1) then begin
                        dr.DeviceClass:=GetDeviceClass(dr.ClassName);
                        Add(dr);
                      end;
                    end;
                  end;
              end;
          end;
      end;
  finally
    Free;
  end;

  finally
  Freemem(Data);
  sl1.free;
  sl2.Free;
  sl3.Free;
  sl4.Free;
  end;
end;
*)

procedure TMiTeC_Devices.Sort;
var
 i,j: Integer;
 r: TDevice;
begin
  for i:=0 to High(FDeviceList)-1 do
    for j:=High(FDeviceList) downto i+1 do
      if CompareStr(Format('%s_%s',[FDeviceList[i].ClassName,FDeviceList[i].Name]),
                    Format('%s_%s',[FDeviceList[j].ClassName,FDeviceList[j].Name]))>0 then begin
        r:=FDeviceList[i];
        FDeviceList[i]:=FDeviceList[j];
        FDeviceList[j]:=r;
      end;
end;

function TMiTeC_Devices.Add;
begin
  SetLength(FDeviceList,Length(FDeviceList)+1);
  Result:=High(FDeviceList);
  FDeviceList[Result]:=ARecord;
end;

procedure TMiTeC_Devices.Clear;
begin
  ClearList;
end;

procedure TMiTeC_Devices.ClearList;
var
  i: Integer;
begin
  for i:=0 to High(FDeviceList) do
    Finalize(FDeviceList[i]);
  Finalize(FDeviceList);
end;

procedure TMiTeC_Devices.GetResourceList(var RL: TResourceList);
var
  i,j: Integer;
  d: TDevice;
  dr: TDeviceResources;
  ri: TResourceItem;
begin
  SetLength(RL,0);
  for i:=0 to DeviceCount-1 do begin
    d:=Devices[i];
    if LiveData and not Empty(d.ResourceListKey) then begin
      GetDeviceResources(d,dr);
      for j:=0 to High(dr.Resources) do begin
        ri.Share:=dr.Resources[j].ShareDisposition;
        ri.Device:=d.Name;
        ri.DeviceClassGUID:=d.ClassGUID;
        case dr.Resources[j].Typ of
          CmResourceTypePort:
            ri.Resource:=Format('%s %4.4x - %4.4x',[DeviceResourceTypeStr(dr.Resources[j].Typ),
                                           dr.Resources[j].Port.Start.QuadPart,
                                           dr.Resources[j].Port.Start.QuadPart+dr.Resources[j].Port.Length-1]);
          CmResourceTypeInterrupt:
            ri.Resource:=Format('%s %2.2d',[DeviceResourceTypeStr(dr.Resources[j].Typ),
                                         dr.Resources[j].Interrupt.Vector]);
          CmResourceTypeMemory:
            ri.Resource:=Format('%s %8.8x - %8.8x',[DeviceResourceTypeStr(dr.Resources[j].Typ),
                                           dr.Resources[j].Memory.Start.QuadPart,
                                           dr.Resources[j].Memory.Start.QuadPart+dr.Resources[j].Memory.Length-1]);
          CmResourceTypeDma:
            ri.Resource:=Format('%s %2.2d',[DeviceResourceTypeStr(dr.Resources[j].Typ),
                                         dr.Resources[j].DMA.Channel]);
        end;
        if not Empty(ri.Resource) then begin
          SetLength(RL,Length(RL)+1);
          RL[High(RL)]:=ri;
        end;
      end;
    end;
  end;
end;

function TMiTeC_Devices.LoadFromStorage;
var
  stg: IStorage;
  SS, Sub: TStructuredStorage;

function ReadFromStream(AIndex: integer): boolean;
var
  strm: TStorageStream;
  sl: TStringList;
  dr: TDevice;
begin
  Result:=False;
  try
    strm:=Sub.OpenStream(Format(strm_Item,[AIndex]),STG_READ_INSTORAGE,False) except strm:=nil end;
    if strm<>nil then
      try
        sl:=TStringList.Create;
        try
          LoadFromEncodedStream(strm,sl,ACodeStream);
          dr.Name:=ReadStrProperty(sl,'Name');
          dr.ClassName:=ReadStrProperty(sl,'ClassName');
          dr.ClassDesc:=ReadStrProperty(sl,'ClassDesc');
          dr.ClassIcon:=ReadStrProperty(sl,'ClassIcon');
          dr.FriendlyName:=ReadStrProperty(sl,'FriendlyName');
          dr.Description:=ReadStrProperty(sl,'Description');
          dr.GUID:=ReadStrProperty(sl,'GUID');
          dr.ClassGUID:=StringToGUID(dr.GUID);
          dr.Manufacturer:=ReadStrProperty(sl,'Manufacturer');
          dr.Location:=ReadStrProperty(sl,'Location');
          dr.PCINumber:=ReadIntProperty(sl,'PCINumber');
          dr.DeviceNumber:=ReadIntProperty(sl,'DeviceNumber');
          dr.FunctionNumber:=ReadIntProperty(sl,'FunctionNumber');
          dr.UINumber:=ReadIntProperty(sl,'UINumber');
          dr.HardwareID:=ReadStrProperty(sl,'HardwareID');
          dr.Parent:=ReadStrProperty(sl,'Parent');
          dr.SymbolicLink:=ReadStrProperty(sl,'SymbolicLink');
          dr.DeviceParam:=ReadStrProperty(sl,'DeviceParam');
          dr.Driver:=ReadStrProperty(sl,'Driver');
          dr.DriverDate:=ReadStrProperty(sl,'DriverDate');
          dr.DriverVersion:=ReadStrProperty(sl,'DriverVersion');
          dr.DriverProvider:=ReadStrProperty(sl,'DriverProvider');
          dr.InfPath:=ReadStrProperty(sl,'InfPath');
          dr.Service:=ReadStrProperty(sl,'Service');
          dr.ServiceName:=ReadStrProperty(sl,'ServiceName');
          dr.ServiceGroup:=ReadStrProperty(sl,'ServiceGroup');
          dr.ServiceType:=ReadIntProperty(sl,'ServiceType');
          dr.RegKey:=ReadStrProperty(sl,'RegKey');
          dr.ResourceListKey:=ReadStrProperty(sl,'ResourceListKey');
          dr.ResourceListValue:=ReadStrProperty(sl,'ResourceListValue');
          dr.VendorID:=ReadIntProperty(sl,'VendorID');
          dr.DeviceID:=ReadIntProperty(sl,'DeviceID');
          dr.SubSysID:=ReadIntProperty(sl,'SubSysID');
          dr.Revision:=ReadIntProperty(sl,'Revision');
          dr.LastArrivalDate:=ReadDtProperty(sl,'LastArrivalDate');
          if dr.LastArrivalDate=0 then
            dr.LastArrivalDate:=ReadDtProperty(sl,'TimeStamp');
          if Trim(dr.ClassName)<>'' then
            Add(dr);
          Result:=True;
        finally
          sl.Free;
        end;
      finally
        strm.Free;
      end;
end;

var
  i: Integer;
begin
  Clear;
  Result:=inherited LoadFromStorage(AFilename,AReadHeader,ACodeStream);
  if StgIsStorageFile(PWideChar(WideString(AFileName)))<>S_OK then
    Exit;
  OleCheck(StgOpenStorage(PWideChar(WideString(AFileName)),nil,STG_READ_INSTORAGE,nil,LongInt(nil),stg));
  SS:=TStructuredStorage.Create(nil,stg);
  try
    try
      Sub:=SS.OpenSubStorage(StorageFolderName,STG_READ_INSTORAGE,False);
    except
      Exit;
    end;
    try
      i:=0;
      while ReadFromStream(i) do
        Inc(i);
      Result:=Result or (i>0);
      SetDataAvail(True);
    finally
      Sub.Free;
    end;
  finally
    SS.Free;
  end;
end;

end.