How to read Office Product ID in VBA

D

dmoney

not sure about office, but the following gets the excel data - i'm sure you
can adjust the path and get what you need.

Const MAX_STRING As Long = 128
Public Const REG_BINARY = 3&
Public Const REG_DWORD = 4&

Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" _
(ByVal hkey As Long, _
ByVal sKey As String, _
ByRef plKeyReturn As Long) As Long

Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" _
(ByVal hkey As Long, _
ByVal sValueName As String, _
ByVal dwReserved As Long, _
ByRef lValueType As Long, _
ByVal sValue As String, _
ByRef lResultLen As Long) As Long

Declare Function RegCloseKey Lib "ADVAPI32.DLL" _
(ByVal hkey As Long) As Long

Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
'

Sub ShowExcelProductID()
MsgBox GetRegistryValue(HKEY_LOCAL_MACHINE, _
"Software\Microsoft\Microsoft Excel 97\97.2.0.0717(1033)\Registration",
"ProductID")
End Sub

Function GetRegistryValue(KEY As Long, SubKey As String, _
ValueName As String) As String
'Pass:
' (1) the KEY (e.g., HKEY_CLASSES_ROOT),
' (2) the SUBKEY (e.g., "Excel. Sheet.5"),
' (3) the value's name (e.g., "" [for default] Or "whatever")


Dim Buffer As String * MAX_STRING, ReturnCode As Long
Dim KeyHdlAddr As Long, ValueType As Long, ValueLen As Long
Dim TempBuffer As String, Counter As Integer
ValueLen = MAX_STRING
ReturnCode = RegOpenKeyA(KEY, SubKey, KeyHdlAddr)
If ReturnCode = 0 Then
ReturnCode = RegQueryValueExA(KeyHdlAddr, ValueName, _
0&, ValueType, Buffer, ValueLen)
RegCloseKey KeyHdlAddr
'If successful ValueType contains data type
' of value And ValueLen its length
If ReturnCode = 0 Then
Select Case ValueType
Case REG_BINARY
For Counter = 1 To ValueLen
TempBuffer = TempBuffer & _
Stretch(Hex(Asc(Mid(Buffer, Counter, 1)))) & " "
Next
GetRegistryValue = TempBuffer
Case REG_DWORD
TempBuffer = "0x"
For Counter = 4 To 1 Step -1
TempBuffer = TempBuffer & _
Stretch(Hex(Asc(Mid(Buffer, Counter, 1))))
Next
GetRegistryValue = TempBuffer
Case Else
GetRegistryValue = Buffer
End Select
Exit Function
End If
End If
GetRegistryValue = "Error"
End Function

Function Stretch(ByteStr As String) As String
If Len(ByteStr) = 1 Then ByteStr = "0" & ByteStr
Stretch = ByteStr
End Function
 
Top