With FP
.sFileRoot = QualifyPath(Combo1.Text + "\") 'начальный путь
.sFileNameExt = "*.*" 'нужные файлы
.bRecurse = 1 'True = рекурсией
End With
Call GetDirectorySize(FP.sFileRoot, FP)
GetVolumeInformation Combo1.Text + "\", VName, 255, Serial, 0, 0, FSName, 255
Retval = GetDiskFreeSpace(Combo1.Text + "\", SecPerClus, BytePerSec, FreeClus, TotalClus)
VName = Left$(VName, InStr(1, VName, Chr$(0)) - 1)
FSName = Left$(FSName, InStr(1, FSName, Chr$(0)) - 1)
Free = (FreeClus / 1000 * SecPerClus * BytePerSec) * 1000
If MainForm.NumDrive = 2 Then Label1(0).Caption = "Тип устройства: Съемный диск"
If MainForm.NumDrive = 3 Then Label1(0).Caption = "Тип устройства: Жесткий диск"
If MainForm.NumDrive = 5 Then Label1(0).Caption = "Тип устройства: CD или DVD диск"
Label1(1).Caption = "Полный объем: " + Format$(FP.nFileSize + Free, "#,###") & " байт" + " (" + Format$((FP.nFileSize + Free) / 1073741824, "###.#") + " Гбайт)"
Label1(2).Caption = "Свобоный объем: " + Format$(Free, "#,###") & " байт" + " (" + Format$(Free / 1073741824, "###.#") + " Гбайт)"
Label1(3).Caption = "Используемый объем: " + Format$(FP.nFileSize, "###,###,###,###") + " байт" + " (" + Format$(FP.nFileSize / 1073741824, "###.#") + " Гбайт)"
Label1(4).Caption = "Файловая система: " + FSName
Label1(5).Caption = "Число свободных кластеров: " + CStr(FreeClus)
Label1(6).Caption = "Число секторов в кластере: " + CStr(SecPerClus)
Label1(7).Caption = "Число байт в секторе: " + CStr(BytePerSec)
Label1(8).Caption = "Общее число кластеров: " + CStr(TotalClus)
ProgressBar1.Value = ((FP.nFileSize / (FP.nFileSize + Free)) * 100): Label2.Caption = CStr(CInt(ProgressBar1.Value)) + "%"
End Sub
Private Sub Form_Load()
Dim i As Byte, drivetype As Long, k As Byte
FillCombo Combo1, True
For i = 0 To Combo1.ListCount - 1
Combo1.ListIndex = i
drivetype = GetDriveType(Combo1.Text + "\")
If drivetype = MainForm.NumDrive Then Combo1.AddItem Combo1.Text: k = k + 1
Next i
For i = 0 To Combo1.ListCount - k - 1
Combo1.RemoveItem 0
Next i
Combo1.ListIndex = 0
Call Command2_Click
End Sub
Private Sub FillCombo(cbo As ComboBox, ByVal bUsed As Boolean)
Dim DriveNum As Long
cbo.Clear
For DriveNum = 0 To 25
If CBool(GetLogicalDrives And (2 ^ DriveNum)) = bUsed Then
cbo.AddItem Chr$(Asc("A") + DriveNum) & ":"
End If
Next DriveNum
End Sub
Private Sub GetDirectorySize(sRoot As String, FP As FILE_PARAMS)
Dim wfd As WIN32_FIND_DATA
Dim hFile As Long
hFile = FindFirstFile(sRoot & "*.*", wfd)
If hFile <> INVALID_HANDLE_VALUE Then
Do
If Asc(wfd.cFileName) <> vbDot Then
If (wfd.dwFileAttributes And vbDirectory) Then
If FP.bRecurse Then
GetDirectorySize sRoot & TrimNull(wfd.cFileName) & "\", FP
End If 'If fp.bRecurse
Else
FP.nFileCount = FP.nFileCount + 1
FP.nFileSize = FP.nFileSize + ((wfd.nFileSizeHigh * (MAXDWORD + 1)) + wfd.nFileSizeLow)
End If 'If WFD.dwFileAttributes
End If 'If Asc(wfd.cFileName)
FP.nSearched = FP.nSearched + 1
Loop While FindNextFile(hFile, wfd)
End If 'If hFile
End Sub
Private Function TrimNull(startstr As String) As String
TrimNull = Left$(startstr, lstrlen(StrPtr(startstr)))
End Function
Private Function QualifyPath(sPath As String) As String
If Right$(sPath, 1) <> "\" Then
QualifyPath = sPath & "\"
Else
QualifyPath = sPath
End If
End Function
Приложение 4 (листинг модуля окна свойств дисплея)
Option Explicit
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Const DRIVERVERSION As Long = 0 'Версия драйвера
Private Const TECHNOLOGY As Long = 2 'Классификация устройства
Private Const HORZSIZE As Long = 4 'Размер по горизонтали в мм.
Private Const VERTSIZE As Long = 6 'Размер по вертикали в мм.
Private Const HORZRES As Long = 8 'Размер по горизонтали в точках
Private Const VERTRES As Long = 10 'Размер по вертикали в точках
Private Const BITSPIXEL As Long = 12 'Кол-во бит на точку
Private Const PLANES As Long = 14 'Number of planes
Private Const NUMBRUSHES As Long = 16 'Number of brushes the device has
Private Const NUMPENS As Long = 18 'Number of pens the device has
Private Const NUMMARKERS As Long = 20 'Number of markers the device has
Private Const NUMFONTS As Long = 22 'Number of fonts the device has
Private Const NUMCOLORS As Long = 24 'Макс. кол-во возможных цветов
Private Const PDEVICESIZE As Long = 26 'Size required for device descripto
Private Const CURVECAPS As Long = 28 'Curve capabilities
Private Const LINECAPS As Long = 30 'Line capabilities
Private Const POLYGONALCAPS As Long = 32 'Polygonal capabilities
Private Const TEXTCAPS As Long = 34 'Text capabilities
Private Const CLIPCAPS As Long = 36 'Clipping capabilities
Private Const RASTERCAPS As Long = 38 'Bitblt capabilities
Private Const ASPECTX As Long = 40 'Length of the X leg
Private Const ASPECTY As Long = 42 'Length of the Y leg
Private Const ASPECTXY As Long = 44 'Length of the hypotenuse
Private Const SHADEBLENDCAPS As Long = 45 'Shading and blending caps (IE5)
Private Const LOGPIXELSX As Long = 88 'Logical pixels/inch in X
Private Const LOGPIXELSY As Long = 90 'Logical pixels/inch in Y
Private Const SIZEPALETTE As Long = 104 'Number of entries in physical palette
Private Const NUMRESERVED As Long = 106 'Number of reserved entries in palette
Private Const COLORRES As Long = 108 'Количество цветов
Private Const VREFRESH As Long = 116 'Текущий рефрешь по вертикали в Гц
'(только для монитора)
Private Const DESKTOPVERTRES As Long = 117 'Размер десктопа по горизонтали
Private Const DESKTOPHORZRES As Long = 118 'Размер десктопа по вертикали
Private Const BLTALIGNMENT As Long = 119 'Preferred blt alignment
'Для списка режимов
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Const CCDEVICENAME = 32
Private Const CCFORMNAME = 32
Private Type DEVMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim sBPPtype As String
Dim sFreqtype As String
Dim CurrBPP As Long
Dim CurrVFreq As Long
'Подписываем глубину цвета для удобства чтения
CurrBPP = GetDeviceCaps(hdc, BITSPIXEL)
Select Case CurrBPP
Case 4: sBPPtype = "(16 цветов)"
Case 8: sBPPtype = "(256 цветов)"
Case 16: sBPPtype = "(High Color)"
Case 24, 32: sBPPtype = "(True Color)"
End Select
CurrVFreq = GetDeviceCaps(hdc, VREFRESH)
Select Case CurrVFreq
Case 0, 1: sFreqtype = "(Определяется адаптером)"
Case Else: sFreqtype = "(Ручная настройка)"
End Select
Label1(0).Caption = "Разрешение по горизонтали: " & GetDeviceCaps(hdc, HORZRES) & " пикселей"
Label1(1).Caption = "Разрешение по вертикали: " & GetDeviceCaps(hdc, VERTRES) & " пикселей"
Label1(2).Caption = "Разрешение по горизонтали в миллиметрах: " & GetDeviceCaps(hdc, HORZSIZE) & " мм"
Label1(3).Caption = "Разрешение по вертикали в миллиметрах: " & GetDeviceCaps(hdc, VERTSIZE) & " мм"
Label1(4).Caption = "Качество цветопередачи: " & CurrBPP & " бит " & sBPPtype
Label1(5).Caption = "Количество цветов: " & 2 ^ CurrBPP
Label1(6).Caption = "Частота обновления экрана: " & CurrVFreq & " Гц " & sFreqtype
'Заполнение списка режимов
EnumDisplay lstmodes
End Sub
Private Sub EnumDisplay(displaylistbox As ListBox)
Dim lTemp As Long, tDevMode As DEVMODE, lIndex As Long
lIndex = 0
Do
lTemp = EnumDisplaySettings(0&, lIndex, tDevMode)
If lTemp = 0 Then Exit Do
With tDevMode
displaylistbox.AddItem .dmPelsWidth & " x " & .dmPelsHeight & " , " & .dmBitsPerPel & " бит"
End With
lIndex = lIndex + 1
Loop
End Sub
Приложение 5 (листинг модуля окна тестирования дисков)
Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim TStart As Long 'переменная таймера только для этой процедуры
Dim TEnd As Long 'переменная таймера только для этой процедуры
Dim Zapis(9) As Single
Dim Chten(9) As Single
Dim AStart As Single
Dim AEnd As Single
Private Sub Command1_Click()
Dim i As Long, j As Byte, Tmp As Single, Str1 As String
If MainForm.NumDrive = 3 Then
AStart = GetTickCount()
For j = 0 To 9
TStart = GetTickCount()
Open Combo1.Text & "\proba.txt" For Output As 1
For i = 0 To 349524
Print #1, " "
Next i
Close 1
TEnd = GetTickCount()
Zapis(j) = 1 / ((TEnd - TStart) / 2000)
Next j
For i = 0 To 9
Tmp = Tmp + Zapis(i)
Next i
Tmp = Tmp / 10
Label1.Caption = "Средняя скорость записи " & FormatNumber(Tmp, 3) & " Мб/сек"
ProgressBar1.Value = Tmp
For j = 0 To 9
TStart = GetTickCount()
Open Combo1.Text & "\proba.txt" For Input As 1
Str1 = Len(Input(LOF(1), 1))
Close 1
TEnd = GetTickCount()
Chten(j) = 1 / ((TEnd - TStart) / 1000)
Next j
For i = 0 To 9
Tmp = Tmp + Chten(i)
Next i
Tmp = Tmp / 10
Label2.Caption = "Средняя скорость чтения " & FormatNumber(Tmp, 3) & " Мб/сек"
ProgressBar2.Value = Tmp
AEnd = GetTickCount()
Label3.Caption = "Общее время теста: " & FormatNumber(((AEnd - AStart) / 1000), 4) & " секунд"
Label4.Caption = "Кол-во тестов: 10 на запись, 10 на чтение"
End If
If MainForm.NumDrive = 2 Then
ProgressBar1.Max = 80
ProgressBar2.Max = 80
AStart = GetTickCount()
TStart = GetTickCount()
Open Combo1.Text & "\proba.txt" For Output As 1
For i = 0 To 349524
Print #1, " "
Next i
Close 1
TEnd = GetTickCount()
Label1.Caption = "Cкорость записи " & FormatNumber(1 / ((TEnd - TStart) / 1000000), 3) & " Kb/sec"
ProgressBar1.Value = 1 / ((TEnd - TStart) / 1000000)
For j = 0 To 3
TStart = GetTickCount()
Open Combo1.Text & "\proba.txt" For Input As 1
Str1 = Len(Input(LOF(1), 1))
Close 1
TEnd = GetTickCount()
Chten(j) = 1 / ((TEnd - TStart) / 10000)
Next j
For i = 0 To 3
Tmp = Tmp + Chten(i)
Next i
Tmp = Tmp / 10
AEnd = GetTickCount()
Label2.Caption = "Средняя скорость чтения " & FormatNumber(Tmp, 3) & " Мб/сек"
Label3.Caption = "Общее время теста: " & FormatNumber(((AEnd - AStart) / 1000), 4) & " секунд"
ProgressBar2.Value = Tmp
Label4.Caption = "Кол-во тестов: 1 на запись, 4 на чтение"
End If
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim i As Byte, drivetype As Long, k As Byte
FillCombo Combo1, True
For i = 0 To Combo1.ListCount - 1
Combo1.ListIndex = i
drivetype = GetDriveType(Combo1.Text + "\")
If drivetype = MainForm.NumDrive Then Combo1.AddItem Combo1.Text: k = k + 1
Next i
For i = 0 To Combo1.ListCount - k - 1
Combo1.RemoveItem 0
Next i
Combo1.ListIndex = 0
Call Command1_Click
End Sub
Private Sub FillCombo(cbo As ComboBox, ByVal bUsed As Boolean)
Dim DriveNum As Long
cbo.Clear
For DriveNum = 0 To 25
If CBool(GetLogicalDrives And (2 ^ DriveNum)) = bUsed Then
cbo.AddItem Chr$(Asc("A") + DriveNum) & ":"
End If
Next DriveNum
End Sub