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