home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kompon / d56 / MSYSINFO.ZIP / Source / MSI_Devices.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-07-24  |  12.3 KB  |  426 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       MiTeC System Information Component              }
  5. {               Device Detection Part                   }
  6. {           version 6.0 for Delphi 5,6                  }
  7. {                                                       }
  8. {       Copyright ⌐ 1997,2001 Michal Mutl               }
  9. {                                                       }
  10. {*******************************************************}
  11.  
  12. {$INCLUDE MITEC_DEF.INC}
  13.  
  14. unit MSI_Devices;
  15.  
  16. interface
  17.  
  18. uses
  19.   SysUtils, Windows, Classes;
  20.  
  21. type
  22.   TDeviceClass = (dcBattery, dcComputer, dcDiskDrive, dcDisplay, dcCDROM, dcfdc,
  23.                   dcFloppyDisk, dcGPS, dcHIDClass, dchdc, dc1394, dcImage, dcInfrared,
  24.                   dcKeyboard, dcMediumChanger, dcMTD, dcMouse, dcModem, dcMonitor,
  25.                   dcMultiFunction, dcPortSerial, dcNet, dcLegacyDriver,
  26.                   dcNtApm, dcUnknown, dcPCMCIA, dcPorts, dcPrinter, dcSCSIAdapter,
  27.                   dcSmartCardReader, dcMEDIA, dcVolume, dcSystem, dcTapeDrive,
  28.                   dcTapeController, dcTape, dcUSB);
  29.  
  30.   PDevice = ^TDevice;
  31.  
  32.   TDevice = record
  33.     ClassName,
  34.     ClassDesc,
  35.     ClassIcon,
  36.     FriendlyName,
  37.     Description,
  38.     GUID,
  39.     Manufacturer,
  40.     Location,
  41.     HardwareID,
  42.     DriverDate,
  43.     DriverVersion,
  44.     DriverProvider,
  45.     Service,
  46.     ServiceName,
  47.     ServiceGroup: string;
  48.     ServiceType: integer;
  49.     RegKey: string;
  50.     DeviceClass :TDeviceClass;
  51.   end;
  52.  
  53.   TDeviceList = TStringList;
  54.  
  55.   TDevices = class(TPersistent)
  56.   private
  57.     FCount: integer;
  58.     FDeviceList: TDeviceList;
  59.     function GetDevice(Index: integer): TDevice;
  60.     function GetDeviceCount: integer;
  61.     procedure ScanDevices(var ADeviceList: TDeviceList);
  62.     function GetDeviceClass(AClassName: string): TDeviceClass;
  63.  
  64.     procedure ClearList;
  65.   public
  66.     constructor Create;
  67.     destructor Destroy; override;
  68.     procedure GetInfo;
  69.     procedure Report(var sl :TStringList);
  70.     procedure GetDevicesByClass(ADeviceClass: TDeviceClass; var ADevices: TStrings);
  71.     property Devices[Index: integer]: TDevice read GetDevice;
  72.   published
  73.     property DeviceCount: integer read FCount {$IFNDEF D6PLUS} write FCount {$ENDIF};
  74.   end;
  75.  
  76. implementation
  77.  
  78. uses Registry, MiTeC_Routines;
  79.  
  80. const
  81.   DeviceClass :array[dcBattery..dcUSB] of string =
  82.                  ('Battery', 'Computer', 'DiskDrive', 'Display', 'CDROM', 'fdc',
  83.                   'FloppyDisk', 'GPS', 'HID', 'hdc', '1394', 'Image', 'Infrared',
  84.                   'Keyboard', 'MediumChanger', 'MTD', 'Mouse', 'Modem', 'Monitor',
  85.                   'MultiFunction', 'MultiPortSerial', 'Net', 'LegacyDriver',
  86.                   'NtApm', 'Unknown', 'PCMCIA', 'Ports', 'Printer', 'SCSIAdapter',
  87.                   'SmartCardReader', 'MEDIA', 'Volume', 'System', 'TapeDrive', 'TapeController', 'Tape', 'USB');
  88.  
  89. { TDevices }
  90.  
  91. constructor TDevices.Create;
  92. begin
  93.   FDeviceList:=TDeviceList.Create;
  94. end;
  95.  
  96. destructor TDevices.Destroy;
  97. begin
  98.   ClearList;
  99.   FDeviceList.Free;
  100.   inherited;
  101. end;
  102.  
  103. procedure TDevices.GetDevicesByClass;
  104. var
  105.   i,c: integer;
  106.   s: string;
  107. begin
  108.   ADevices.Clear;
  109.   c:=DeviceCount-1;
  110.   for i:=0 to c do
  111.     if Devices[i].DeviceClass=ADeviceClass then begin
  112.       if Trim(Devices[i].FriendlyName)='' then
  113.         s:=Devices[i].Description
  114.       else
  115.         s:=Devices[i].FriendlyName;
  116.       ADevices.Add(s);
  117.     end;
  118. end;
  119.  
  120. function TDevices.GetDevice(Index: integer): TDevice;
  121. begin
  122.   try
  123.     Result:=PDevice(FDeviceList.Objects[Index])^;
  124.   except
  125.   end;
  126. end;
  127.  
  128. function TDevices.GetDeviceClass(AClassName: string): TDeviceClass;
  129. var
  130.   i: TDeviceClass;
  131. begin
  132.   Result:=dcUnknown;
  133.   AClassName:=UpperCase(AClassName);
  134.   for i:=dcBattery to dcUSB do
  135.     if Pos(UpperCase(DeviceClass[i]),AClassName)=1 then begin
  136.       Result:=i;
  137.       Break;
  138.     end;
  139. end;
  140.  
  141. function TDevices.GetDeviceCount: integer;
  142. begin
  143.   Result:=FDeviceList.Count;
  144. end;
  145.  
  146. procedure TDevices.GetInfo;
  147. begin
  148.   ScanDevices(FDeviceList);
  149.   FDeviceList.Sort;
  150.   FCount:=GetDeviceCount;
  151. end;
  152.  
  153. procedure TDevices.Report(var sl: TStringList);
  154. var
  155.   i,c: integer;
  156.   s: string;
  157. begin
  158.   c:=DeviceCount;
  159.   with sl do begin
  160.     Add('[Devices]');
  161.     Add(Format('Count=%d',[c]));
  162.     for i:=0 to c-1 do begin
  163.       if Trim(Devices[i].FriendlyName)='' then
  164.         s:=Devices[i].Description
  165.       else
  166.         s:=Devices[i].FriendlyName;
  167.       Add(Format('[%s]',[s]));
  168.       Add(Format('Class Name=%s',[Devices[i].ClassDesc]));
  169.       Add(Format('Class GUID=%s',[Devices[i].GUID]));
  170.       Add(Format('Manufacturer=%s',[Devices[i].Manufacturer]));
  171.       Add(Format('Location=%s',[Devices[i].Location]));
  172.       Add(Format('Hardware ID=%s',[Devices[i].HardwareID]));
  173.       Add(Format('Driver Date=%s',[Devices[i].DriverDate]));
  174.       Add(Format('Driver Version=%s',[Devices[i].DriverVersion]));
  175.       Add(Format('Driver Provider=%s',[Devices[i].DriverProvider]));
  176.       Add(Format('Service Name=%s',[Devices[i].ServiceName]));
  177.       Add(Format('Service Group=%s',[Devices[i].ServiceGroup]));
  178.     end;
  179.   end;
  180. end;
  181.  
  182. procedure TDevices.ScanDevices(var ADeviceList: TDeviceList);
  183.  
  184. procedure GetDeviceClass(AGUID :string; var AClassName, AClassDesc, AClassIcon: string);
  185. var
  186.   i :integer;
  187.   sl :TStringList;
  188.   rkClass, vLink: string;
  189. const
  190.   rvClass = 'Class';
  191.   rvIcon = 'Icon';
  192.   rvLink = 'Link';
  193.  
  194.   rkClassNT = {HKEY_LOCAL_MACHINE\}'SYSTEM\CurrentControlSet\Control\Class';
  195.   rkClass9x = {HKEY_LOCAL_MACHINE\}'SYSTEM\CurrentControlSet\Services\Class';
  196. begin
  197.   if IsNT then
  198.     rkClass:=rkClassNT
  199.   else
  200.     rkClass:=rkClass9x;
  201.   with TRegistry.Create do begin
  202.     RootKey:=HKEY_LOCAL_MACHINE;
  203.     {$IFDEF D4PLUS}
  204.     if OpenKeyReadOnly(rkClass) then begin
  205.     {$ELSE}
  206.     if OpenKey(rkClass,False) then begin
  207.     {$ENDIF}
  208.       sl:=TStringList.Create;
  209.       GetKeyNames(sl);
  210.       CloseKey;
  211.       i:=sl.IndexOf(AGUID);
  212.       if i>-1 then
  213.         {$IFDEF D4PLUS}
  214.         if OpenKeyReadOnly(rkClass+'\'+sl[i]) then begin
  215.         {$ELSE}
  216.         if OpenKey(rkClass+'\'+sl[i],False) then begin
  217.         {$ENDIF}
  218.           AClassName:=ReadString(rvClass);
  219.           if not IsNT then begin
  220.             vLink:=ReadString(rvLink);
  221.             CloseKey;
  222.             {$IFDEF D4PLUS}
  223.             if not OpenKeyReadOnly(rkClass+'\'+vLink) then
  224.             {$ELSE}
  225.             if not OpenKey(rkClass+'\'+vLink,False) then
  226.             {$ENDIF}
  227.               Exit;
  228.           end;
  229.           AClassIcon:=ReadString(rvIcon);
  230.           AClassDesc:=ReadString('');
  231.           CloseKey;
  232.         end;
  233.       sl.Free;
  234.     end;
  235.     free;
  236.   end;
  237. end;
  238.  
  239. procedure GetDeviceDriver(AGUID :string; var ADate, AVersion, AProvider: string);
  240. var
  241.   rkClass: string;
  242. const
  243.   rvDate = 'DriverDate';
  244.   rvVersion = 'DriverVersion';
  245.   rvProvider = 'ProviderName';
  246.  
  247.   rkClassNT = {HKEY_LOCAL_MACHINE\}'SYSTEM\CurrentControlSet\Control\Class';
  248.   rkClass9x = {HKEY_LOCAL_MACHINE\}'SYSTEM\CurrentControlSet\Services\Class';
  249. begin
  250.   if IsNT then
  251.     rkClass:=rkClassNT
  252.   else
  253.     rkClass:=rkClass9x;
  254.   AGUID:=ReplaceStr(AGUID,'\\','\');  
  255.   with TRegistry.Create do begin
  256.     RootKey:=HKEY_LOCAL_MACHINE;
  257.     {$IFDEF D4PLUS}
  258.     if OpenKeyReadOnly(rkClass+'\'+AGUID) then begin
  259.     {$ELSE}
  260.     if OpenKey(rkClass+'\'+AGUID,False) then begin
  261.     {$ENDIF}
  262.       ADate:=ReadString(rvDate);
  263.       AVersion:=ReadString(rvVersion);
  264.       AProvider:=ReadString(rvProvider);
  265.       CloseKey;
  266.     end;
  267.     free;
  268.   end;
  269. end;
  270.  
  271. procedure GetDeviceService(AGUID :string; var AName, AGroup: string; var AType: integer);
  272. const
  273.   rvName = 'DisplayName';
  274.   rvGroup = 'Group';
  275.   rvType = 'Type';
  276.  
  277.   rkClass = {HKEY_LOCAL_MACHINE\}'SYSTEM\CurrentControlSet\Services';
  278. begin
  279.   with TRegistry.Create do begin
  280.     RootKey:=HKEY_LOCAL_MACHINE;
  281.     {$IFDEF D4PLUS}
  282.     if OpenKeyReadOnly(rkClass+'\'+AGUID) then begin
  283.     {$ELSE}
  284.     if OpenKey(rkClass+'\'+AGUID,False) then begin
  285.     {$ENDIF}
  286.       AGroup:=ReadString(rvGroup);
  287.       try
  288.         AName:=ReadString(rvName);
  289.         AGroup:=ReadString(rvGroup);
  290.         AType:=ReadInteger(rvType);
  291.       except
  292.         AName:='';
  293.       end;
  294.       CloseKey;
  295.     end;
  296.     free;
  297.   end;
  298. end;
  299.  
  300. var
  301.   i,j,k :integer;
  302.   sl1,sl2,sl3 :TStringList;
  303.   dr: PDevice;
  304.   rkEnum: string;
  305.   Data: PChar;
  306. const
  307.   rvClass = 'Class';
  308.   rvGUID = 'ClassGUID';
  309.   rvDesc = 'DeviceDesc';
  310.   rvFriend = 'FriendlyName';
  311.   rvMfg = 'Mfg';
  312.   rvService = 'Service';
  313.   rvLoc = 'LocationInformation';
  314.   rvDriver = 'Driver';
  315.   rvHID = 'HardwareID';
  316.  
  317.   rkEnumNT = {HKEY_LOCAL_MACHINE\}'SYSTEM\CurrentControlSet\Enum';
  318.   rkEnum9x = {HKEY_LOCAL_MACHINE\}'Enum';
  319.  
  320.   rkControl = 'Control';
  321.  
  322. begin
  323.   ClearList;
  324.   if IsNT then
  325.     rkEnum:=rkEnumNT
  326.   else
  327.     rkEnum:=rkEnum9x;
  328.   with TRegistry.Create do begin
  329.     RootKey:=HKEY_LOCAL_MACHINE;
  330.     {$IFDEF D4PLUS}
  331.     if OpenKeyReadOnly(rkEnum) then begin
  332.     {$ELSE}
  333.     if OpenKey(rkEnum,False) then begin
  334.     {$ENDIF}
  335.       sl1:=TStringList.Create;
  336.       sl2:=TStringList.Create;
  337.       sl3:=TStringList.Create;
  338.       Data:=StrAlloc(255);
  339.       GetKeyNames(sl1);
  340.       CloseKey;
  341.       for i:=0 to sl1.Count-1 do
  342.         if (IsNT or (not IsNT and (sl1[i]<>'Network'))) and
  343.           {$IFDEF D4PLUS}
  344.           OpenKeyReadOnly(rkEnum+'\'+sl1[i]) then begin
  345.           {$ELSE}
  346.           OpenKey(rkEnum+'\'+sl1[i],False) then begin
  347.           {$ENDIF}
  348.           GetKeyNames(sl2);
  349.           CloseKey;
  350.           for j:=0 to sl2.count-1 do
  351.             {$IFDEF D4PLUS}
  352.             if OpenKeyReadOnly(rkEnum+'\'+sl1[i]+'\'+sl2[j]) then begin
  353.             {$ELSE}
  354.             if OpenKey(rkEnum+'\'+sl1[i]+'\'+sl2[j],False) then begin
  355.             {$ENDIF}
  356.               GetKeyNames(sl3);
  357.               CloseKey;
  358.               for k:=0 to sl3.count-1 do
  359.                 {$IFDEF D4PLUS}
  360.                 if OpenKeyReadOnly(rkEnum+'\'+sl1[i]+'\'+sl2[j]+'\'+sl3[k]) then begin
  361.                 {$ELSE}
  362.                 if OpenKey(rkEnum+'\'+sl1[i]+'\'+sl2[j]+'\'+sl3[k],False) then begin
  363.                 {$ENDIF}
  364.                   if not IsNT or (IsNT and KeyExists(rkControl)) then begin
  365.                     new(dr);
  366.                     with dr^ do begin
  367.                       GUID:=UpperCase(ReadString(rvGUID));
  368.                       FriendlyName:=ReadString(rvFriend);
  369.                       Description:=ReadString(rvDesc);
  370.                       Manufacturer:=ReadString(rvMfg);
  371.                       Service:=ReadString(rvService);
  372.                       Location:=ReadString(rvLoc);
  373.                       if Location='' then
  374.                         GetDeviceService(sl1[i],Location,ServiceGroup,ServiceType);
  375.                       GetDeviceClass(GUID,Classname,ClassDesc,ClassIcon);
  376.                       if ClassName='' then
  377.                         ClassName:=ReadString(rvClass);
  378.                       GetDeviceDriver(ReadString(rvDriver),DriverDate,DriverVersion,DriverProvider);
  379.                       GetDeviceService(Service,ServiceName,ServiceGroup,ServiceType);
  380.                       RegKey:=rkEnum+'\'+sl1[i]+'\'+sl2[j]+'\'+sl3[k];
  381.                       try
  382.                         if ValueExists(rvHID) then begin
  383.                           ReadBinaryData(rvHID,Data^,255);
  384.                           HardWareID:=GetStrFromBuf(Data);
  385.                         end else
  386.                           HardwareID:='';
  387.                       except
  388.                         try
  389.                           HardwareID:=ReadString(rvHID);
  390.                         except
  391.                         end;
  392.                       end;
  393.                     end;
  394.                     if Trim(dr.ClassName)<>'' then begin
  395.                       dr.DeviceClass:=Self.GetDeviceClass(dr.ClassName);
  396.                       ADeviceList.AddObject(dr.Classname,TObject(dr));
  397.                     end else
  398.                       Dispose(dr);
  399.                   end;
  400.                   CloseKey;
  401.                 end;
  402.             end;
  403.         end;
  404.       sl1.free;
  405.       sl2.Free;
  406.       sl3.Free;
  407.       StrDispose(Data);
  408.     end;
  409.     free;
  410.   end;
  411. end;
  412.  
  413. procedure TDevices.ClearList;
  414. var
  415.   dr: PDevice;
  416. begin
  417.   while FDeviceList.count>0 do begin
  418.    dr:=PDevice(FDeviceList.Objects[FDeviceList.count-1]);
  419.    Dispose(dr);
  420.    FDeviceList.Delete(FDeviceList.count-1);
  421.   end;
  422. end;
  423.  
  424.  
  425. end.
  426.