Конфигурация аппаратных средств персонального компьютера (стр. 2 из 2)
Отображение информации.
По нажатию одной из кнопок вступает в работу соответствующая процедура обработки, которая производит подготовку и вывод нужной информации. В результате в окне справа появляется информация, касающаяся выбранной группы.
Линейка быстрой помощи
При наведении курсора мыши на каждую из кнопок в линейке быстрой помощи появляется информация её функции .
4. Текст программы
Ниже приводится текст разработанной программы:
Код формы HV1(HV1.frm):
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 Sub
Код формы Progress(Pr.frm):
Private Sub Form_Load()
DrawWidth = 3
End Sub
Код модуля Module1(Hwm.bas):
Public 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 Sub
Код класса clsMemorySnapshot(Memory.cls)
Option 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
Заключение
Программа полностью выполнила все поставленные перед ней задачи при тестировании, что позволяет сделать вывод о её пригодности для определения конфигурации компьютера и использования в качестве дополнения к, уже имеющимся в составе операционной системы Windows , средствам получения информации об аппаратных средствах с более простым и удобным интерфейсом.