fox-info1.frm

VB获取硬件信息

Dim TMP
Dim pdhStatus As PDH_STATUS
Dim hQuery As Long
Dim Counters(0 To 99) As CounterInfo
Dim currentCounterIdx As Long
Dim iPerformanceDetail As PERF_DETAIL
Dim BARVALUE As Integer
Dim PCName As String
Dim Ppp As Long
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
Dim PROCESSORSINFO
Dim a1
Private Const LVM_FIRST As Long = &H1000
Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
Private Const LVSCW_AUTOSIZE As Long = -1
Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2

Private Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
  (ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long
'回收站
Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Const SHERB_NOCONFIRMATION = &H1
Const SHERB_NOPROGRESSUI = &H2
Const SHERB_NOSOUND = &H4
'--
Dim ListTotal As Integer, i, j, k, L
Dim intCnt As Integer
'---屏幕分辨率------
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Const ENUM_CURRENT_SETTINGS = &HFFFF - 1
Private Type DEVMODE
    dmDeviceName      As String * 32
    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 * 32
    dmUnusedPadding   As Integer
    dmBitsPerPel      As Integer
    dmPelsWidth       As Long
    dmPelsHeight      As Long
    dmDisplayFlags    As Long
    dmDisplayFrequency As Long
End Type

Private Sub Command2_Click()
    On Error Resume Next
    Dim EmptyNowInOrder
    EmptyNowInOrder = SHEmptyRecycleBin(Form2.hwnd, "", SHERB_NOPROGRESSUI)
ERRORA:
End Sub

Private Sub Command3_Click()
   ListView1.ListItems.Clear
   Call wmiBiosInfo
   Call lvAutosizeControl(ListView1)
End Sub

Private Sub mnuAbout_Click()
    MsgBox "狐狸硬件信息 v 1.0" & Chr(13) & "枕善居汉化制作" & Chr(13) & "http://www.mndsoft.com" & Chr(13) & "E-mail:[e-mail]", vbInformation, "狐狸硬件信息 v 1.0"
End Sub

Private Sub mnuAlwaysOnTop_Click()
    If mnuAlwaysOnTop.Checked = True Then
        mnuAlwaysOnTop.Checked = False
        TMP = SetTopMostWindow(Form2.hwnd, False)
    Else
        mnuAlwaysOnTop.Checked = True
        TMP = SetTopMostWindow(Form2.hwnd, True)
    End If
End Sub

Private Sub Command1_Click()
    processeslisting
End Sub

Private Sub TOPmostPOSITIONonSCREEN_Click()
    TMP = SetTopMostWindow(Form2.hwnd, True)
End Sub

Private Sub Form_Load()
    Dim cpubarcolor
    Set WS = DBEngine.Workspaces(0)
    DbFile = (App.Path & "\Data\Options.mdb")
    PwdString = "swordfishofvolen"
    Set db = DBEngine.OpenDatabase(DbFile, False, False, ";PWD=" & PwdString)
    Set rs = db.OpenRecordset("tblOptions", dbOpenTable)
    cpubarcolor = rs("CPUcolor")
    CPUBAR.FillColor = cpubarcolor
    Timer1.Interval = rs("CPUupdatespeed")
    TOPmostPOSITIONonSCREEN_Click
    pdhStatus = PdhOpenQuery(0, 1, hQuery)
    If pdhStatus <> ERROR_SUCCESS Then
       MsgBox "Open Query failed"
       Resume Next
    End If
    
    AddCounter "\Processor(0)\% Processor Time", hQuery
    
    UpdateValues
    
    TAB1INFOS
End Sub

Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        PopupMenu mnuFile
    End If
End Sub

Private Sub mnuExit_Click()
    End
End Sub

Private Sub mnuMinimizeFoxInfo_Click()
    Me.WindowState = vbMinimized
End Sub

Private Sub mnuOptions2_Click()
    frmOptions.Show
End Sub

Private Sub SSTab1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If SSTab1.Tab = 1 And Button = 2 Then
        PopupMenu mnuFile
    End If
End Sub

Private Sub mnuFile_Click()
    If processorlbl.Caption = vbNullString Then
        mnuLog2.Enabled = False
    Else
        mnuLog2.Enabled = True
    End If
End Sub

Sub TAB1INFOS()
    On Error Resume Next
    Set Information = New GetInfomation
    Dim lngTickCount As Long
    Dim UpTimeWin As String
    lngTickCount = GetTickCount
    UpTimeWin = CStr(Round((lngTickCount / 1000 / 60))) & " 分钟"
    Ppp = NameOfTheComputer(PCName)
    List1.AddItem "Windows已运行时间         = " & UpTimeWin
    List1.AddItem "计算机名称                = " & PCName
    List1.AddItem "当前用户                  = " & Information.GetUSERNAME
    List1.AddItem "国家                      = " & IIf(Information.GetCountry = "People's Republic of China", "中华人民共和国", Information.GetCountry)
    List1.AddItem "语言                      = " & IIf(Information.GetLanguage = "Chinese", "中文", Information.GetLanguage)
    List1.AddItem "系统安装                  = " & Information.GetSystemDrive
    List1.AddItem "Windowns 安装路径         = " & Information.GetWinDir
    List1.AddItem "Windows 临时文件夹        = " & Information.TempDir
    List1.AddItem "Win\System 路径           = " & Information.SystemDir
    List1.AddItem "----------------"
    List1.AddItem "货币                      = " & Information.GetCurrencySymbol
    List1.AddItem "日期分隔符                = " & Information.GetDateSeparator
    List1.AddItem "小数点                    = " & Information.GetDecimalSeparator
    List1.AddItem "数字组                    = " & Information.GetDigitGrouping
    List1.AddItem "小数前导                  = " & Information.GetLeadingZerosForDecimal
    List1.AddItem "长日期格式                = " & Information.GetLongDateFormat
    List1.AddItem "长日期 1              = " & Information.GetLongMonthName1
    List1.AddItem "长日期 2              = " & Information.GetLongMonthName2
    List1.AddItem "长日期 3              = " & Information.GetLongMonthName3
    List1.AddItem "长日期 4              = " & Information.GetLongMonthName4
    List1.AddItem "长日期 5              = " & Information.GetLongMonthName5
    List1.AddItem "长日期 6              = " & Information.GetLongMonthName6
    List1.AddItem "长日期 7              = " & Information.GetLongMonthName7
    List1.AddItem "长日期 8              = " & Information.GetLongMonthName8
    List1.AddItem "长日期 9              = " & Information.GetLongMonthName9
    List1.AddItem "长日期 10             = " & Information.GetLongMonthName10
    List1.AddItem "长日期 11             = " & Information.GetLongMonthName11
    List1.AddItem "长日期 12             = " & Information.GetLongMonthName12
    List1.AddItem "长星期 1              = " & Information.GetLongNameDay1
    List1.AddItem "长星期 2              = " & Information.GetLongNameDay2
    List1.AddItem "长星期 3              = " & Information.GetLongNameDay3
    List1.AddItem "长星期 4              = " & Information.GetLongNameDay4
    List1.AddItem "长星期 5              = " & Information.GetLongNameDay5
    List1.AddItem "长星期 6              = " & Information.GetLongNameDay6
    List1.AddItem "长星期 7              = " & Information.GetLongNameDay7
    List1.AddItem "负号                  = " & Information.GetNegativeSign
    List1.AddItem "负号位置              = " & Information.GetNegativeSignPosition
    List1.AddItem "Number Fractional Digits  = " & Information.GetNumberOfFractionalDigits
    List1.AddItem "正号                  = " & Information.GetPositiveSign
    List1.AddItem "正号位置              = " & Information.GetPositiveSignPosition
    List1.AddItem "短日期格式            = " & Information.GetShortDateFormat
    List1.AddItem "短日期 1              = " & Information.GetShortMonthName1
    List1.AddItem "短日期 2              = " & Information.GetShortMonthName2
    List1.AddItem "短日期 3              = " & Information.GetShortMonthName3
    List1.AddItem "短日期 4              = " & Information.GetShortMonthName4
    List1.AddItem "短日期 5              = " & Information.GetShortMonthName5
    List1.AddItem "短日期 6              = " & Information.GetShortMonthName6
    List1.AddItem "短日期 7              = " & Information.GetShortMonthName7
    List1.AddItem "短日期 8              = " & Information.GetShortMonthName8
    List1.AddItem "短日期 9              = " & Information.GetShortMonthName9
    List1.AddItem "短日期 10             = " & Information.GetShortMonthName10
    List1.AddItem "短日期 11             = " & Information.GetShortMonthName11
    List1.AddItem "短日期 12             = " & Information.GetShortMonthName12
    List1.AddItem "短星期 1              = " & Information.GetShortNameDay1
    List1.AddItem "短星期 2              = " & Information.GetShortNameDay2
    List1.AddItem "短星期 3              = " & Information.GetShortNameDay3
    List1.AddItem "短星期 4              = " & Information.GetShortNameDay4
    List1.AddItem "短星期 5              = " & Information.GetShortNameDay5
    List1.AddItem "短星期 6              = " & Information.GetShortNameDay6
    List1.AddItem "短星期 7              = " & Information.GetShortNameDay7
    List1.AddItem "千位分隔符            = " & Information.GetThousandSeparator
    List1.AddItem "时间格式              = " & Information.GetTimeFormat
    List1.AddItem "时间分割符            = " & Information.GetTimeSeparator
    Timer1.Enabled = True '物理内存更新定时器
End Sub

Public Sub AddCounter(strCounterName As String, hQuery As Long)
    Dim pdhStatus As PDH_STATUS
    Dim hCounter As Long
    
    pdhStatus = PdhVbAddCounter(hQuery, strCounterName, hCounter)
    Counters(currentCounterIdx).hCounter = hCounter
    Counters(currentCounterIdx).strName = strCounterName
    currentCounterIdx = currentCounterIdx + 1
End Sub

Private Sub UpdateValues()
    Dim dblCounterValue As Double
    Dim pdhStatus As Long
    Dim strInfo As String
    Dim i As Long
        
    PdhCollectQueryData (hQuery)
    
    i = 0

    dblCounterValue = _
            PdhVbGetDoubleCounterValue(Counters(i).hCounter, pdhStatus)
        
        '错误检查
        If (pdhStatus = PDH_CSTATUS_VALID_DATA) _
        Or (pdhStatus = PDH_CSTATUS_NEW_DATA) Then
        PB1.Value = dblCounterValue
        End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Timer1.Enabled = False
    PdhCloseQuery (hQuery)
End Sub

Private Sub mnuLog1_Click()
    Dim PlaceToSave As String
    
    LogSave.DialogTitle = "生成日志文件..."
    LogSave.Filter = "文本文件 (*.txt)|*.txt|"
    LogSave.ShowSave
    PlaceToSave = LogSave.FileName
    
    Open PlaceToSave For Output As #1
    List1.ListIndex = 0
          
    On Error Resume Next
    
    For i = 0 To List1.ListCount
       Print #1, List1
       List1.ListIndex = List1.ListIndex + 1
    Next i
    Close #1
End Sub

Private Sub mnuLog2_Click()
    Dim Prr
    Dim Lrr
    Dim Crr
    Dim Drr
    Dim Krr
    Dim Orr
    Dim Hrr
    Dim Nrr
    Dim JJJ
    Dim KKLL
    Dim KKKJJJ
    Dim HOHO
    Dim WOW
    Dim BBBj
    Dim PlaceToSave As String
    Prr = Label3.Caption & " " & processorlbl.Caption
    Lrr = Label9.Caption & " " & numberofprocessorslbl.Caption
    Crr = Label10.Caption & " " & systemdrivelbl.Caption
    Drr = Label4.Caption & " " & wanIPADDRESSlbl.Caption
    Krr = Label8.Caption & " " & ScreenResolutionLBL.Caption
    Orr = Label5.Caption & " " & WinOSlbl.Caption
    Hrr = Label6.Caption & " " & ramlbl.Caption
    Nrr = Label7.Caption & " " & ramfreelbl.Caption
    JJJ = Label11.Caption & " " & runningprogramslbl.Caption
    KKLL = Label12.Caption & " " & printerlbl.Caption
    KKKJJJ = Label15.Caption & " " & DXVERSIONlbl.Caption
    HOHO = Label13.Caption & " " & totalpagingfilelbl.Caption
    WOW = Label14.Caption & " " & freepagingfilelbl.Caption
    BBBj = Label16.Caption & " " & networkipaddresslBl.Caption
    Text1.Text = Prr & vbNewLine & Lrr & vbNewLine & Crr & vbNewLine & Drr & vbNewLine & BBBj & vbNewLine & Krr & vbNewLine & Orr & vbNewLine & Hrr & vbNewLine & Nrr & vbNewLine & JJJ & vbNewLine & KKLL & vbNewLine & KKKJJJ & vbNewLine & HOHO & vbNewLine & WOW
    
    LogSave.DialogTitle = "生成日志文件..."
    LogSave.Filter = "文本文件 (*.txt)|*.txt|"
    LogSave.ShowSave
    PlaceToSave = LogSave.FileName
        
    On Error GoTo ERRORA
    
    Open PlaceToSave For Output As #1
    Print #1, Text1.Text
    Close #1
ERRORA:
    Exit Sub
End Sub

Private Sub RAMtimer_Timer()
    Call GlobalMemoryStatus(memInfo)
    ramlbl.Caption = memInfo.dwTotalPhys / 1024 & " KB"
    ramfreelbl.Caption = memInfo.dwAvailPhys / 1024 & " KB"
End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
    On Error Resume Next
    Select Case SSTab1.Tab
    Case 0
        List1.Clear
        TAB1INFOS
        RAMtimer.Enabled = False
    Case 1
        On Error Resume Next
        networkipaddresslBl.Caption = GetIPAddress()
        Dim MS As MEMORYSTATUS
        MS.dwLength = Len(MS)