リモートホストのWindowsUpdateが最新か確認し、かつ最後にUpdateされた日時と実行されたKB番号を取得する

WindowsUpDateは、本来はWSUSで管理すればいいのだが、どうしてもそれができない現場というのがあります。

そういう時に、管理している端末のWindowsUpDateの状況を確認するのに、1台ずつアクセスして確認していては時間がかかるので、
VBAで取得するコードを書きました。

必ずしもすべての端末が起動しているとは限らないので、まずはPingを打って疎通と起動を確認してます。

WakeOnLanができればいいのですが、それはまた次の機会に設定してみようと思います。

'対象ホストにPingを打つFunction

Function GetPingResult(Host)

   Dim objPing As Object
   Dim objStatus As Object
   Dim Result As String

   Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
       ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")

   For Each objStatus In objPing
      Select Case objStatus.StatusCode
         Case 0: strResult = "Connected"
         Case 11001: strResult = "Buffer too small"
         Case 11002: strResult = "Destination net unreachable"
         Case 11003: strResult = "Destination host unreachable"
         Case 11004: strResult = "Destination protocol unreachable"
         Case 11005: strResult = "Destination port unreachable"
         Case 11006: strResult = "No resources"
         Case 11007: strResult = "Bad option"
         Case 11008: strResult = "Hardware error"
         Case 11009: strResult = "Packet too big"
         Case 11010: strResult = "Request timed out"
         Case 11011: strResult = "Bad request"
         Case 11012: strResult = "Bad route"
         Case 11013: strResult = "Time-To-Live (TTL) expired transit"
         Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
         Case 11015: strResult = "Parameter problem"
         Case 11016: strResult = "Source quench"
         Case 11017: strResult = "Option too big"
         Case 11018: strResult = "Bad destination"
         Case 11032: strResult = "Negotiating IPSEC"
         Case 11050: strResult = "General failure"
         Case Else: strResult = "Unknown host"
      End Select
      GetPingResult = strResult
   Next

   Set objPing = Nothing

End Function


'Pingを打って結果を保存

Sub GetIPStatus()

  Dim Cell As Range
  Dim ipRng As Range
  Dim Result As String
  Dim Wks As Worksheet

'シート名はworkとする
'対象ホスト名記載の列は"B3"から

Set Wks = Worksheets("work")

Set ipRng = Wks.Range("B3")
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))

  For Each Cell In ipRng
    Result = GetPingResult(Cell)
    Cell.Offset(0, 1) = Result
    Cell.Offset(0, 2) = Date & " " & Time

  Next Cell


End Sub



==================================================================================================


'Ping結果がConnectedのものだけにWindowsUpdateを確認

Sub WinUpDateResult()
Application.DisplayAlerts = False

On Error Resume Next
Dim TagetHostName As String
Dim TagetHostPingResult As String

'対象ホストのセルの行番号
y = 3

Do While Cells(y, 2).Value <> ""
    TagetHostName = Cells(y, 2).Value
    TagetHostPingResult = Cells(y, 3).Value
    
    If TagetHostPingResult = "Connected" Then
        
    Set objSession = CreateObject("Microsoft.Update.Session", TagetHostName)

     Debug.Print "TagetHostName = " & TagetHostName
     Debug.Print "エラーの番号:" & Err.Number
     Debug.Print "エラーの種類:" & Err.Description

    If Err.Number <> 0 Then Next

    Set objSearcher = objSession.CreateUpdateSearcher


strSeatchCondition = "IsInstalled=0"

Set objSearchResult = objSearcher.Search(strSeatchCondition)

If objSearchResult.Updates.Count = 0 Then
 Cells(y, 6).Value = "未適用の更新ファイルなし"

End If

    Set colHistory = ob
jSearcher.QueryHistory(0, 1)

    For Each objEntry In colHistory
        
        Cells(y, 8).Value = objEntry.Title
        Cells(y, 7).Value = objEntry.Date
        
    Next

       
    Else
    End If
    
y = y + 1
    
Loop


Application.DisplayAlerts = True
      

End Sub