VBA
Attribute VB_Name = "GetM365Version"
' ============================================================
' Microsoft 365 Apps バージョン取得マクロ
' 対象列:
' B列 - リモートコンピューター名 (FQDN)
' D列 - M365 Apps バージョン番号（取得結果を格納）
'
' 動作仕様:
' - B列にFQDNが存在する行を順に処理
' - WMI (Win32_Registry 経由) でリモートレジストリを参照
' - オフライン（接続不可）の場合はスキップ（D列に何も書かない）
' - ヘッダー行は1行目と想定（2行目から処理開始）
' ============================================================
Option Explicit
' レジストリ定数
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Const REG_PATH As String = "SOFTWARE\Microsoft\Office\ClickToRun\Configuration"
Private Const REG_VALUE As String = "VersionToReport"
' タイムアウト関連（WMI接続確認用 ping）
Private Const PING_TIMEOUT_MS As Long = 1000 ' ping タイムアウト (ms)
Private Const MAX_ROWS As Long = 10000 ' 最大処理行数（無限ループ防止）
' ============================================================
' メインプロシージャ
' ============================================================
Public Sub GetM365AppsVersion()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fqdn As String
Dim version As String
Set ws = ActiveSheet
' データ最終行を取得（B列基準）
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
If lastRow < 2 Then
MsgBox "B列にデータが見つかりません。", vbInformation
Exit Sub
End If
' 処理行数の安全チェック
If lastRow > MAX_ROWS + 1 Then lastRow = MAX_ROWS + 1
' 画面更新を停止して高速化
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.StatusBar = "M365 バージョン取得中..."
Dim processed As Long: processed = 0
Dim skipped As Long: skipped = 0
For i = 2 To lastRow
fqdn = Trim(ws.Cells(i, "B").Value)
' B列が空の行はスキップ
If fqdn = "" Then GoTo NextRow
Application.StatusBar = "処理中: " & fqdn & " (" & i - 1 & "/" & lastRow - 1 & ")"
' オンライン確認（ping）
If Not IsHostOnline(fqdn) Then
' オフラインの場合: D列は変更しない（スキップ）
skipped = skipped + 1
GoTo NextRow
End If
' WMI でリモートレジストリからバージョン取得
version = GetVersionViaWMI(fqdn)
If version <> "" Then
ws.Cells(i, "D").Value = version
processed = processed + 1
End If
' 取得失敗時もD列は変更しない
NextRow:
Next i
' 後処理
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
MsgBox "完了しました。" & vbCrLf & _
" 取得成功: " & processed & " 件" & vbCrLf & _
" スキップ（オフライン等）: " & skipped & " 件", vbInformation, "M365 バージョン取得"
End Sub
' ============================================================
' ホストがオンラインか確認（WMI の Win32_PingStatus を使用）
' 戻り値: True = オンライン / False = オフライン or 到達不可
' ============================================================
Private Function IsHostOnline(ByVal hostName As String) As Boolean
On Error GoTo ErrHandler
Dim objWMI As Object
Dim colPing As Object
Dim objPing As Object
' ローカルのWMIサービスに接続してリモートホストへpingを実行
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Dim wql As String
wql = "SELECT StatusCode FROM Win32_PingStatus " & _
"WHERE Address='" & hostName & "' " & _
"AND Timeout=" & PING_TIMEOUT_MS & " " & _
"AND ResolveAddressNames=False"
Set colPing = objWMI.ExecQuery(wql)
For Each objPing In colPing
If Not IsNull(objPing.StatusCode) Then
If objPing.StatusCode = 0 Then
IsHostOnline = True
Exit Function
End If
End If
Next objPing
IsHostOnline = False
Exit Function
ErrHandler:
IsHostOnline = False
End Function
' ============================================================
' WMI リモートレジストリ経由で M365 Apps バージョンを取得
' 戻り値: バージョン文字列 or "" (取得失敗)
' ============================================================
Private Function GetVersionViaWMI(ByVal hostName As String) As String
On Error GoTo ErrHandler
Dim oReg As Object
Dim sValue As String
' StdRegProv を使用してリモートレジストリに接続
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
hostName & "\root\default:StdRegProv")
' レジストリ文字列値を取得
oReg.GetStringValue HKEY_LOCAL_MACHINE, REG_PATH, REG_VALUE, sValue
If Not IsNull(sValue) Then
GetVersionViaWMI = Trim(sValue)
Else
GetVersionViaWMI = ""
End If
Exit Function
ErrHandler:
GetVersionViaWMI = ""
End Function
.png)
