Dùng WScript.Shell Object để lấy thông tin hệ thống

[anhtuan1066]

Ai từng dùng qua DOS chắc không lạ với lệnh SystemInfo
Các bạn bấm nút Start\Run, gõ vào lệnh CMD. Trong cửa sổ Command Prompt, gõ vào lệnh SystemInfo sẽ thấy hàng loạt các thông tin về hệ thống như: Tên máy tính, Hệ điều hành, tốc độ CPU, RAM, địa chỉ IP... vân vân... gần như đầy đủ mọi thứ
Nhiệm vụ của ta là dùng VBA để lấy toàn bộ thông tin này. Xin giới thiệu với các bạn WScript.Shell Object dùng để làm việc này với đoạn code khá đơn giản

Sub Test()
  With CreateObject("WScript.Shell")
    MsgBox .Exec("systeminfo").StdOut.ReadAll
  End With
End Sub

Code này sẽ xuất ra MsgBox toàn bộ thông tin mà lệnh SystemInfo đã làm. Có điều các thông tin này khá dài nên không thể hiện được toàn bộ trong MsgBox. Ta dùng thêm 1 tí kỹ thuật để lọc toàn bộ thông tin này và đưa vào 2 cột của bảng tính

Sub Test()
  Dim iLine, i As Long
  Range("A2:B1000").Clear
  With CreateObject("WScript.Shell")  '<--- Get System Information
    For Each iLine In Split(.Exec("systeminfo").StdOut.ReadAll, vbLf)  '<--- Get System Information
      i = i + 1
      With WorksheetFunction
        Cells(i, 1).Resize(, 2) = Split(.Clean(.Trim(iLine)), ":")  '<--- Add Info into cell
      End With
    Next
  End With
End Sub

Chạy thử code ta thấy quá trình này có xuất hiện cửa sổ Command Prompt nằm đè lên cửa sổ Excel. Ta có thể cải tiến thêm bằng cách dùng hàm API để cửa sổ Excel Alway on top

Private Declare Function SetForegroundWindow Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Sub SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)

Private Sub CommandButton1_Click()
  Dim iLine, i As Long
  With Application
    .ScreenUpdating = False
    SetForegroundWindow (.hWnd)  '<--- TOPMOST
    SetWindowPos .hWnd, -1, 0, 0, 0, 0, &H40 Or &H2 Or &H1  '<--- TOPMOST
    Range("A2:B1000").Clear
    With CreateObject("WScript.Shell")  '<--- Get System Information
      For Each iLine In Split(.Exec("systeminfo").StdOut.ReadAll, vbLf)  '<--- Get System Information
        i = i + 1
        With WorksheetFunction
          Cells(i, 1).Resize(, 2) = Split(.Clean(.Trim(iLine)), ":")  '<--- Add Info into cell
        End With
      Next
    End With
    SetWindowPos .hWnd, -2, 0, 0, 0, 0, &H40 Or &H2 Or &H1  '<--- NOTOPMOST
    .WindowState = xlMinimized
    .WindowState = xlMaximized
    .ScreenUpdating = True
  End With
End Sub

Sau khi chạy code, nếu để ý cửa sổ TaskManager sẽ thấy xuất hiện thêm tiến trình wmiprvse.exe và nó không tự thoát sau khi kết thúc. Vậy ta thêm 1 đoạn code nữa để "tiêu diệt" tiến trình này

Call Shell("taskkill /F /IM wmiprvse.exe", 1)

Toàn bộ code sau khi chỉnh sửa như sau:

Private Declare Function SetForegroundWindow Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Sub SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Sub CommandButton1_Click()
  Dim iLine, i As Long
  With Application
    .ScreenUpdating = False
    SetForegroundWindow (.hWnd)  '<--- TOPMOST
    SetWindowPos .hWnd, -1, 0, 0, 0, 0, &H40 Or &H2 Or &H1  '<--- TOPMOST
    Range("A2:B1000").Clear
    With CreateObject("WScript.Shell")  '<--- Get System Information
      For Each iLine In Split(.Exec("systeminfo").StdOut.ReadAll, vbLf)  '<--- Get System Information
        i = i + 1
        With WorksheetFunction
          Cells(i, 1).Resize(, 2) = Split(.Clean(.Trim(iLine)), ":")  '<--- Add Info to cell
        End With
      Next
    End With
    Call Shell("taskkill /F /IM wmiprvse.exe", 1)  '<--- Kill wmiprvse.exe Process
    SetWindowPos .hWnd, -2, 0, 0, 0, 0, &H40 Or &H2 Or &H1  '<--- NOTOPMOST
    .WindowState = xlMinimized
    .WindowState = xlMaximized
    .ScreenUpdating = True
  End With
End Sub

Xin mời các bạn tham khảo file đính kèm và góp ý!