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
没有相关教程
|