Skip to content

Instantly share code, notes, and snippets.

@furyutei

furyutei/0.README.md

Last active August 28, 2024 10:52
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save furyutei/2f1998c19bae3de6cb6e7d0ab4217bf4 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save furyutei/2f1998c19bae3de6cb6e7d0ab4217bf4 to your computer and use it in GitHub Desktop.
Download ZIP
[Excel][VBA] エクセルのバージョン取得を試みる(2016以降も対応)
Raw
0.README.md

[Excel][VBA] エクセルのバージョン取得を試みる(2016以降も対応)

元ネタ

ソースコード

基本的に、簡易的な判定で構わなければ1を、やや厳密な判定（LICENSE NAMEの取得）やWord[^1]にも対応したければ3を使います（2はプロトタイプです）。
[^1] 頭の方にあるTARGET_APP_NAMEを"Excel"から"Word"に変更して使います。

  1. Mod_ExcelVersion1.vba: 2016以降を関数の有無で判別
    ※速いが、場合によっては2016～2021であっても365の関数が使えたりする場合があるため、やや不安定
  2. Mod_ExcelVersion2.vba: 2016以降をOSPP.VBSを用いて判別
    ※遅い・OSPP.VBS実行時のプロンプトが表示されてしまう
  3. Mod_ExcelVersion3.vba: 2016以降をOSPP.VBSと同様の処理(WMI)を用いて判別
    ※やや遅いがプロンプトは表示されない

2については、いわゆるプリインストール版（Microsorft Store版・UWPアプリ）のOfficeではOSPP.VBSが見つからないため、動作しません。
これは3でも同様ですが、WMIを使う手法がエラーになった場合は1の手法に切り替えることで対応しています。

参考

Raw
Mod_ExcelVersion1.vba
Option Explicit
Function GetExcelVersion() As String
Select Case Application.Version
Case "16.0"
If IsError([CONCAT(1)]) Then
GetExcelVersion = "2016"
ElseIf IsError([SEQUENCE(1)]) Then
GetExcelVersion = "2019"
ElseIf IsError([LAMBDA(1)()]) Then
GetExcelVersion = "2021"
Else
GetExcelVersion = "365"
End If
Case "15.0"
GetExcelVersion = "2013"
Case "14.0"
GetExcelVersion = "2010"
Case "12.0"
GetExcelVersion = "2007"
Case "11.0"
GetExcelVersion = "2003"
Case "10.0"
GetExcelVersion = "2002"
Case "9.0"
GetExcelVersion = "2000"
Case "8.0"
GetExcelVersion = "97"
Case "7.0"
GetExcelVersion = "95"
Case Else
GetExcelVersion = Application.Version
End Select
End Function
Raw
Mod_ExcelVersion2.vba
Option Explicit
Function GetExcelVersion() As String
Dim ExcelVersion As String
Select Case Application.Version
Case "16.0"
ExcelVersion = GetOffice16Version()
Case "15.0"
ExcelVersion = "2013"
Case "14.0"
ExcelVersion = "2010"
Case "12.0"
ExcelVersion = "2007"
Case "11.0"
ExcelVersion = "2003"
Case "10.0"
ExcelVersion = "2002"
Case "9.0"
ExcelVersion = "2000"
Case "8.0"
ExcelVersion = "97"
Case "7.0"
ExcelVersion = "95"
End Select
GetExcelVersion = IIf(ExcelVersion = "", Application.Version, ExcelVersion)
End Function
Function GetOffice16Version() As String
Static Office16Version As String
If Office16Version <> "" Then
GetOffice16Version = Office16Version
Exit Function
End If
Dim OsppPath: OsppPath = Application.Path & "\..\..\Office16\OSPP.VBS" ' 参考: https://x.com/Officeive/status/1493556270996983810
Dim Reg As Object: Set Reg = CreateObject("VBScript.RegExp")
With Reg
.Global = True: .IgnoreCase = True
.Pattern = "^LICENSE NAME:.*?(\d{3,4}).*$"
'■LICENSE NAME 例
' Office 16, Office16O365BusinessR_Grace edition (←Microsoft 365 Business)
' Office 16, Office16O365HomePremR_Grace edition (←Microsoft 365 Personal(旧Sole))
' Office 19, Office19HomeBusiness2019R_OEM_Perp edition (←Office Home and Business 2019)
' Office 14, OfficeHomeBusiness-Retail3 edition (←Office Home and Business 2010）※本Functionの対象外
End With
Dim WorkLine
Dim MatchParts As Object
With CreateObject("WScript.Shell").Exec("cscript /Nologo """ & OsppPath & """ /dstatus").StdOut
Do Until .AtEndOfStream
WorkLine = .ReadLine
Set MatchParts = Reg.Execute(WorkLine)
If 0 < MatchParts.Count Then
Office16Version = MatchParts(0).SubMatches(0)
GetOffice16Version = Office16Version
'[TODO] LICENSE NAMEが複数存在するケースあり (例: https://x.com/KotorinChunChun/status/1493585372009226243）
' → とりあえず最初に見つかったものを優先
Exit Function
End If
Loop
End With
End Function
Raw
Mod_ExcelVersion3.vba
Option Explicit
#Const TARGET_APP_NAME = "Excel" ' "Excel" / "Word"
#If TARGET_APP_NAME = "Excel" Then
Function GetExcelVersion() As String
Application.Volatile
Dim ExcelVersion As String
On Error Resume Next
ExcelVersion = GetOfficeVersion()
If Err.Number <> 0 Then
'[備忘] 一部の環境[^1]ではGetOfficeVersion()（から内部的に呼び出されるGetOfficeAppId()等）がエラーになるため、その場合は関数有無で判別
' [^1] プリインストール版（Microsorft Store版・UWPアプリ）のOffice等）ではOSPP.VBSが見つからない
If IsError([CONCAT(1)]) Then
ExcelVersion = "2016"
ElseIf IsError([SEQUENCE(1)]) Then
ExcelVersion = "2019"
ElseIf IsError([LAMBDA(1)()]) Then
ExcelVersion = "2021"
Else
ExcelVersion = "365"
End If
End If
GetExcelVersion = IIf(ExcelVersion = "", Application.Version, ExcelVersion)
End Function
#End If
Function GetOfficeVersion() As String
Static OfficeVersion As String
If OfficeVersion <> "" Then
GetOfficeVersion = OfficeVersion
Exit Function
End If
If CLng(Application.Version) < 16 Then
Select Case Application.Version
Case "15.0"
OfficeVersion = "2013"
Case "14.0"
OfficeVersion = "2010"
Case "12.0"
OfficeVersion = "2007"
Case "11.0"
OfficeVersion = "2003"
Case "10.0"
OfficeVersion = "2002"
Case "9.0"
OfficeVersion = "2000"
Case "8.0"
OfficeVersion = "97"
Case "7.0"
OfficeVersion = "95"
End Select
GetOfficeVersion = OfficeVersion
Exit Function
End If
With CreateObject("VBScript.RegExp")
.Global = True: .IgnoreCase = True
.Pattern = "^.*?(\d{3,4}).*$" ' [TODO] 簡易的に3桁もしくは4桁の数字を取り出しているが、本来はもう少し厳密にパターンを考えるべき
Dim OfficeAppName: OfficeAppName = GetOfficeAppName()
'■OfficeAppName(LICENSE NAME) 例
' Office 16, Office16O365BusinessR_Grace edition (←Microsoft 365 Business)
' Office 16, Office16O365HomePremR_Grace edition (←Microsoft 365 Personal(旧Sole))
' Office 19, Office19HomeBusiness2019R_OEM_Perp edition (←Office Home and Business 2019)
' Office 14, OfficeHomeBusiness-Retail3 edition (←Office Home and Business 2010）※本Functionの対象外
Dim MatchParts As Object: Set MatchParts = .Execute(OfficeAppName)
If 0 < MatchParts.Count Then
OfficeVersion = MatchParts(0).SubMatches(0)
GetOfficeVersion = OfficeVersion
End If
End With
End Function
Function GetOfficeAppName(Optional ByVal AppVer As Long = 0) As String
'[備忘]
' [ospp.vbs script](https://learn.microsoft.com/en-us/office/volume-license-activation/tools-to-manage-volume-activation-of-office)
' と同等の処理を実施してLICENSE NAMEを取得
If AppVer = 0 Then AppVer = CLng(Application.Version)
Dim OfficeAppId: OfficeAppId = GetOfficeAppId(AppVer)
If OfficeAppId = "" Then
Exit Function
End If
Dim OSVer
#If TARGET_APP_NAME = "Word" Then
OSVer = System.OperatingSystem & " " & System.Version
#Else
OSVer = Application.OperatingSystem
#End If
Dim Win7 As Boolean: Win7 = OSVer Like "Windows*NT 6.01"
Dim objWMI As Object: Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2") ' [備忘] 対象はローカルマシン固定
Dim strSelect: strSelect = "ApplicationId, ProductKeyID, Name"
Dim strWhere: strWhere = "ApplicationId = '" & OfficeAppId & "' "
Dim productClass: productClass = IIf(Win7 Or AppVer < 16, "OfficeSoftwareProtectionProduct", "SoftwareLicensingProduct")
Dim productinstances As Object: Set productinstances = objWMI.ExecQuery("SELECT " & strSelect & " FROM " & productClass & IIf(AppVer < 16, "", " WHERE " & strWhere))
Dim instance As Object
For Each instance In productinstances
If (LCase(instance.ApplicationId) = OfficeAppId) Then
If instance.ProductKeyID <> "" Then
GetOfficeAppName = instance.Name
'[TODO] ProductKeyIdがNull以外のものが複数存在するケースあり (例: https://x.com/KotorinChunChun/status/1493585372009226243）
' → とりあえず最初に見つかったものを優先
Exit For
End If
End If
Next
End Function
Function GetOfficeAppId(Optional ByVal AppVer As Long = 0) As String
Const DEFAULT_OFFICE_APP_ID As String = "0ff1ce15-a989-479d-af46-f275c6370663" ' [備忘] 2013以降は共通らしい？
Const adReadLine As Long = -2
If AppVer = 0 Then AppVer = CLng(Application.Version)
On Error GoTo SET_DEFAULT
Dim OsppPath: OsppPath = Application.Path & IIf(LCase(Application.Path) Like "*\root\office*", "\..\..\", "\..\") & "Office" & CStr(AppVer) & "\OSPP.VBS"
' OfficeAppIdは
' [ospp.vbs script](https://learn.microsoft.com/en-us/office/volume-license-activation/tools-to-manage-volume-activation-of-office)
' 上に直書きされているため、これを取得
' [TODO] OSPP.VBSへのPathの求め方がこれでよいか確証がない
With CreateObject("ADODB.Stream")
.Charset = "utf-8"
.Open
.LoadFromFile OsppPath
Dim Reg As Object: Set Reg = CreateObject("VBScript.RegExp")
With Reg
.Global = True: .IgnoreCase = True
.Pattern = "^\s*CONST\s*OfficeAppId\s*=\s*""([^""]+)"""
End With
Dim WorkLine
Dim MatchParts As Object
Do Until .Eos
WorkLine = .ReadText(adReadLine)
Set MatchParts = Reg.Execute(WorkLine)
If 0 < MatchParts.Count Then
GetOfficeAppId = MatchParts(0).SubMatches(0)
End If
Loop
.Close
End With
Exit Function
SET_DEFAULT:
If 14 < AppVer Then
GetOfficeAppId = DEFAULT_OFFICE_APP_ID
End If
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment