請大家看完，如果就空餘時間清幫我解決一下這兩個問題！    http://delphi.ktop.com.tw/topic.php?TOPIC_ID=52975 http://delphi.ktop.com.tw/topic.php?TOPIC_ID=52950    { unit DHJSW_SystemInfo;    interface    uses   SysUtils, Windows, Classes,Registry, MMSystem, WinSock, Printers;//, DsgnIntf;    const   cAbout = 'Dong Haojie Software Component of SystemInfo 1.0 - Copyright ?2001-2002 Dong Haojie';      cSystem = 0;   cGDI = 1;   cUSER = 2;    type   {$IFDEF VER130}     {$DEFINE D4PLUS}   {$ENDIF}   {$IFDEF VER120}     {$DEFINE D4PLUS}   {$ENDIF}      {$IFDEF D4PLUS}      TLargInt = _LARGE_INTEGER;   {$ELSE}      TLargInt = TLargeInteger;      Int64 = TLargeInteger;      LongWord = DWORD;   {$ENDIF}      TStrBuf = array[0..11] of char;      TPlatFormType = (os9x,osNT4,os2K);      TCPUFeatures = class(TPersistent)   private     FSYSENTERExt: boolean;     FMTRR: boolean;     FModSpecReg: boolean;     FPageSizeExt: boolean;     FTimeStampCnt: boolean;     FMachineChkExc: boolean;     FMMX: boolean;     FPageAttrTable: boolean;     FPhysAddrExt: boolean;     FFXInstr: boolean;     FVirtModExt: boolean;     FPageGlobalExt: boolean;     FCMOVccOpcode: boolean;     FFPU: boolean;     FCMPXCHG8B: boolean;     FMachineCheck: boolean;     FAPIC: boolean;     FDebugExt: boolean;     FPageSizeExt36bit: boolean;   public     procedure GetFeaturesStr(AClear :boolean; AFeatures :TStringList);   published     property FXInstr :Boolean read FFXInstr write FFxInstr stored false;     property MMX :Boolean read FMMX write FMMX stored false;     property PageSizeExt36bit :Boolean read FPageSizeExt36bit write FPageSizeExt36bit stored false;     property PageAttrTable :Boolean read FPageAttrTable write FPageAttrTable stored false;     property CMOVccOpcode :Boolean read FCMOVccOpcode write FCMOVccOpcode stored false;     property MachineCheck :Boolean read FMachineCheck write FMachineCheck stored false;     property PageGloablExt :Boolean read FPageGlobalExt write FPageGlobalExt stored false;     property MTRR :Boolean read FMTRR write FMTRR stored false;     property SYSENTERExt :Boolean read FSYSENTERExt write FSYSENTERExt stored false;     property APIC :Boolean read FAPIC write FAPIC stored false;     property CMPXCHG8B :Boolean read FCMPXCHG8B write FCMPXCHG8B stored false;     property MachineChkExc :Boolean read FMachineChkExc write FMachineChkExc stored false;     property PhysAddrExt :Boolean read FPhysAddrExt write FPhysAddrExt stored false;     property ModSpecReg :Boolean read FModSpecReg write FModSpecReg stored false;     property TimeStampCnt :Boolean read FTimeStampCnt write FTimeStampCnt stored false;     property PageSizeExt :Boolean read FPageSizeExt write FPageSizeExt stored false;     property DebugExt :Boolean read FDebugExt write FDebugExt stored false;     property VirtModExt :Boolean read FVirtModExt write FVirtModExt stored false;     property FPU :Boolean read FFPU write FFPU stored false;   end;      TCPU = class(TPersistent)   private     FVendorID,     FVendor,     FSubModel: string;     FModel,     FCount,     FArchitecture,     FLevel,     FStepping,     FFamily,     FTyp,     FVendorNo,     FFreq :integer;     FCPUID :boolean;     FFeatures: TCPUFeatures;     function CPUIDExists: boolean;     procedure GetCPUID;     function GetCPUIDLevel :integer;     function GetCPUType :integer;     function GetCPUVendor :string;     function GetCPUVendorID :string;     function GetCPUFreqEx :extended;     function GetSubModel :string;   public     constructor Create;     destructor Destroy; override;     procedure GetInfo;     procedure Report(var sl :TStringList);   published     property CPUID :Boolean read FCPUID write FCPUID stored false;     property Architecture :integer read FArchitecture write FArchitecture stored false;     property Level :integer read FLevel write FLevel stored false;     property Count :integer read FCount write FCount stored false;     property Vendor :string read FVendor write FVendor stored false;     property VendorID :string read FVendorID write FVendorID stored false;     property Freq :integer read FFreq write FFreq stored false;     property Family :integer read FFamily write FFamily stored false;     property Stepping :integer read FStepping write FStepping stored false;     property Model :integer read FModel write FModel stored false;     property Typ :integer read FTyp write FTyp stored false;     property Features :TCPUFeatures read FFeatures write FFeatures;     property SubModel :string read FSubModel write FSubModel stored false;   end;      TMemory = class(TPersistent)   private     FMaxAppAddress: integer;     FVirtualTotal: integer;     FPageFileFree: integer;     FVirtualFree: integer;     FPhysicalFree: integer;     FAllocGranularity: integer;     FMinAppAddress: integer;     FMemoryLoad: integer;     FPhysicalTotal: integer;     FPageFileTotal: integer;     FPageSize: integer;   public     procedure GetInfo;     procedure Report(var sl :TStringList);   published     property PhysicalTotal :integer read FPhysicalTotal write FPhysicalTotal stored false;     property PhysicalFree :integer read FPhysicalFree write FPhysicalFree stored false;     property VirtualTotal :integer read FVirtualTotal write FVirtualTotal stored false;     property VirtualFree :integer read FVirtualFree write FVirtualFree stored false;     property PageFileTotal :integer read FPageFileTotal write FPageFileTotal stored false;     property PageFileFree :integer read FPageFileFree write FPageFileFree stored false;     property MemoryLoad :integer read FMemoryLoad write FMemoryLoad stored false;     property AllocGranularity :integer read FAllocGranularity write FAllocGranularity stored false;     property MaxAppAddress :integer read FMaxAppAddress write FMaxAppAddress stored false;     property MinAppAddress :integer read FMinAppAddress write FMinAppAddress stored false;     property PageSize :integer read FPageSize write FPageSize stored false;   end;      PWindow = ^TWindow;   TWindow = record     ClassName,     Text :string;     Handle,     Process,     Thread :longword;     ParentWin,     WndProc,     Instance,     ID,     UserData,     Style,     ExStyle :longint;     Rect,     ClientRect :TRect;     Atom,     ClassBytes,     WinBytes,     ClassWndProc,     ClassInstance,     Background,     Cursor,     Icon,     ClassStyle :longword;     Styles,     ExStyles,     ClassStyles :tstringlist;     Visible :boolean;   end;      TOperatingSystem = class(TPersistent)   private     FBuildNumber: integer;     FMajorVersion: integer;     FMinorVersion: integer;     FPlatform: string;     FCSD: string;     FVersion: string;     FRegUser: string;     FSerialNumber: string;     FRegOrg: string;     FTimeZone: string;     FEnv: TStrings;     FTempDir: string;     FWinDir: string;     FSysDir: string;        function GetSystemRes: Byte;     function GetGDIRes: Byte;     function GetUSERRes: Byte;        procedure GetEnvironment;   protected     procedure SetNone(Value: Byte);   public     constructor Create;     destructor Destroy; override;     procedure GetInfo;     procedure Report(var sl :TStringList);   published     property MajorVersion :integer read FMajorVersion write FMajorVersion stored false;     property MinorVersion :integer read FMinorVersion write FMinorVersion stored false;     property BuildNumber :integer read FBuildNumber write FBuildNumber stored false;     property Platform :string read FPlatform write FPlatform stored false;     property Version :string read FVersion write FVersion stored false;     property CSD :string read FCSD write FCSD stored false;     property SerialNumber :string read FSerialNumber write FSerialNumber stored false;     property RegisteredUser :string read FRegUser write FRegUser stored false;     property RegisteredOrg :string read FRegOrg write FRegOrg stored false;     property TimeZone :string read FTimeZone write FTimeZone stored false;     property Environment :TStrings read FEnv write FEnv stored false;     property WinDir :string read FWinDir write FWinDir stored false;     property SysDir :string read FSysDir write FSysDir stored false;     property TempDir :string read FTempDir write FTempDir stored false; //    property SystemRes: Byte read GetSystemRes write SetNone; //    property GDIRes: Byte read GetGDIRes write SetNone; //    property UserRes: Byte read GetUserRes write SetNone;   end;      TFileFlag = (fsCaseIsPreserved, fsCaseSensitive, fsUnicodeStoredOnDisk,                fsPersistentAcls, fsFileCompression, fsVolumeIsCompressed,                fsLongFileNames,                // following flags are valid only for Windows2000                fsEncryptedFileSystemSupport, fsObjectIDsSupport, fsReparsePointsSupport,                fsSparseFilesSupport, fsDiskQuotasSupport);   TFileFlags = set of TFileFlag;      TDriveType = (dtUnknown, dtNotExists, dtRemovable, dtFixed, dtRemote, dtCDROM, dtRAMDisk);      TDiskSign = string[2];      TDisk = class(TPersistent)   private     FDisk: TDiskSign;     FMediaPresent: Boolean;     FDriveType: TDriveType;     FSectorsPerCluster: DWORD;     FBytesPerSector: DWORD;     FFreeClusters: DWORD;     FTotalClusters: DWORD;     FFileFlags: TFileFlags;     FVolumeLabel: string;     FSerialNumber: string;     FFileSystem: string;     FFreeSpace: int64;     FCapacity: int64;     FAvailDisks: string;     FSerial: dword;     FModel: string;     function GetMediaPresent: Boolean;   protected     procedure SetDisk(const Value: TDiskSign);   public     procedure GetInfo;     function GetDriveTypeStr(dt :TDriveType) :string;     procedure GetFileFlagsStr(AClear :boolean; var AFileFlags :TStringList);     procedure Report(var sl :TStringList);     function GetCD :byte;     property Serial :dword read FSerial write FSerial stored false;   published     property Drive :TDiskSign read FDisk write SetDisk stored false;     property AvailableDisks :string read FAvailDisks write FAvailDisks stored false;     property MediaPresent :Boolean read GetMediaPresent write FMediaPresent stored false;     property DriveType :TDriveType read FDriveType write FDriveType stored false;     property FileFlags :TFileFlags read FFileFlags write FFileFlags stored false;     property FileSystem :string read FFileSystem write FFileSystem stored false;     property FreeClusters :DWORD read FFreeClusters write FFreeClusters stored false;     property TotalClusters :DWORD read FTotalClusters write FTotalClusters stored false;     // FreeSpace and Capacity returns good results for Win95 OSR2, Win98, NT and 2000     // for Win95 there can be bad sizes for drives over 2GB     property FreeSpace :int64 read FFreeSpace write FFreeSpace stored false;     property Capacity :int64 read FCapacity write FCapacity stored false;     property SerialNumber :string read FSerialNumber write FSerialNumber stored false;     property VolumeLabel :string read FVolumeLabel write FVolumeLabel stored false;     property SectorsPerCluster :DWORD read FSectorsPerCluster write FSectorsPerCluster stored false;     property BytesPerSector :DWORD read FBytesPerSector write FBytesPerSector stored false;     property Model: string read FModel write FModel stored False;   end;      TWorkstation = class(TPersistent)   private     FName: string;     FLastBoot: TDatetime;     FUser: string;     FSystemUpTime: Extended;     FBIOSExtendedInfo: string;     FBIOSCopyright: string;     FBIOSName: string;     FBIOSDate: string;     FScrollLock: Boolean;     FNumLock: Boolean;     FCapsLock: Boolean;     function GetSystemUpTime: Extended;   public     procedure GetInfo;     procedure Report(var sl :TStringList);   published     property Name :string read FName write FName stored false;     property User :string read FUser write FUser stored false;     property SystemUpTime :Extended read FSystemUpTime write FSystemUpTime stored false;     property LastBoot :TDatetime read FLastBoot write FLastBoot stored false;     property BIOSCopyright :string read FBIOSCopyright write FBIOSCopyright stored false;     property BIOSDate :string read FBIOSDate write FBIOSDate stored false;     property BIOSExtendedInfo :string read FBIOSExtendedInfo write FBIOSExtendedInfo stored false;     property BIOSName :string read FBIOSName write FBIOSName stored false;     property CapsLock: Boolean read FCapsLock write FCapsLock stored false;     property NumLock: Boolean read FNumLock write FNumLock stored false;     property ScrollLock: Boolean read FScrollLock write FScrollLock stored false;   end;      TWinsock = class(TPersistent)   private     FDesc: string;     FStat: string;     FMajVer: word;     FMinVer: word;   public     procedure GetInfo;   published     property Description: string read FDesc write FDesc stored False;     property MajorVersion: word read FMajVer write FMajVer stored False;     property MinorVersion: word read FMinVer write FMinVer stored False;     property Status: string read FStat write FStat stored False;   end;      TNetwork = class(TPersistent)   private     FIPAddress: string;     FAdapter: TStrings;     FWinsock: TWinsock;     function GetLocalIP :string;   public     constructor Create;     destructor Destroy; override;     procedure GetInfo;     procedure Report(var sl :TStringList);   published     property IPAddress :string read FIPAddress write FIPAddress stored false;     property Adapter :TStrings read FAdapter write FAdapter stored false;     property WinSock: TWinsock read FWinsock write FWinsock;   end;      TCurveCap = (ccCircles,ccPieWedges,ccChords,ccEllipses,ccWideBorders,ccStyledBorders,                ccWideStyledBorders,ccInteriors,ccRoundedRects);   TLineCap = (lcPolylines,lcMarkers,lcMultipleMarkers,lcWideLines,lcStyledLines,                lcWideStyledLines,lcInteriors);   TPolygonCap = (pcAltFillPolygons,pcRectangles,pcWindingFillPolygons,pcSingleScanlines,                  pcWideBorders,pcStyledBorders,pcWideStyledBorders,pcInteriors);   TRasterCap = (rcRequiresBanding,rcTranserBitmaps,rcBitmaps64K,rcSetGetDIBits,                 rcSetDIBitsToDevice,rcFloodfills,rcWindows2xFeatures,rcPaletteBased,                 rcScaling,rcStretchBlt,rcStretchDIBits);   TTextCap = (tcCharOutPrec,tcStrokeOutPrec,tcStrokeClipPrec,tcCharRotation90,               tcCharRotationAny,tcScaleIndependent,tcDoubledCharScaling,tcIntMultiScaling,               tcAnyMultiExactScaling,tcDoubleWeightChars,tcItalics,tcUnderlines,               tcStrikeouts,tcRasterFonts,tcVectorFonts,tcNoScrollUsingBlts);      TCurveCaps = set of TCurveCap;   TLineCaps = set of TLineCap;   TPolygonCaps = set of TPolygonCap;   TRasterCaps = set of TRasterCap;   TTextCaps = set of TTextCap;      TVideo = class(TPersistent)   private     FVertRes: integer;     FColorDepth: integer;     FHorzRes: integer;     FBIOSDate: string;     FBIOSVersion: string;     FPixelDiagonal: integer;     FPixelHeight: integer;     FVertSize: integer;     FPixelWidth: integer;     FHorzSize: integer;     FTechnology: string;     FCurveCaps: TCurveCaps;     FLineCaps: TLineCaps;     FPolygonCaps: TPolygonCaps;     FRasterCaps: TRasterCaps;     FTextCaps: TTextCaps;     FMemory: TStrings;     FChipset: TStrings;     FAdapter: TStrings;     FDAC: TStrings;     FAcc: TStrings;   public     constructor Create;     destructor Destroy; override;     procedure GetInfo;     procedure GetCurveCapsStr(AClear :boolean; ACaps :TStringList);     procedure GetLineCapsStr(AClear :boolean; ACaps :TStringList);     procedure GetPolygonCapsStr(AClear :boolean; ACaps :TStringList);     procedure GetRasterCapsStr(AClear :boolean; ACaps :TStringList);     procedure GetTextCapsStr(AClear :boolean; ACaps :TStringList);     procedure Report(var sl :TStringList);   published     property Adapter :TStrings read FAdapter write FAdapter stored false;     property Accelerator :TStrings read FAcc write FAcc stored false;     property DAC :TStrings read FDAC write FDAC stored false;     property Chipset :TStrings read FChipset write FChipset stored false;     property Memory :TStrings read FMemory write FMemory stored false;     property HorzRes :integer read FHorzRes write FHorzRes stored false;     property VertRes :integer read FVertRes write FVertRes stored false;     property ColorDepth :integer read FColorDepth write FColorDepth stored false;     // BIOS info is available only under NT     property BIOSVersion :string read FBIOSVersion write FBIOSVersion stored false;     property BIOSDate :string read FBIOSDate write FBIOSDate stored false;     property Technology :string read FTechnology write FTechnology stored false; //    property HorzSize :integer read FHorzSize write FHorzSize stored false; //    property VertSize :integer read FVertSize write FVertSize stored false;     property PixelWidth :integer read FPixelWidth write FPixelWidth stored false;     property PixelHeight :integer read FPixelHeight write FPixelHeight stored false;     property PixelDiagonal :integer read FPixelDiagonal write FPixelDiagonal stored false;     property RasterCaps :TRasterCaps read FRasterCaps write FRasterCaps stored false;     property CurveCaps :TCurveCaps read FCurveCaps write FCurveCaps stored false;     property LineCaps :TLineCaps read FLineCaps write FLineCaps stored false;     property PolygonCaps :TPolygonCaps read FPolygonCaps write FPolygonCaps stored false;     property TextCaps :TTextCaps read FTextCaps write FTextCaps stored false;   end;      TMedia = class(TPersistent)   private     FDevice: TStrings;     FAUX: string;     FMIDIIn: string;     FMixer: string;     FWAVEOut: string;     FWAVEIn: string;     FMIDIOut: string;   public     constructor Create;     destructor Destroy; override;     procedure GetInfo;     procedure Report(var sl :TStringList);   published     property Device :TStrings read FDevice write FDevice stored false;     property WAVEIn :string read FWAVEIn write FWAVEIn stored false;     property WAVEOut :string read FWAVEOut write FWAVEOut stored false;     property MIDIIn :string read FMIDIIn write FMIDIIn stored false;     property MIDIOut :string read FMIDIOut write FMIDIOut stored false;     property AUX :string read FAUX write FAUX stored false;     property Mixer :string read FMixer write FMixer stored false;   end;      TDevices = class(TPersistent)   private     FKeyboard: string;     FMouse: string;     FSD: TStrings;     FSCSI: TStrings;     FUSB: TStrings;     FModem: TStrings;     FMonitor: TStrings;     FPrinter: TStrings;     FPort: TStrings;   public     constructor Create;     destructor Destroy; override;     procedure GetInfo;     procedure Report(var sl :TStringList);   published     property Monitor :TStrings read FMonitor write FMonitor stored false;     property Printer :TStrings read FPrinter write FPrinter stored false;     property Keyboard :string read FKeyboard write FKeyboard stored false;     property Mouse :string read FMouse write FMouse stored false;     property SystemDevice :TStrings read FSD write FSD stored false;     property USB :TStrings read FUSB write FUSB stored false;     property SCSI :TStrings read FSCSI write FSCSI stored false;     property Modem :TStrings read FModem write FModem stored false;     property Port :TStrings read FPort write FPort stored false;   end;      TEngines = class(TPersistent)   private     FBDE: string;     FODBC: string;   public     procedure GetInfo;     procedure Report(var sl :TStringList);   published     property ODBC :string read FODBC write FODBC stored false;     property BDE :string read FBDE write FBDE stored false;   end;      TAPM = class(TPersistent)   private     FBatteryLifePercent: Byte;     FBatteryLifeFullTime: DWORD;     FBatteryLifeTime: DWORD;     FACPowerStatus: string;     FBatteryChargeStatus: string;   public     procedure GetInfo;     procedure Report(var sl :TStringList);   published     property ACPowerStatus :string read FACPowerStatus write FACPowerStatus stored false;     property BatteryChargeStatus :string read FBatteryChargeStatus write FBatteryChargeStatus stored false;     property BatteryLifePercent :Byte read FBatteryLifePercent write FBatteryLifePercent stored false;     property BatteryLifeTime :DWORD read FBatteryLifeTime write FBatteryLifeTime stored false;     property BatteryLifeFullTime :DWORD read FBatteryLifeFullTime write FBatteryLifeFullTime stored false;   end;      TDirectX = class(TPersistent)   private     FVersion: string;     FDirect3D: TStrings;     FDirectPlay: TStrings;     FDirectMusic: TStrings;   public     constructor Create;     destructor Destroy; override;     procedure GetInfo;     procedure Report(var sl :TStringList);   published     property Version :string read FVersion write FVersion stored false;     property Direct3D :TStrings read FDirect3D write FDirect3D stored false;     property DirectPlay :TStrings read FDirectPlay write FDirectPlay stored false;     property DirectMusic :TStrings read FDirectMusic write FDirectMusic stored false;   end;      DSSystemInfo = class(TComponent)   private     FCPU: TCPU;     FMemory: TMemory;     FOS :TOperatingSystem;     FDisk :TDisk;     FWorkstation: TWorkstation;     FNetwork: TNetwork;     FVideo: TVideo;     FEngines: TEngines;     FDevices: TDevices;     FAPM :TAPM;     FAbout: string;     FDirectX: TDirectX;     FMedia: TMedia;     procedure SetAbout(const Value: string);   public     constructor Create(AOwner :TComponent); override;     destructor Destroy; override;     procedure Refresh;        procedure WkstaInfoRefresh;     procedure OSInfoRefresh;     procedure CPUInfoRefresh;     procedure MemoryInfoRefresh;     procedure DisplayInfoRefresh;     procedure APMInfoRefresh;     procedure MediaInfoRefresh;     procedure NetInfoRefresh;     procedure DeviceInfoRefresh;     procedure EngInfoRefresh;     procedure DriveInfoRefresh;     procedure DiskInfoRefresh;        procedure Report(var sl :TStringList);   published     property About :string read FAbout write SetAbout;     property CPU :TCPU read FCPU write FCPU;     property Memory :TMemory read FMemory write FMemory;     property OS :TOperatingSystem read FOS write FOS;     property Disk :TDisk read FDisk write FDisk;     property Workstation :TWorkstation read FWorkstation write FWorkstation;     property Network :TNetwork read FNetwork write FNetwork;     property Video :TVideo read FVideo write FVideo;     property Media :TMedia read FMedia write FMedia;     property Devices :TDevices read FDevices write FDevices;     property Engines :TEngines read FEngines write FEngines;     property APM :TAPM read FAPM write FAPM;     property DirectX :TDirectX read FDirectX write FDirectX;   end;      function FormatSeconds(TotalSeconds :comp; WholeSecondsOnly,                          DisplayAll, DTFormat :Boolean) :String;   function ReadVerInfo(const fn :string; var Desc :string) :string;   function ReadRegInfo(ARoot :hkey; AKey, AValue :string) :string;   function GetTimeStamp :TLargInt;   function GetTicksPerSecond(Iterations :Word) :Comp;   function GetWindowInfo(wh: hwnd): PWindow;   function GetFreeSysRes(SysRes: Word): Word;   procedure GetEnvironment(EnvList :tstringlist);   function GetWinSysDir: string;      procedure Register;    const   ID_Bit = $200000;    // EFLAGS ID bit      CPUVendorIDs :array[0..5] of string = ('GenuineIntel',                                          'UMC UMC UMC',                                          'AuthenticAMD',                                          'CyrixInstead',                                          'NexGenDriven',                                          'CentaurHauls');      CPUVendors :array[0..5] of string = ('Intel',                                        'UMC',                                        'AMD',                                        'Cyrix',                                        'NexGen',                                        'CentaurHauls');      {   FILE_SUPPORTS_ENCRYPTION =   FILE_SUPPORTS_OBJECT_IDS =   FILE_SUPPORTS_REPARSE_POINTS =   FILE_SUPPORTS_SPARSE_FILES =   FILE_VOLUME_QUOTAS =   }    var   IsNT,IS95,Is98,Is2000,IsOSR2: Boolean;   WindowsUser, MachineName: string;   Platform: TPlatformType;    implementation    type   TLoadLibrary16 = function (LibraryName: PChar): THandle; stdcall;   TFreeLibrary16 = procedure (HInstance: THandle); stdcall;   TGetProcAddress16 = function (Hinstance: THandle; ProcName: PChar): Pointer; stdcall;   TQT_Thunk = procedure; cdecl;    var   VLevel, VFamily, VModel, VStepping, VTyp :Byte;   VFeatures :LongInt;      _LoadLibrary16 :TLoadLibrary16;   _FreeLibrary16 :TFreeLibrary16;   _GetProcAddress16 :TGetProcAddress16;   _QT_Thunk :TQT_Thunk;   hInst16: THandle;   SR: Pointer;   HKernel :Thandle;   idxLoadLibrary16,   idxFreeLibrary16,   idxGetProcAddress16 :dword;    procedure LoadKernel16; begin   HKernel:=GetModuleHandle('kernel32.dll');   idxLoadLibrary16:=35;   idxFreeLibrary16:=36;   idxGetProcAddress16:=37;   if HKernel<>0 then begin     @_LoadLibrary16:=getprocaddress(HKernel,@idxLoadLibrary16);     @_FreeLibrary16:=getprocaddress(HKernel,@idxFreeLibrary16);     @_GetProcAddress16:=getprocaddress(HKernel,@idxGetProcAddress16);     @_QT_Thunk:=getprocaddress(HKernel,pchar('QT_Thunk'));   end; end;    procedure FreeLibrary16(HInstance: THandle); begin   if assigned(_FreeLibrary16) then     _FreeLibrary16(HInstance); end;    function GetProcAddress16(HInstance: THandle;   ProcName: PChar): Pointer; begin   if assigned(_GetProcAddress16) then     result:=_GetProcAddress16(HInstance,ProcName)   else     result:=nil; end;    function LoadLibrary16(LibraryName: PChar): THandle; begin   if assigned(_LoadLibrary16) then     result:=_LoadLibrary16(LibraryName)   else     result:=0; end;    procedure QT_Thunk; begin   if assigned(_QT_Thunk) then     _QT_Thunk; end;    function GetFreeSysRes(SysRes: Word): Word; var   Thunks: Array[0..$20] of Word; begin   result:=0;   if HKernel=0 then     LoadKernel16;   Thunks[0]:=hInst16;   hInst16:=LoadLibrary16('user.exe');   if hInst16>32 then begin     FreeLibrary16(hInst16);     SR:=GetProcAddress16(hInst16,'GetFreeSystemResources');     if assigned(SR) then       asm         push SysRes       // push arguments         mov edx, SR       // load 16-bit procedure pointer         call QT_Thunk     // call thunk         mov Result, ax    // save the result       end     else       //raise Exception.Create('Can''t get address of GetFreeSystemResources!');   end else     //raise Exception.Create('Can''t load USER.EXE!'); end;    procedure GetEnvironment(EnvList :tstringlist); var   c,i :dword;   b :pchar;   s :string; begin   EnvList.Clear;   c:=1024;   b:=GetEnvironmentStrings;   i:=0;   s:='';   while i#0 then s:=s b[i] else begin if s='' then break; EnvList.Add(s); s:=''; end; inc(i); end; FreeEnvironmentStrings(b); end; function GetWinSysDir: string; var n: integer; p: PChar; begin n:=MAX_PATH; p:=stralloc(n); getwindowsdirectory(p,n); result:=strpas(p) ';'; getsystemdirectory(p,n); Result:=Result strpas(p) ';'; end; procedure Register; begin RegisterComponents('DHJSW',[DSSystemInfo]); end; function GetCPUIDFlags: DWORD; assembler; register; asm PUSH EBX //Save registers PUSH EDI MOV EAX,1 //Set up for CPUID DW $A20F //CPUID OpCode MOV @Result,EDX //Put the flag array into a DWord POP EDI //Restore registers POP EBX end; function GetTimeStampHi: DWORD; assembler; register; asm DW $310F //RDTSC Command MOV @Result, EDX; end; function GetTimeStampLo: DWORD; assembler; register; asm DW $310F //RDTSC Command MOV @Result, EAX; end; function GetTimeStamp :TLargInt; begin //*Result.QuadPart:=0; Result:=0; if (GetCPUIDFlags and 16) <> 16 then exit; //*Result.HighPart:=DWORD(GetTimeStampHi); Result:=DWORD(GetTimeStampHi); //*Result.LowPart:=GetTimeStampLo; Result:=GetTimeStampLo; end; function GetTicksPerSecond(Iterations :Word) :Comp; var Freq ,PerfCount,Target :int64; StartTime, EndTime, Elapsed :TLargInt; procedure StartTimer; begin StartTime:=GetTimeStamp; //*EndTime.QuadPart:=0; EndTime:=0; //*Elapsed.QuadPart:=0; Elapsed:=0; end; procedure StopTimer; begin EndTime:=GetTimeStamp; //*Elapsed.QuadPart:=(EndTime.QuadPart-StartTime.QuadPart); Elapsed:=(EndTime-StartTime); end; begin Result:=0; if not QueryPerformanceFrequency(Freq) then exit; QueryPerformanceCounter(PerfCount); {$IFDEF D4PLUS} Target:=PerfCount (Freq*Iterations); {$ELSE} //*Target.QuadPart:=PerfCount.QuadPart (Freq.QuadPart*Iterations); Target:=PerfCount (Freq*Iterations); {$ENDIF} StartTimer; repeat QueryPerformanceCounter(PerfCount); {$IFDEF D4PLUS} until (PerfCount>=Target); {$ELSE} //*until (PerfCount.QuadPart>=Target.QuadPart); until (PerfCount>=Target); {$ENDIF} StopTimer; //*Result:=(Elapsed.QuadPart/Iterations); Result:=(Elapsed/Iterations); end; function GetStrFromBuf(Buffer :pchar) :string; var i,j :integer; begin result:=''; j:=0; i:=0; repeat if buffer[i]<>#0 then begin result:=result buffer[i]; j:=0; end else inc(j); inc(i); until j>1; end; function GetKey(StartKey, Value, Data :string) :string; var vn,kn :tstringlist; regbase :tregistry; procedure EnumKeys(aregbase :tregistry; aroot: string; akn :tstringlist); var kn :tstringlist; i :integer; begin for i:=0 to akn.count-1 do with aregbase do begin closekey; if openkey(aroot '\' akn[i],false) then begin getvaluenames(vn); if vn.indexof(value)>-1 then begin if readstring(value)=data then begin result:=aroot '\' akn[i]; break; end; end else if hassubkeys then begin kn:=tstringlist.create; getkeynames(kn); enumkeys(aregbase,aroot '\' akn[i],kn); if result<>'' then break; kn.free; end; end; end; end; begin result:=''; regbase:=tregistry.create; with regbase do begin rootkey:=HKEY_LOCAL_MACHINE; vn:=tstringlist.create; kn:=tstringlist.create; if openkey(startkey,false) then begin getkeynames(kn); enumkeys(regbase,startkey,kn); closekey; end; vn.free; kn.free; free; end; end; function GetWindowInfo(wh: hwnd): PWindow; var cn,wn :pchar; n, wpid,tid :longword; begin n:=255; wn:=stralloc(n); cn:=stralloc(n); tid:=GetWindowThreadProcessId(wh,@wpid); getclassname(wh,cn,n); getwindowtext(wh,wn,n); new(result); result^.ClassName:=strpas(cn); result^.Text:=strpas(wn); result^.Handle:=wh; result^.Process:=wpid; result^.Thread:=tid; result^.ParentWin:=getwindowlong(wh,GWL_HWNDPARENT); result^.WndProc:=getwindowlong(wh,GWL_WNDPROC); result^.Instance:=getwindowlong(wh,GWL_HINSTANCE); result^.ID:=getwindowlong(wh,GWL_ID); result^.UserData:=getwindowlong(wh,GWL_USERDATA); result^.Style:=getwindowlong(wh,GWL_STYLE); result^.ExStyle:=getwindowlong(wh,GWL_EXSTYLE); getwindowrect(wh,result^.Rect); getclientrect(wh,result^.ClientRect); result^.Atom:=getclasslong(wh,GCW_ATOM); result^.ClassBytes:=getclasslong(wh,GCL_CBCLSEXTRA); result^.WinBytes:=getclasslong(wh,GCL_CBWNDEXTRA); result^.ClassWndProc:=getclasslong(wh,GCL_WNDPROC); result^.ClassInstance:=getclasslong(wh,GCL_HMODULE); result^.Background:=getclasslong(wh,GCL_HBRBACKGROUND); result^.Cursor:=getclasslong(wh,GCL_HCURSOR); result^.Icon:=getclasslong(wh,GCL_HICON); result^.ClassStyle:=getclasslong(wh,GCL_STYLE); result^.Styles:=tstringlist.create; result^.visible:=iswindowvisible(wh); if not(result^.ExStyle and WS_BORDER=0) then result^.Sty

{ TMemory }    procedure TMemory.GetInfo; var   //*SI :TSysteminfo   SI :_SYSTEM_INFO;   MS :TMemoryStatus; begin   ZeroMemory(@MS,SizeOf(MS));   MS.dwLength:=SizeOf(MS);   GlobalMemoryStatus(MS);   MemoryLoad:=MS.dwMemoryLoad;   PhysicalTotal:=MS.dwTotalPhys;   PhysicalFree:=MS.dwAvailPhys;   VirtualTotal:=MS.dwTotalVirtual;   VirtualFree:=MS.dwAvailVirtual;   PageFileTotal:=MS.dwTotalPageFile;   PageFileFree:=MS.dwAvailPageFile;   ZeroMemory(@SI,SizeOf(SI));   GetSystemInfo(SI);   AllocGranularity:=SI.dwAllocationGranularity;   MaxAppAddress:=DWORD(SI.lpMaximumApplicationAddress);   MinAppAddress:=DWORD(SI.lpMinimumApplicationAddress);   PageSize:=DWORD(SI.dwPageSize); end;    procedure TMemory.Report(var sl: TStringList); begin   with sl do begin     add(formatfloat('Physical Memory Total: #,## B',PhysicalTotal));     add(formatfloat('Physical Memory Free: #,## B',PhysicalFree));     add(formatfloat('Page File Total: #,## B',PageFileTotal));     add(formatfloat('Page File Free: #,## B',PageFileFree));     add(formatfloat('Virtual Memory Total: #,## B',VirtualTotal));     add(formatfloat('Virtual Memory Free: #,## B',VirtualFree));     add('');     add(formatfloat('Allocation Granularity: #,## B',AllocGranularity));     add(format('Application Addres Range: %s - %s',[inttohex(MinAppAddress,8),inttohex(MaxAppAddress,8)]));     add(formatfloat('Page Size: #,## B',PageSize));   end; end;    { TOperatingSystem }    constructor TOperatingSystem.Create; begin   inherited;   FEnv:=TStringList.Create; end;    destructor TOperatingSystem.Destroy; begin   FEnv.Free;   inherited; end;    procedure TOperatingSystem.GetEnvironment; var   c,i :dword;   b :pchar;   s :string; begin   FEnv.Clear;   c:=1024;   b:=GetEnvironmentStrings;   i:=0;   s:='';   while i#0 then s:=s b[i] else begin if s='' then break; FEnv.Add(s); s:=''; end; inc(i); end; FreeEnvironmentStrings(b); end; procedure TOperatingSystem.GetInfo; var OS :TOSVersionInfo; p :pchar; n :DWORD; const rkTimeZone = {HKEY_LOCAL_MACHINE\}'SYSTEM\CurrentControlSet\Control\TimeZoneInformation'; rvTimeZone = 'StandardName'; rkOSInfo95 = {HKEY_LOCAL_MACHINE\}'SOFTWARE\Microsoft\Windows\CurrentVersion'; rkOSInfoNT = {HKEY_LOCAL_MACHINE\}'SOFTWARE\Microsoft\Windows NT\CurrentVersion'; rvVersionName95 = 'Version'; rvVersionNameNT = 'CurrentType'; rvRegOrg = 'RegisteredOrganization'; rvRegOwn = 'RegisteredOwner'; rvProductID = 'ProductID'; begin ZeroMemory(@OS,SizeOf(OS)); OS.dwOSVersionInfoSize:=SizeOf(OS); GetVersionEx(OS); MajorVersion:=OS.dwMajorVersion; MinorVersion:=OS.dwMinorVersion; BuildNumber:=word(OS.dwBuildNumber); case OS.dwPlatformId of VER_PLATFORM_WIN32s :Platform:='Windows 3.1x'; VER_PLATFORM_WIN32_WINDOWS :Platform:='Windows 95'; VER_PLATFORM_WIN32_NT :Platform:='Windows NT'; end; if MajorVersion>4 then Platform:='Windows 2000'; CSD:=strpas(OS.szCSDVersion); TimeZone:=''; Version:=''; RegisteredUser:=''; RegisteredOrg:=''; SerialNumber:=''; with tregistry.create do begin rootkey:=HKEY_LOCAL_MACHINE; if openkey(rkTimeZone,false) then begin if valueexists(rvTimeZone) then TimeZone:=readstring(rvTimeZone); closekey; end; if isnt then begin if openkey(rkOSInfoNT,false) then begin if valueexists(rvVersionNameNT) then Version:=readstring(rvVersionNameNT); if valueexists(rvRegOrg) then RegisteredOrg:=readstring(rvRegOrg); if valueexists(rvRegOwn) then RegisteredUser:=readstring(rvRegOwn); if valueexists(rvProductID) then SerialNumber:=readstring(rvProductID); closekey; end; end else begin if openkey(rkOSInfo95,false) then begin if valueexists(rvVersionName95) then Version:=readstring(rvVersionName95); if valueexists(rvRegOrg) then RegisteredOrg:=readstring(rvRegOrg); if valueexists(rvRegOwn) then RegisteredUser:=readstring(rvRegOwn); if valueexists(rvProductID) then SerialNumber:=readstring(rvProductID); closekey; end; end; end; GetEnvironment; n:=MAX_PATH; p:=stralloc(n); getwindowsdirectory(p,n); windir:=strpas(p); getsystemdirectory(p,n); sysdir:=strpas(p); gettemppath(n,p); tempdir:=strpas(p); strdispose(p); end; function TOperatingSystem.GetGDIRes: Byte; begin if not isNT then result:=GetFreeSysRes(cGDI) else result:=0; end; function TOperatingSystem.GetSystemRes: Byte; begin if not isNT then result:=GetFreeSysRes(cSystem) else result:=0; end; function TOperatingSystem.GetUSERRes: Byte; begin if not isNT then result:=GetFreeSysRes(cUser) else result:=0; end; procedure TOperatingSystem.Report(var sl: TStringList); begin with sl do begin add('Platform: ' Platform); add(format('Version: %s %d.%d.%d',[Version,MajorVersion,MinorVersion,BuildNumber])); add('CSD: ' CSD); add('Serial Number: ' SerialNumber); add('Registered User: ' RegisteredUser); add('Registered Organization: ' RegisteredOrg); add('Time Zone: ' TimeZone); add(''); add('Windows Folder: ' WinDir); add('System Folder: ' SysDir); add('Temp Folder: ' TempDir); add(''); add('Environment:'); addstrings(Environment); end; end; procedure TOperatingSystem.SetNone(Value: Byte); begin end; { TDisk } function TDisk.GetCD: byte; var i :integer; root :pchar; begin result:=0; root:=stralloc(255); for i:=1 to length(FAvailDisks) do begin strpcopy(root,copy(FAvailDisks,i,1) ':\'); if getdrivetype(root)=drive_cdrom then begin result:=i; break; end; end; strdispose(root); end; function TDisk.GetDriveTypeStr(dt: TDriveType) :string; begin case dt of dtUnknown :result:='Unknown'; dtNotExists :result:='Not Exists'; dtRemovable :result:='Removable'; dtFixed :result:='Fixed'; dtRemote :result:='Remote'; dtCDROM :result:='CDROM'; dtRAMDisk :result:='RAMDisk'; end; end; procedure TDisk.GetFileFlagsStr(AClear :boolean; var AFileFlags: TStringList); begin if AClear then AFileFlags.Clear; AFileFlags.Add('Case Is Preserved: ' bool2yn(fsCaseIsPreserved in FileFlags)); AFileFlags.Add('Case Sensitive: ' bool2yn(fsCaseSensitive in FileFlags)); AFileFlags.Add('Unicode Stored On Disk: ' bool2yn(fsUnicodeStoredOnDisk in FileFlags)); AFileFlags.Add('Persistent Acls: ' bool2yn(fsPersistentAcls in FileFlags)); AFileFlags.Add('File Compression: ' bool2yn(fsFileCompression in FileFlags)); AFileFlags.Add('Volume Is Compressed: ' bool2yn(fsVolumeIsCompressed in FileFlags)); AFileFlags.Add('Long Filenames: ' bool2yn(fsLongFileNames in FileFlags)); AFileFlags.Add('Encrypted File System Support: ' bool2yn(fsEncryptedFileSystemSupport in FileFlags)); AFileFlags.Add('Object IDs Support: ' bool2yn(fsObjectIDsSupport in FileFlags)); AFileFlags.Add('Reparse Points Support: ' bool2yn(fsReparsePointsSupport in FileFlags)); AFileFlags.Add('Sparse Files Support: ' bool2yn(fsSparseFilesSupport in FileFlags)); AFileFlags.Add('Disk Quotas Support: ' bool2yn(fsDiskQuotasSupport in FileFlags)); end; procedure TDisk.GetInfo; var i,n :integer; buf :pchar; begin buf:=stralloc(255); n:=GetLogicalDriveStrings(255,buf); FAvailDisks:=''; for i:=0 to n do if buf[i]<>#0 then begin if (ord(buf[i]) in [$41..$5a]) or (ord(buf[i]) in [$61..$7a]) then FAvailDisks:=FAvailDisks upcase(buf[i]) end else if buf[i 1]=#0 then break; strdispose(buf); end; function TDisk.GetMediaPresent :Boolean; var ErrorMode: Word; bufRoot :pchar; a,b,c,d :dword; begin bufRoot:=stralloc(255); strpcopy(bufRoot,FDisk '\'); ErrorMode:=SetErrorMode(SEM_FailCriticalErrors); try try result:=GetDiskFreeSpace(bufRoot,a,b,c,d); except result:=False; end; finally strdispose(bufroot); SetErrorMode(ErrorMode); end; end; procedure TDisk.Report(var sl: TStringList); var i :integer; begin for i:=1 to length(AvailableDisks) do begin sl.add(''); Drive:=copy(AvailableDisks,i,1) ':'; sl.add(format('%s [%s] - %s',[Drive,VolumeLabel,GetDriveTypeStr(DriveType)])); sl.add('UNC: ' expanduncfilename(Drive)); sl.add('Serial Number: ' SerialNumber); {$IFDEF D4PLUS} sl.add(formatfloat('Capacity: 0,## bytes',Capacity)); sl.add(formatfloat('Free space: 0,## bytes',FreeSpace)); {$ELSE} //*sl.add(formatfloat('Capacity: 0,## bytes',Capacity.QuadPart)); sl.add(formatfloat('Capacity: 0,## bytes',Capacity)); //*sl.add(formatfloat('Free space: 0,## bytes',FreeSpace.QuadPart)); sl.add(formatfloat('Free space: 0,## bytes',FreeSpace)); {$ENDIF} sl.add(formatfloat('Bytes/sector: 0',BytesPerSector)); sl.add(formatfloat('Sector/cluster: 0',SectorsPerCluster)); sl.add(formatfloat('Free clusters: 0,##',FreeClusters)); sl.add(formatfloat('Total clusters: 0,##',TotalClusters)); sl.add(' File Flags:'); GetFileFlagsStr(false,sl); end; end; procedure TDisk.SetDisk(const Value: TDiskSign); var BPS,TC,FC,SPC :integer; T,F :TLargeInteger; TF :PLargeInteger; bufRoot, bufVolumeLabel, bufFileSystem :pchar; MCL,Size,Flags :DWORD; s :string; {$IFNDEF D4PLUS} h :THandle; GetDiskFreeSpaceEx :function (lpDirectoryName: PChar; var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes; lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall; {$ENDIF} const rk2KModel = ''; begin FDisk:=Value; Size:=255; bufRoot:=stralloc(Size); strpcopy(bufRoot,FDisk '\'); case GetDriveType(bufRoot) of DRIVE_UNKNOWN :FDriveType:=dtUnknown; DRIVE_NO_ROOT_DIR :FDriveType:=dtNotExists; DRIVE_REMOVABLE :FDriveType:=dtRemovable; DRIVE_FIXED :FDriveType:=dtFixed; DRIVE_REMOTE :FDriveType:=dtRemote; DRIVE_CDROM :FDriveType:=dtCDROM; DRIVE_RAMDISK :FDriveType:=dtRAMDisk; end; FFileFlags:=[]; if MediaPresent then begin GetDiskFreeSpace(bufRoot,FSectorsPerCluster,FBytesPerSector,FFreeClusters,FTotalClusters); try new(TF); {$IFDEF D4PLUS} SysUtils.GetDiskFreeSpaceEx(bufRoot,F,T,TF); FCapacity:=T; FFreeSpace:=F; {$ELSE} GetDiskFreeSpaceEx:=nil; h:=LoadLibrary('KERNEL32.DLL'); if h>0 then GetDiskFreeSpaceEx:=GetProcAddress(h,'GetDiskFreeSpaceExA'); if assigned(GetDiskFreeSpaceEx) then GetDiskFreeSpaceEx(bufRoot,F,T,TF); FCapacity:=T; FFreeSpace:=F; FreeLibrary(h); {$ENDIF} dispose(TF); except BPS:=FBytesPerSector; TC:=FTotalClusters; FC:=FFreeClusters; SPC:=FSectorsPerCluster; {$IFDEF D4PLUS} FCapacity:=TC*SPC*BPS; FFreeSpace:=FC*SPC*BPS; {$ELSE} //*FCapacity.QuadPart:=TC*SPC*BPS; FCapacity:=TC*SPC*BPS; //*FFreeSpace.QuadPart:=FC*SPC*BPS; FFreeSpace:=FC*SPC*BPS; {$ENDIF} end; bufVolumeLabel:=stralloc(Size); bufFileSystem:=stralloc(Size); if GetVolumeInformation(bufRoot,bufVolumeLabel,Size,@FSerial,MCL,Flags,bufFileSystem,Size) then begin; FVolumeLabel:=strpas(bufVolumeLabel); FFileSystem:=strpas(bufFileSystem); s:=inttohex(FSerial,8); FSerialNumber:=copy(s,1,4) '-' copy(s,5,4); StrDispose(bufVolumeLabel); StrDispose(bufFileSystem); StrDispose(bufRoot); if Flags and FS_CASE_SENSITIVE=FS_CASE_SENSITIVE then FFileFlags:=FFileFlags [fsCaseSensitive]; if Flags and FS_CASE_IS_PRESERVED=FS_CASE_IS_PRESERVED then FFileFlags:=FFileFlags [fsCaseIsPreserved]; if Flags and FS_UNICODE_STORED_ON_DISK=FS_UNICODE_STORED_ON_DISK then FFileFlags:=FFileFlags [fsUnicodeStoredOnDisk]; if Flags and FS_PERSISTENT_ACLS=FS_PERSISTENT_ACLS then FFileFlags:=FFileFlags [fsPersistentAcls]; if Flags and FS_VOL_IS_COMPRESSED=FS_VOL_IS_COMPRESSED then FFileFlags:=FFileFlags [fsVolumeIsCompressed]; if Flags and FS_FILE_COMPRESSION=FS_FILE_COMPRESSION then FFileFlags:=FFileFlags [fsFileCompression]; if MCL=255 then FFileFlags:=FFileFlags [fsLongFileNames]; {if Flags and FILE_SUPPORTS_ENCRYPTION=FILE_SUPPORTS_ENCRYPTION then FFileFlags:=FFileFlags [fsEncryptedFileSystemSupport]; if Flags and FILE_SUPPORTS_OBJECT_IDS=FILE_SUPPORTS_OBJECT_IDS then FFileFlags:=FFileFlags [fsObjectIDsSupport]; if Flags and FILE_SUPPORTS_REPARSE_POINTS=FILE_SUPPORTS_REPARSE_POINTS then FFileFlags:=FFileFlags [fsReparsePointsSupport]; if Flags and FILE_SUPPORTS_SPARSE_FILES=FILE_SUPPORTS_SPARSE_FILES then FFileFlags:=FFileFlags [fsSparseFilesSupport]; if Flags and FILE_VOLUME_QUOTAS=FILE_VOLUME_QUOTAS then FFileFlags:=FFileFlags [fsDiskQuotasSupport]; } end; end else begin FSectorsPerCluster:=0; FBytesPerSector:=0; FFreeClusters:=0; FTotalClusters:=0; {$IFDEF D4PLUS} FCapacity:=0; FFreeSpace:=0; {$ELSE} //FCapacity.QuadPart:=0; FCapacity:=0; //FFreeSpace.QuadPart:=0; FFreeSpace:=0; {$ENDIF} FVolumeLabel:=''; FSerialNumber:=''; FFileSystem:=''; FSerial:=0; end; end; { TWorkstation } function TWorkstation.GetSystemUpTime: Extended; begin try //*FSystemUpTime:=GetTimeStamp.QuadPart/GetTicksPerSecond(1); FSystemUpTime:=GetTimeStamp/GetTicksPerSecond(1); except FSystemUpTime:=0; end; result:=FSystemUpTime; end; procedure TWorkstation.GetInfo; var bdata :pchar; KeyState : TKeyBoardState; const cBIOSName = $FE061; cBIOSDate = $FFFF5; cBIOSExtInfo = $FEC71; cBIOSCopyright = $FE091; rkBIOS = {HKEY_LOCAL_MACHINE\}'HARDWARE\DESCRIPTION\System'; rvBiosDate = 'SystemBiosDate'; rvBiosID = 'Identifier'; rvBiosVersion = 'SystemBiosVersion'; begin try //*FLastBoot:=Now-(GetTimeStamp.QuadPart/GetTicksPerSecond(1))/(24*3600); FLastBoot:=Now-(GetTimeStamp/GetTicksPerSecond(1))/(24*3600); except FLastBoot:=0; end; FSystemUpTime:=GetSystemUpTime; FName:=GetMachine; FUser:=GetUser; if isNT then begin with TRegistry.Create do begin rootkey:=HKEY_LOCAL_MACHINE; if openkey(rkBIOS,false) then begin if valueexists(rvBIOSID) then FBiosName:=readstring(rvBIOSID); if valueexists(rvBIOSVersion) then begin bdata:=stralloc(255); try readbinarydata(rvBIOSVersion,bdata^,255); FBIOSCopyright:=strpas(pchar(bdata)); except end; end; if valueexists(rvBIOSDate) then FBIOSDate:=readstring(rvBIOSDate); closekey; end; free; end; end else begin FBIOSName:=string(pchar(ptr(cBIOSName))); FBIOSDate:=string(pchar(ptr(cBIOSDate))); FBIOSCopyright:=string(pchar(ptr(cBIOSCopyright))); FBIOSExtendedInfo:=string(pchar(ptr(cBIOSExtInfo))); end; GetKeyboardState(KeyState); FCapsLock:=KeyState[VK_CAPITAL]=1; FNumLock:=KeyState[VK_NUMLOCK]=1; FScrollLock:=KeyState[VK_SCROLL]=1; end; procedure TWorkstation.Report(var sl: TStringList); begin with sl do begin add('Name: ' Name); add('User: ' User); add('BIOS name: ' BIOSName); add('BIOS Copyright: ' BIOSCopyright); add('BIOS Date: ' BIOSDate); add('BIOS Extended info: ' BIOSExtendedInfo); add('Last Boot: ' datetimetostr(LastBoot)); add('System Up Time: ' formatseconds(SystemUpTime,true,false,false)); end; end; { TWinsock } procedure TWinsock.GetInfo; var GInitData :TWSADATA; begin if wsastartup($101,GInitData)=0 then begin FDesc:=GInitData.szDescription; FStat:=GInitData.szSystemStatus; FMajVer:=Hi(GInitData.wHighVersion); FMinVer:=Lo(GInitData.wHighVersion); wsacleanup; end else FStat:='Winsock cannot be initialized.'; end; { TNetwork } function TNetwork.GetLocalIP: string; type TaPInAddr = array [0..10] of PInAddr; PaPInAddr = ^TaPInAddr; var phe :PHostEnt; pptr :PaPInAddr; Buffer :array [0..63] of char; i :integer; GInitData :TWSADATA; begin wsastartup($101,GInitData); result:=''; GetHostName(Buffer,SizeOf(Buffer)); phe:=GetHostByName(buffer); if not assigned(phe) then exit; pptr:=PaPInAddr(Phe^.h_addr_list); i:=0; while pptr^[I]<>nil do begin result:=StrPas(inet_ntoa(pptr^[I]^)); inc(i); end; wsacleanup; end; procedure TNetwork.GetInfo; const rkNetworkNT = {HKEY_LOCAL_MACHINE\}'SOFTWARE\Microsoft\Windows NT\CurrentVersion\NetworkCards\1'; rvNetworkNT = 'Description'; rvNet95Class = 'Network adapters'; rvNet2000Class = 'Net'; begin FWinSock.GetInfo; FIPAddress:=GetLocalIP; FAdapter.Clear; with TRegistry.Create do begin rootkey:=HKEY_LOCAL_MACHINE; if isNT then begin if is2000 then begin getclassdevices(rvNet2000Class,FAdapter); end else if openkey(rkNetworkNT,false) then begin if valueexists(rvNetworkNT) then FAdapter.Add(readstring(rvNetworkNT)); closekey; end end else begin getclassdevices(rvNet95Class,FAdapter); end; free; end; end; constructor TNetwork.Create; begin inherited; FWinsock:=TWinsock.Create; FAdapter:=TStringList.Create; end; destructor TNetwork.Destroy; begin FWinsock.Free; FAdapter.Free; inherited; end; procedure TNetwork.Report(var sl: TStringList); begin with sl do begin add('Adapters:'); addstrings(Adapter); add(''); add('IP Address: ' IPAddress); Add(''); Add(Format('%s (%d.%d): %s',[Winsock.Description, Hi(Winsock.MajorVersion), Lo(Winsock.MinorVersion), Winsock.Status])); end; end; { TVideo } procedure TVideo.GetInfo; var rk :string; idata,bdata :pchar; sl :tstringlist; i :integer; const rkVideoNT = {HKEY_LOCAL_MACHINE\}'HARDWARE\DEVICEMAP\VIDEO'; rvVideoNTKey = '\Device\Video0'; rvHardwareNT = 'HardwareInformation'; rvVideoNT = 'AdapterString'; rvDACNT = 'DacType'; rvChipNT = 'ChipType'; rvVideoNTClass = 'Display'; rvVideo95Class = 'Display adapters'; rkInfo = 'INFO'; rv = 'DriverDesc'; rvDAC = 'DACType'; rvChip = 'ChipType'; rvMem = 'VideoMemory'; rvMemNT = 'MemorySize'; rvRev = 'Revision'; rv3D95Class = '3D Accelerators'; rv3DNTClass = '3D Accelerators'; rkBIOS = {HKEY_LOCAL_MACHINE\}'HARDWARE\DESCRIPTION\System'; rvVideoBiosDate = 'VideoBiosDate'; rvVideoBiosVersion = 'VideoBiosVersion'; begin FHorzRes:=GetDeviceCaps(GetDC(0),windows.HORZRES); FVertRes:=GetDeviceCaps(GetDC(0),windows.VERTRES); FColorDepth:=GetDeviceCaps(GetDC(0),BITSPIXEL); case GetDeviceCaps(GetDC(0),windows.TECHNOLOGY) of DT_PLOTTER: FTechnology:='Vector Plotter'; DT_RASDISPLAY: FTechnology:='Raster Display'; DT_RASPRINTER: FTechnology:='Raster Printer'; DT_RASCAMERA: FTechnology:='Raster Camera'; DT_CHARSTREAM: FTechnology:='Character Stream'; DT_METAFILE: FTechnology:='Metafile'; DT_DISPFILE: FTechnology:='Display File'; end; FHorzSize:=GetDeviceCaps(GetDC(0),HORZSIZE); FVertSize:=GetDeviceCaps(GetDC(0),VERTSIZE); FPixelWidth:=GetDeviceCaps(GetDC(0),ASPECTX); FPixelHeight:=GetDeviceCaps(GetDC(0),ASPECTY); FPixelDiagonal:=GetDeviceCaps(GetDC(0),ASPECTXY); FCurveCaps:=[]; if GetDeviceCaps(GetDC(0),windows.CURVECAPS)<>CC_NONE then begin if (GetDeviceCaps(GetDC(0),windows.CURVECAPS) and CC_CIRCLES)=CC_CIRCLES then FCurveCaps:=FCurveCaps [ccCircles]; if (GetDeviceCaps(GetDC(0),windows.CURVECAPS) and CC_PIE)=CC_PIE then FCurveCaps:=FCurveCaps [ccPieWedges]; if (GetDeviceCaps(GetDC(0),windows.CURVECAPS) and CC_CHORD)=CC_CHORD then FCurveCaps:=FCurveCaps [ccChords]; if (GetDeviceCaps(GetDC(0),windows.CURVECAPS) and CC_ELLIPSES)=CC_ELLIPSES then FCurveCaps:=FCurveCaps [ccEllipses]; if (GetDeviceCaps(GetDC(0),windows.CURVECAPS) and CC_WIDE)=CC_WIDE then FCurveCaps:=FCurveCaps [ccWideBorders]; if (GetDeviceCaps(GetDC(0),windows.CURVECAPS) and CC_STYLED)=CC_STYLED then FCurveCaps:=FCurveCaps [ccStyledBorders]; if (GetDeviceCaps(GetDC(0),windows.CURVECAPS) and CC_WIDESTYLED)=CC_WIDESTYLED then FCurveCaps:=FCurveCaps [ccWideStyledBorders]; if (GetDeviceCaps(GetDC(0),windows.CURVECAPS) and CC_INTERIORS)=CC_INTERIORS then FCurveCaps:=FCurveCaps [ccInteriors]; if (GetDeviceCaps(GetDC(0),windows.CURVECAPS) and CC_ROUNDRECT)=CC_ROUNDRECT then FCurveCaps:=FCurveCaps [ccRoundedRects]; end; FLineCaps:=[]; if GetDeviceCaps(GetDC(0),windows.LINECAPS)<>LC_NONE then begin if (GetDeviceCaps(GetDC(0),windows.LINECAPS) and LC_POLYLINE)=LC_POLYLINE then FLineCaps:=FLineCaps [lcPolylines]; if (GetDeviceCaps(GetDC(0),windows.LINECAPS) and LC_MARKER)=LC_MARKER then FLineCaps:=FLineCaps [lcMarkers]; if (GetDeviceCaps(GetDC(0),windows.LINECAPS) and LC_POLYMARKER)=LC_POLYMARKER then FLineCaps:=FLineCaps [lcMultipleMarkers]; if (GetDeviceCaps(GetDC(0),windows.LINECAPS) and LC_WIDE)=LC_WIDE then FLineCaps:=FLineCaps [lcWideLines]; if (GetDeviceCaps(GetDC(0),windows.LINECAPS) and LC_STYLED)=LC_STYLED then FLineCaps:=FLineCaps [lcStyledLines]; if (GetDeviceCaps(GetDC(0),windows.LINECAPS) and LC_WIDESTYLED)=LC_WIDESTYLED then FLineCaps:=FLineCaps [lcWideStyledLines]; if (GetDeviceCaps(GetDC(0),windows.LINECAPS) and LC_INTERIORS)=LC_INTERIORS then FLineCaps:=FLineCaps [lcInteriors]; end; FPolygonCaps:=[]; if GetDeviceCaps(GetDC(0),POLYGONALCAPS)<>PC_NONE then begin if (GetDeviceCaps(GetDC(0),POLYGONALCAPS) and PC_POLYGON)=PC_POLYGON then FPolygonCaps:=FPolygonCaps [pcAltFillPolygons]; if (GetDeviceCaps(GetDC(0),POLYGONALCAPS) and PC_RECTANGLE)=PC_RECTANGLE then FPolygonCaps:=FPolygonCaps [pcRectangles]; if (GetDeviceCaps(GetDC(0),POLYGONALCAPS) and PC_WINDPOLYGON)=PC_WINDPOLYGON then FPolygonCaps:=FPolygonCaps [pcWindingFillPolygons]; if (GetDeviceCaps(GetDC(0),POLYGONALCAPS) and PC_SCANLINE)=PC_SCANLINE then FPolygonCaps:=FPolygonCaps [pcSingleScanlines]; if (GetDeviceCaps(GetDC(0),POLYGONALCAPS) and PC_WIDE)=PC_WIDE then FPolygonCaps:=FPolygonCaps [pcWideBorders]; if (GetDeviceCaps(GetDC(0),POLYGONALCAPS) and PC_STYLED)=PC_STYLED then FPolygonCaps:=FPolygonCaps [pcStyledBorders]; if (GetDeviceCaps(GetDC(0),POLYGONALCAPS) and PC_WIDESTYLED)=PC_WIDESTYLED then FPolygonCaps:=FPolygonCaps [pcWideStyledBorders]; if (GetDeviceCaps(GetDC(0),POLYGONALCAPS) and PC_INTERIORS)=PC_INTERIORS then FPolygonCaps:=FPolygonCaps [pcInteriors]; end; FRasterCaps:=[]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_BANDING)=RC_BANDING then FRasterCaps:=FRasterCaps [rcRequiresBanding]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_BITBLT)=RC_BITBLT then FRasterCaps:=FRasterCaps [rcTranserBitmaps]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_BITMAP64)=RC_BITMAP64 then FRasterCaps:=FRasterCaps [rcBitmaps64K]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_DI_BITMAP)=RC_DI_BITMAP then FRasterCaps:=FRasterCaps [rcSetGetDIBits]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_DIBTODEV)=RC_DIBTODEV then FRasterCaps:=FRasterCaps [rcSetDIBitsToDevice]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_FLOODFILL)=RC_FLOODFILL then FRasterCaps:=FRasterCaps [rcFloodfills]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_GDI20_OUTPUT)=RC_GDI20_OUTPUT then FRasterCaps:=FRasterCaps [rcWindows2xFeatures]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_PALETTE)=RC_PALETTE then FRasterCaps:=FRasterCaps [rcPaletteBased]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_SCALING)=RC_SCALING then FRasterCaps:=FRasterCaps [rcScaling]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_STRETCHBLT)=RC_STRETCHBLT then FRasterCaps:=FRasterCaps [rcStretchBlt]; if (GetDeviceCaps(GetDC(0),windows.RASTERCAPS) and RC_STRETCHDIB)=RC_STRETCHDIB then FRasterCaps:=FRasterCaps [rcStretchDIBits]; FTextCaps:=[]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_OP_CHARACTER)=TC_OP_CHARACTER then FTextCaps:=FTextCaps [tcCharOutPrec]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_OP_STROKE)=TC_OP_STROKE then FTextCaps:=FTextCaps [tcStrokeOutPrec]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_CP_STROKE)=TC_CP_STROKE then FTextCaps:=FTextCaps [tcStrokeClipPrec]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_CR_90)=TC_CR_90 then FTextCaps:=FTextCaps [tcCharRotation90]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_CR_ANY)=TC_CR_ANY then FTextCaps:=FTextCaps [tcCharRotationAny]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_SF_X_YINDEP)=TC_SF_X_YINDEP then FTextCaps:=FTextCaps [tcScaleIndependent]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_SA_DOUBLE)=TC_SA_DOUBLE then FTextCaps:=FTextCaps [tcDoubledCharScaling]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_SA_INTEGER)=TC_SA_INTEGER then FTextCaps:=FTextCaps [tcIntMultiScaling]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_SA_CONTIN)=TC_SA_CONTIN then FTextCaps:=FTextCaps [tcAnyMultiExactScaling]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_EA_DOUBLE)=TC_EA_DOUBLE then FTextCaps:=FTextCaps [tcDoubleWeightChars]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_IA_ABLE)=TC_IA_ABLE then FTextCaps:=FTextCaps [tcItalics]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_UA_ABLE)=TC_UA_ABLE then FTextCaps:=FTextCaps [tcUnderlines]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_SO_ABLE)=TC_SO_ABLE then FTextCaps:=FTextCaps [tcStrikeouts]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_RA_ABLE)=TC_RA_ABLE then FTextCaps:=FTextCaps [tcRasterFonts]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_VA_ABLE)=TC_VA_ABLE then FTextCaps:=FTextCaps [tcVectorFonts]; if (GetDeviceCaps(GetDC(0),windows.TEXTCAPS) and TC_SCROLLBLT)=TC_SCROLLBLT then FTextCaps:=FTextCaps [tcNoScrollUsingBlts]; sl:=tstringlist.create; FAdapter.Clear; FDAC.Clear; FChipset.Clear; FMemory.Clear; bdata:=stralloc(255); with TRegistry.Create do begin rootkey:=HKEY_LOCAL_MACHINE; if isNT then begin if is2000 then begin rk:=getclassdevices(rvVideoNTClass,FAdapter); if openkey(rk,false) then begin getkeynames(sl); closekey; for i:=0 to sl.count-1 do if openkey(rk '\' sl[i] '\' rkinfo,false) then begin if valueexists(rvDAC) then FDAC.Add(readstring(rvDAC)); if valueexists(rvChip) then FChipset.Add(readstring(rvChip)); if valueexists(rvRev) then FChipset[FChipset.Count-1]:=FChipset[FChipset.Count-1] ' Rev ' readstring(rvRev); if valueexists(rvMem) then FMemory.Add(inttostr(readinteger(rvMem))); closekey; end; end; end else begin if openkey(rkVideoNT,false) then begin if valueexists(rvVideoNTKey) then rk:=readstring(rvVideoNTKey) else rk:=''; closekey; if rk<>'' then begin rk:=copy(rk,pos('Machine\',rk) 8,255); if openkey(rk,false) then begin if valueexists(rvHardwareNT '.' rvVideoNT) then try readbinarydata(rvHardwareNT '.' rvVideoNT,bdata^,255); FAdapter.Add(getstrfrombuf(pchar(bdata))); except end; if valueexists(rvHardwareNT '.' rvDACNT) then try readbinarydata(rvHardwareNT '.' rvDACNT,bdata^,255); FDAC.Add(getstrfrombuf(pchar(bdata))); except end; if valueexists(rvHardwareNT '.' rvChipNT) then try readbinarydata(rvHardwareNT '.' rvChipNT,bdata^,255); FChipset.Add(getstrfrombuf(pchar(bdata))); except end; if valueexists(rvHardwareNT '.' rvmemNT) then try idata:=stralloc(255); readbinarydata(rvHardwareNT '.' rvMemNT,idata,4); FMemory.Add(inttostr(integer(idata))); strdispose(idata); except end; closekey; end; end; end; end; if openkey(rkBIOS,false) then begin if valueexists(rvVideoBIOSVersion) then begin try readbinarydata(rvVideoBIOSVersion,bdata^,151); FBIOSVersion:=strpas(pchar(bdata)); except end; end; if valueexists(rvVideoBIOSDate) then FBIOSDate:=readstring(rvVideoBIOSDate); closekey; end; end else begin rk:=getclassdevices(rvVideo95Class,FAdapter); if openkey(rk,false) then begin getkeynames(sl); closekey; for i:=0 to sl.count-1 do if openkey(rk '\' sl[i] '\' rkinfo,false) then begin if valueexists(rvDAC) then FDAC.Add(readstring(rvDAC)); if valueexists(rvChip) then FChipset.Add(readstring(rvChip)); if valueexists(rvRev) then FChipset[FChipset.Count-1]:=FChipset[FChipset.Count-1] ' Rev ' readstring(rvRev); if valueexists(rvMem) then FMemory.Add(inttostr(readinteger(rvMem))); closekey; end; end; end; free; end; FAcc.Clear; getclassdevices(rv3D95Class,FAcc); strdispose(bdata); sl.free; end; procedure TVideo.GetCurveCapsStr(AClear :boolean; ACaps: TStringList); begin if AClear then ACaps.Clear; ACaps.Add('Circles: ' bool2yn(ccCircles in CurveCaps)); ACaps.Add('Pie Wedges: ' bool2yn(ccPieWedges in CurveCaps)); ACaps.Add('Chords: ' bool2yn(ccChords in CurveCaps)); ACaps.Add('Ellipses: ' bool2yn(ccEllipses in CurveCaps)); ACaps.Add('Wide Borders: ' bool2yn(ccWideBorders in CurveCaps)); ACaps.Add('Styled Borders: ' bool2yn(ccStyledBorders in CurveCaps)); ACaps.Add('Wide and Styled Borders: ' bool2yn(ccWideStyledBorders in CurveCaps)); ACaps.Add('Interiors: ' bool2yn(ccInteriors in CurveCaps)); ACaps.Add('Rounded Rectangles: ' bool2yn(ccRoundedRects in CurveCaps)); end; procedure TVideo.GetLineCapsStr(AClear :boolean; ACaps: TStringList); begin if AClear then ACaps.Clear; ACaps.Add('Polylines: ' bool2yn(lcPolylines in LineCaps)); ACaps.Add('Markers: ' bool2yn(lcMarkers in LineCaps)); ACaps.Add('Multiple Markers: ' bool2yn(lcMultipleMarkers in LineCaps)); ACaps.Add('Wide Lines: ' bool2yn(lcWideLines in LineCaps)); ACaps.Add('Styled Lines: ' bool2yn(lcStyledLines in LineCaps)); ACaps.Add('Wide and Styled Lines: ' bool2yn(lcWideStyledLines in LineCaps)); ACaps.Add('Interiors: ' bool2yn(lcInteriors in LineCaps)); end; procedure TVideo.GetPolygonCapsStr(AClear :boolean; ACaps: TStringList); begin if AClear then ACaps.Clear; ACaps.Add('Alternate Fill Polygons: ' bool2yn(pcAltFillPolygons in PolygonCaps)); ACaps.Add('Rectangles: ' bool2yn(pcRectangles in PolygonCaps)); ACaps.Add('Winding Fill Polygons: ' bool2yn(pcWindingFillPolygons in PolygonCaps)); ACaps.Add('Single Scanlines: ' bo

可以排版一下嗎 ? Thanks ! 

------
能力不足，求助於人；有能力時，幫幫別人；如果您滿意答覆，請適時結案！

子曰：問有三種，不懂則問，雖懂有疑則問，雖懂而想知更多則問！