Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If
Private i As Long
Sub test()
MsgBox GetExcelActivationStatus
End Sub
Function GetExcelActivationStatus() As String
Dim FileNum As Integer
Dim sBatFile As String
Dim sBatFileOutPut As String
Dim sCommand As String
Dim DataLine As String
Dim sStatus As String
Dim WshShell As Object
sBatFile = ThisWorkbook.Path & "\temp.bat"
sBatFileOutPut = ThisWorkbook.Path & "\temp.txt"
With Application
'' sCommand = "CD ""%SystemDrive%\" & Right(.Path, Len(.Path) - InStr(.Path, "\")) ' %SystemDrive% is not correct ;)
'
sCommand = "CD " & Environ("SystemDrive") & "\" & Right(.Path, Len(.Path) - InStr(.Path, "\"))
'
'--------
'
If sCommand = "CD C:\Program Files (x86)\Microsoft Office\root\Office16" Then ' Office 2016/2019 32/64 bit 32/64 bit office/windows check ie. 32 to 32 or 64 to 64
sCommand = "CD C:\Program Files (x86)\Microsoft Office\Office16"
End If
If sCommand = "CD C:\Program Files\Microsoft Office\root\Office16" Then ' Office 2016/2019 32/64 bit check ... Guessing at this one, can't test it
sCommand = "CD C:\Program Files\Microsoft Office\Office16"
End If
'
'--------
'
End With
'It may take a little while to execute the batch file.
'so you may want to update the user of the ongoing processing.
'This is optional, so you can comment out the following line if feedback is not wanted.
SetTimer Application.hwnd, 0, 1000, AddressOf ProcessingFeedBack
FileNum = FreeFile() ' 1
Open sBatFile For Output As #FileNum
Print #FileNum, "@echo on"
Print #FileNum, sCommand
Print #FileNum, "cscript ospp.vbs /dstatus> " & sBatFileOutPut
Close #FileNum
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run sBatFile, 0, True
FileNum = FreeFile()
Open sBatFileOutPut For Input As #FileNum
While Not EOF(FileNum)
Line Input #FileNum, DataLine
If InStr(1, DataLine, "LICENSE STATUS:", vbTextCompare) Then
sStatus = Replace(DataLine, "LICENSE STATUS:", "")
sStatus = Trim(Replace(sStatus, "-", ""))
End If
Wend
Close #FileNum
KillTimer Application.hwnd, 0
i = 0
Application.StatusBar = False
Set WshShell = Nothing
Kill sBatFile
Kill sBatFileOutPut
GetExcelActivationStatus = sStatus
End Function
Sub ProcessingFeedBack()
On Error Resume Next
Application.StatusBar = "Processing" & String((i Mod 3) + 1, ".")
i = i + 1
End Sub
