Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformID As Long
szCSDVersion As String * 128
End Type
Const VER_PLATFORM_WIN32s = 0
Const VER_PLATFORM_WIN32_WINDOWS = 1
Const VER_PLATFORM_WIN32_NT = 2
Dim OSInfo As OSVERSIONINFO
'*** 获取显示器等资源信息
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
'***获取计算机名称
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'***获取磁盘剩余空间
Private 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
'***获取内存状况
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Private Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Dim lpInfoBuffer As MEMORYSTATUS
Dim hdesktopwnd
Dim hdccaps
Public Sub DeviceInfo()
Dim DisplayBits
Dim DisplayPlanes
Dim DisplayWidth
Dim DisplayHeight
Dim RetVal
'获取窗口的设备场景
hdccaps = GetDC(hdesktopwnd)
'像素
DisplayBits = GetDeviceCaps(hdccaps, 12)
'
DisplayPlanes = GetDeviceCaps(hdccaps, 14)
'以像素为单位的显示宽度
DisplayWidth = GetDeviceCaps(hdccaps, 8)
'以像素为单位的显示高度
DisplayHeight = GetDeviceCaps(hdccaps, 10)
'释放由调用GetDC函数获取的指定设备场景
RetVal = ReleaseDC(hdesktopwnd, hdccaps)
'确定颜色数
If DisplayBits = 1 Then
If DisplayPlanes = 1 Then
'黑白模式
lblRes = "1 位/2 黑白模式"
ElseIf DisplayPlanes = 4 Then
'16色模式
lblRes = "4 位/16 色"
End If
ElseIf DisplayBits = 8 Then
'256色模式
lblRes = "8 位/256 色"
ElseIf DisplayBits = 16 Then
'真彩色16位模式
lblRes = "真彩色16位/65,000 色"
ElseIf DisplayBits = 32 Then
'真彩色32位模式
lblRes = "真彩色32位/16,000,000 色"
Else
'未知模式
lblRes = "未知模式"
End If
End Sub
Function sGetComputerName() As String
Dim sBuffer As String
Dim lBufSize As Long
Dim lStatus As Long
lBufSize = 255
sBuffer = String$(lBufSize, " ")
lStatus = GetComputerName(sBuffer, lBufSize)
sGetComputerName = ""
If lStatus <> 0 Then
sGetComputerName = Left(sBuffer, lBufSize)
End If
Form1.lblName = sGetComputerName
End Function
Public Function DiskSpace(DrivePath As String) As Double
' 通过驱动器符号获取它的剩余空间
Dim Drive As String
Dim SectorsPerCluster As Long, BytesPerSector As Long
Dim NumberOfFreeClusters As Long, TotalClusters As Long, Sts As Long
Dim DS
Drive = Left(Trim(DrivePath), 1) & ":\" '确认位于根目录
Sts = GetDiskFreeSpace(Drive, SectorsPerCluster, BytesPerSector, NumberOfFreeClusters, TotalClusters)
If Sts <> 0 Then
DiskSpace = SectorsPerCluster * BytesPerSector * NumberOfFreeClusters
DS = Format$(DiskSpace, "###,###")
lblSpace = DS & " bytes"
Else
DiskSpace = -1 '出错将调用GetLastError
End If
End Function
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Load()
'计算机名称
Dim a
a = sGetComputerName
Dim OSName As String
'操作系统版本
Dim RetVal As Long
RetVal = GetVersionEx(OSInfo)
OSInfo.dwOSVersionInfoSize = 148
OSInfo.szCSDVersion = Space(128)
RetVal = GetVersionEx(OSInfo)
Select Case OSInfo.dwPlatformID
Case VER_PLATFORM_WIN32s
OSName = "Windows 3.1"
Case VER_PLATFORM_WIN32_WINDOWS
OSName = "Windows 98"
Case VER_PLATFORM_WIN32_NT
OSName = "Windows NT"
End Select
lblVersion.Caption = OSName & "(" & OSInfo.dwMajorVersion & "." & OSInfo.dwMinorVersion & ")"
Dim X As Variant
X = DiskSpace("c")
Call DeviceInfo
End Sub
Private Sub Timer1_Timer()
'系统时间
lblTime.Caption = Time
'内存
lpInfoBuffer.dwLength = Len(lpInfoBuffer)
GlobalMemoryStatus lpInfoBuffer
lblUsedMem.Caption = lpInfoBuffer.dwMemoryLoad & " % used"
lblTotalPhys.Caption = lpInfoBuffer.dwTotalPhys / 1024 & " KByte"
lblAvailPhys.Caption = lpInfoBuffer.dwAvailPhys / 1024 & " KByte"
lblTotalPageFile.Caption = lpInfoBuffer.dwTotalPageFile / 1024 & " KByte"
lblAvailPageFile.Caption = lpInfoBuffer.dwAvailPageFile / 1024 & " KByte"
lblTotalVirt = lpInfoBuffer.dwTotalVirtual / 1024 & " KByte"
lblAvailVirt = lpInfoBuffer.dwAvailVirtual / 1024 & " KByte"
'日期
Dim day As String
Dim n As Integer
n = Weekday(Date)
If n = 1 Then day = "Sunday"
If n = 2 Then day = "Monday"
If n = 3 Then day = "Tuesday"
If n = 4 Then day = "Wednesday"
If n = 5 Then day = "Thursday"
If n = 6 Then day = "Friday"
If n = 7 Then day = "Saturday"
lblDate.Caption = day & ", " & Date
End Sub
