Определение аппаратной конфигурации персонального компьютера - VB

Private Sub Form_Load()
    Progress.Show
    Call SB_Sveden
    Progress.Hide
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub Command1_Click()
    SubK$ = "Hardware\Description\System\CentralProcessor\0"
    On Error GoTo Noread
    ProcID$ = HV1.RegCtrl1.RReadValue(HK$, SubK$, "Identifier")
Noread:  On Error Resume Next
    On Error GoTo Noread1
    ProcMMX$ = HV1.RegCtrl1.RReadValue(HK$, SubK$, "MMXIdentifier")
Noread1:  On Error Resume Next
    On Error GoTo Noread2
    VendorID$ = HV1.RegCtrl1.RReadValue(HK$, SubK$, "VendorIdentifier")
Noread2:  Err.Clear
    CpInst$ = ""
    If Coproc Then CpInst$ = "Сопроцессор встроенный"
    Box1 = ProcID$ & vbCrLf & ProcMMX$ & vbCrLf & VendorID$ & vbCrLf &  "  "
& vbCrLf & CpInst$
    On Error GoTo 0
End Sub
 
Private Sub Command1_MouseMove(Button As Integer, Shift  As  Integer,  X  As
Single, Y As Single)
    Label1.Caption = "Информация о центральном процессоре."
End Sub
 
Private Sub Command2_Click()
    Call B_Text(2)
End Sub
Private Sub Command2_MouseMove(Button As Integer, Shift  As  Integer,  X  As
Single, Y As Single)
    Label1.Caption = "Информация о системной плате."
End Sub
Private Sub Command3_Click()
    Dim clsMem As New clsMemorySnapshot
    Box1 = "Объём физической  памяти  :   "  &  Format(clsMem.TotalMemory  \
1024,   "###,###,###,###,##0")   &   "   KB"   &    vbCrLf    &    "Свободно
            :  " & Format(clsMem.FreeMemory \  1024,  "###,###,###,###,##0")
& " KB*" & vbCrLf
End Sub
Private Sub Command3_MouseMove(Button As Integer, Shift  As  Integer,  X  As
Single, Y As Single)
    Label1.Caption = "Информация о памяти."
End Sub
 
Private Sub Command4_Click()
ms = MsgBox("Рекомендуется вставить диски во  все  дисководы.",  vbOKCancel,
"ВНИМАНИЕ!")
GetDiskInfo
Box1 = ""
For Ka = 1 To n
tc$ = Str((BytesPerSec(Ka) * SecsPerClus(Ka) * TotalNumOfClus(Ka) / 1000)  /
1000)
fc$ = Str((BytesPerSec(Ka) * SecsPerClus(Ka) * NumOfFreeClus(Ka) /  1000)  /
1000)
Box1 = Box1 & "Информация о диске: " & Drives(Ka) & vbCrLf & _
"Метка тома: " & VNBuffer(Ka) & vbCrLf & _
"Файловая система: " & vSysBuff(Ka) & vbCrLf & _
"Серийный номер: " & vSerialNum(Ka) & vbCrLf & _
"Тип диска: " & TypeOfDrive(Ka) & vbCrLf & _
"Общее количество кластеров: " & TotalNumOfClus(Ka) & vbCrLf & _
"Количество свободных кластеров: " & NumOfFreeClus(Ka) & vbCrLf & _
"Секторов в кластере: " & SecsPerClus(Ka) & vbCrLf & _
"Байтов в секторе: " & BytesPerSec(Ka) & vbCrLf & _
"Емкость: " & tc$ & "mb" & vbCrLf & _
"Свободно: " & fc$ & "mb" & vbCrLf & " " & vbCrLf
Next
End Sub
 
Private Sub Command4_MouseMove(Button As Integer, Shift  As  Integer,  X  As
Single, Y As Single)
    Label1.Caption = "Информация о дисках."
End Sub
 
Private Sub Command5_Click()
    Call B_Text(5)
End Sub
Private Sub Command5_MouseMove(Button As Integer, Shift  As  Integer,  X  As
Single, Y As Single)
    Label1.Caption = "Информация о  установленных  адаптерах  (звук,  видео,
модем и т.д.)."
End Sub
Private Sub Command6_Click()
    Call B_Text(6)
End Sub
Private Sub Command6_MouseMove(Button As Integer, Shift  As  Integer,  X  As
Single, Y As Single)
     Label1.Caption  =  "Информация  о  устройствах  ввода/вывода  (монитор,
клавиатура, принтер и т.д.)."
End Sub
 
Sub B_Text(Comm As Integer)
Select Case Comm
    Case 2
        l = 0
        k = k0
    Case 5
        l = 2
        k = k2
    Case 6
        l = 1
        k = k1
End Select
    For i = 1 To k
        s$ = s$ + (Sv(l, i) & vbCrLf)
    Next i
    Box1 = s$
End SubPrivate Sub Form_Load()
    DrawWidth = 3
End SubPublic   Declare   Function   GetDiskFreeSpace    Lib    "kernel32"    Alias
"GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster  As
Long,   lpBytesPerSector   As   Long,   lpNumberOfFreeClusters   As    Long,
lpTotalNumberOfClusters As Long) As Long
Public Declare Function GetDriveType Lib  "kernel32"  Alias  "GetDriveTypeA"
(ByVal nDrive As String) As Long
Public  Declare   Function   GetVolumeInformation   Lib   "kernel32"   Alias
"GetVolumeInformationA"   (ByVal    lpRootPathName    As    String,    ByVal
lpVolumeNameBuffer   As   String,    ByVal    nVolumeNameSize    As    Long,
lpVolumeSerialNumber   As   Long,    lpMaximumComponentLength    As    Long,
lpFileSystemFlags As Long, ByVal  lpFileSystemNameBuffer  As  String,  ByVal
nFileSystemNameSize As Long) As Long
Public Sv(2, 1000) As String
Public Coproc As Boolean
Public X1, X2, Y1, dX As Integer
Public k0 As Integer
Public k1 As Integer
Public k2 As Integer
Public Const HK$ = "HKEY_LOCAL_MACHINE"
Public cpuspd As Long
Public FF As Boolean
Public Drives(100) As String
Public n
Public Ka
Public vSerialNum(100) As Long
Public vCompLen(100) As Long
Public vFlags(100) As Long
Public vSysBuff(100) As String
Public vSysSize(100) As Long
Public SecsPerClus(100) As Long
Public BytesPerSec(100) As Long
Public NumOfFreeClus(100) As Long
Public TotalNumOfClus(100) As Long
Public TypeOfDrive(100) As String
Public VNBuffer(100) As String
Public VNSize(100) As Long
Public Const DRIVE_CDROM = 5
Public Const DRIVE_FIXED = 3
Public Const DRIVE_RAMDISK = 6
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_REMOVABLE = 2
 
Sub SB_Sveden()
Dim mDir(1000), mDir1, mStr, mDDir(100) As String
Dim mClass, nClass(1000) As String
Dim s, s1 As String
Dim a As Integer
    X1 = Progress.Line1.X1: X2 = Progress.Line1.X2
    Y1 = Progress.Line1.Y1
    ChDir ("C:\WINDOWS\INF")
    mDDir(0) = "C:\Windows\INF\"
    mDTMP = Dir(mDDir(0), vbDirectory)
    i = 0
    Do While mDTMP <> ""
        If mDTMP <> "." And mDTMP <> ".." Then
            If (GetAttr(mDDir(0) & mDTMP)  And  vbDirectory)  =  vbDirectory
Then
                i = i + 1: mDDir(i) = mDTMP
            End If
        End If
        mDTMP = Dir
    Loop
    On Error GoTo EndFindINF
    For j = 1 To i
        mDir1 = Dir("C:\Windows\INF\" + mDDir(j) + "\*.inf")
        While mDir1 <> ""
            a = a + 1
            mDir(a) = mDDir(0) + mDDir(j) + "\" + mDir1
            mDir1 = Dir()
        Wend
     Next j
        mDir1 = Dir("C:\WINDOWS\INF\*.inf")
        While mDir1 <> ""
            a = a + 1
            mDir(a) = mDDir(0) + mDir1
            mDir1 = Dir()
        Wend
EndFindINF:
    Err.Clear
    dX = (X2 - X1) / a
    For i = 1 To a
    On Error GoTo 0
    Open mDir(i) For Input As #1
    XE = X1 + (dX * i)
    Progress.Line (X1, Y1)-(XE, Y1), &H8000000D
    f = 0
sClFind:
    If Not (EOF(1)) And f = 0 Then
        Input #1, mClass
        If Mid(mClass, 1, 5) = "Class" And  (Mid(mClass,  6,  1)  =  "="  Or
Mid(mClass, 6, 1) = " ") Then
            a1 = a1 + 1: f = 1
            mClass = Mid(mClass, 7)
            For j = 1 To Len(mClass)
                mStr = Mid(mClass, j, 1)
                If mStr <> " " And mStr <> "="  And  mStr  <>  Chr(34)  Then
nClass(a1) = nClass(a1) + mStr
            Next j
            For j = 1 To a1 - 1
                s = StrConv(nClass(a1), vbLowerCase)
                s1 = StrConv(nClass(j), vbLowerCase)
                If s = s1 Then nClass(a1) = "": a1 = a1 - 1:  f  =  0:  Exit
For
            Next j
            If f = 1 Then
                If nClass(a1) <> "DiskDrive" And nClass(a1)  <>  "NetClient"
And nClass(a1) <> "NetService" And nClass(a1) <> "NetTrans"  And  nClass(a1)
<> "CDROM" Then Call FClassCH(nClass(a1))
            End If
        Else: GoTo sClFind
        End If
    End If
    Close #1
    Next i
End Sub
 
Sub FClassCH(FClass As String)
    Num$ = "\0000"
    For i = 0 To 1999
        tmp$ = Mid(Str(i), 2)
        tmp1 = Len(tmp$)
        Mid(Num$, 6 - tmp1, tmp1) = tmp$
        SubK$ = "System\CurrentControlSet\Services\Class\" + FClass + Num$
        On Error GoTo NoDev
        DDesc$ = HV1.RegCtrl1.RReadValue(HK$, SubK$, "DriverDesc")
        On Error GoTo 0
        If i = 0 Then
            DD$ = " "
            Call GroupDev(FClass, DD$, "")
            SubK$ = "System\CurrentControlSet\Services\Class\" + FClass
            DD$ = HV1.RegCtrl1.RReadValue(HK$, SubK$, "")
            Call GroupDev(FClass, DD$, "")
            DD$ = String(70, "-")
            Call GroupDev(FClass, DD$, "")
        End If
        If DDesc$ <> "Coprocessor" And DDesc$  <>  "Сопроцессор"  Then  Call
GroupDev(FClass, DDesc$, Num$) Else Coproc = True
NoDev:  If Err <> 0 Then Exit For
    Next i
    Err.Clear
End Sub
 
Sub GroupDev(DClass, DDsc, Nm As String)
    If DClass = "System" Or DClass = "fdc" Or DClass =  "hdc"  Or  DClass  =
"Infrared" Then k0 = k0 + 1: Sv(0, k0) = DDsc: Exit Sub
    If DClass = "MTD" Or DClass = "MultiFunction" Or DClass  =  "PCMCIA"  Or
DClass = "Ports" Then k0 = k0 + 1: Sv(0, k0) = DDsc: Exit Sub
    If DClass = "USB" Then k0 = k0 + 1: Sv(0, k0) = DDsc: Exit Sub
    If DClass = "Monitor" Or DClass = "Keyboard"  Or  DClass  =  "Mouse"  Or
DClass = "Printer" Then k1 = k1 + 1: Sv(1, k1) = DDsc: Exit Sub
    SubK$ = "System\CurrentControlSet\Services\Class\" + DClass + Nm
    On Error GoTo NoMD
       MDId$    =    HV1.RegCtrl1.RReadValue("HKEY_LOCAL_MACHINE",    SubK$,
"MatchingDeviceId")
    On Error GoTo 0
    If Mid(MDId$, 1, 3) = "PCI" Then DDsc = "(PCI)  " + DDsc
    If Mid(MDId$, 1, 6) = "ISAPNP" Then DDsc = "(ISA)  " + DDsc
NoMD:
    k2 = k2 + 1: Sv(2, k2) = DDsc
    Err.Clear
End Sub
 
Sub GetDiskInfo()
n = 0
For i = 65 To 90
If GetDriveType(Chr$(i) & ":" & "\") <> 1 Then  n  =  n  +  1:  Drives(n)  =
Chr$(i) & ":" & "\"
Next i
For i = 1 To n
Call     GetDiskFreeSpace(Drives(i),     SecsPerClus(i),     BytesPerSec(i),
NumOfFreeClus(i), TotalNumOfClus(i))
Select Case GetDriveType(Drives(i))
Case DRIVE_CDROM
TypeOfDrive(i) = "CD-ROM"
Case DRIVE_REMOVABLE
TypeOfDrive(i) = "Floppy disk"
Case DRIVE_FIXED
TypeOfDrive(i) = "Hard disk drive"
Case DRIVE_RAMDISK
TypeOfDrive(i) = "Virtual disk"
Case DRIVE_REMOTE
TypeOfDrive(i) = "Net disk"
Case Else
End Select
Next
For i = 1 To n
VNBuffer(i) = Space$(255)
VNSize(i) = 255
vSysBuff(i) = Space$(255)
vSysSize(i) = 255
vFlags(i) = 0
vCompLen(i) = 255
vSerialNum(i) = 255
lRet    =    GetVolumeInformation(Drives(i),     VNBuffer(i),     VNSize(i),
vSerialNum(i), vCompLen(i), vFlags(i), vSysBuff(i), vSysSize(i))
If lRet = 1 Then VNBuffer(i) =  Left$(VNBuffer(i),  Len(RTrim$(VNBuffer(i)))
-  1):  vSysBuff(i)  =  Left$(vSysBuff(i),  Len(RTrim$(vSysBuff(i)))  -  1):
vSerialNum(i) = Left$(vSerialNum(i), Len(RTrim$(vSerialNum(i))) - 1)
If lRet = False Then VNBuffer(i) = "None": vSysBuff(i) = "None"
Next
End SubOption Explicit
Private Type MEMORYSTATUS
        dwLength As Long
        dwMemoryLoad As Long
        dwTotalPhys As Long
        dwAvailPhys As Long
        dwTotalPageFile As Long
        dwAvailPageFile As Long
        dwTotalVirtual As Double
        dwAvailVirtual As Double
End Type
 
Private Declare Sub GlobalMemoryStatus Lib "kernel32" _
    (lpBuffer As MEMORYSTATUS)
Private mmemMemoryStatus As MEMORYSTATUS
Public Property Get FreeMemory() As Long
    FreeMemory = mmemMemoryStatus.dwAvailPhys
End Property
Public Property Get TotalMemory() As Long
    TotalMemory = mmemMemoryStatus.dwTotalPhys
End Property
Public Property Get TotalVirtualMemory() As Double
    TotalVirtualMemory = mmemMemoryStatus.dwTotalVirtual
End Property
Public Property Get AvailableVirtualMemory() As Double
    AvailableVirtualMemory = mmemMemoryStatus.dwAvailVirtual
End Property
Private Sub Class_Initialize()
    mmemMemoryStatus.dwLength = Len(mmemMemoryStatus)
    GlobalMemoryStatus mmemMemoryStatus
End Sub
Public Sub Refresh()
    GlobalMemoryStatus mmemMemoryStatus
End Sub

Sub SB_Sveden()
Dim mDir(1000), mDir1, mStr, mDDir(100) As String
Dim mClass, nClass(1000) As String
Dim s, s1 As String
Dim a As Integer
    X1 = Progress.Line1.X1: X2 = Progress.Line1.X2
    Y1 = Progress.Line1.Y1