VBA: Detect whether Office 365 subscription or purchased Office version

[bishop3000]

Using VBA, is it possible to determine whether someone is accessing Excel through an Office 365 subscription or through a purchased Office version (e.g. Office 2013)? Thanks!

[Aflatoon]

Why? A 365 subscription gives you the current office version on your desktop (i.e. 2013 at the moment).

[bishop3000]

For one thing, Microsoft is making Office 2016 available to Office 365 subscribers first. So this will help us prioritize Excel 2016 compatibility. This will also help us gauge how quickly our user base will move to Excel 2016 (people are more likely to upgrade if it's free).

Is there any way to detect using VBA?

[Aflatoon]

I'm not aware of anything in the object model (I don't think there's any way of telling from the build numbers either) but you can probably test the registry for the HKLM\Software\Microsoft\Office\ClickToRun hive.

[Kenneth Hobs]

This will tell you the version. It does not answer your question though.

MsgBox Application.Version

[bishop3000]

Thanks Aflatoon. I'll try your registry suggestion, and will let you know how it goes. I'm an amateur on navigating and reading the registry, so anything more on that would be greatly appreciated.

[Kenneth Hobs]

I tried 3 different registry methods but no success. Here is one:

' Bill Ehrreich, http://bytes.com/groups/ms-access/206820-open-excel-access
Sub DoesClickToRunExist()
  MsgBox GetString(&H80000002, "Software\Microsoft\Office\" & Application.Version & "\ClickToRun", "InstallPath")
End Sub

[bishop3000]

Kenneth, thanks so much for the attempt.

[Kenneth Hobs]

I suspect that the other problems had to do with privileges even though I am the Admin.

This worked for me on win8 Excel 365. Add the 2nd block of code to a Module and then add this to another or at the end of the other one. You don't need all of the 2nd block so delete parts if needed.

It should return 1 if found or nothing if not found. So, compare result to <> "" and it will be a boolean True it exists and has a value or False that it was not found or has no value.

'https://support.microsoft.com/en-us/kb/145679
'PtrSafe, https://support.microsoft.com/en-us/kb/983043


Sub ken()
  MsgBox HKeyQueryValue(HKEY_CURRENT_USER, _
    "\Software\Microsoft\Office\" & Application.Version & "\ClickToRun\DistributedEvents", _
    "Global\FF_INTEGRATED6836")
End Sub

Put this in a separate Module. You don't need the VBA7 routines but I added it to show how one can use PtrSafe and added PtrSafe to the other API routines. I also added one routine at the end that was called in the routine above.

Option Explicit
'https://support.microsoft.com/en-us/kb/145679
'PtrSafe, https://support.microsoft.com/en-us/kb/983043


   Public Const REG_SZ As Long = 1
   Public Const REG_DWORD As Long = 4


   Public Const HKEY_CLASSES_ROOT = &H80000000
   Public Const HKEY_CURRENT_USER = &H80000001
   Public Const HKEY_LOCAL_MACHINE = &H80000002
   Public Const HKEY_USERS = &H80000003


   Public Const ERROR_NONE = 0
   Public Const ERROR_BADDB = 1
   Public Const ERROR_BADKEY = 2
   Public Const ERROR_CANTOPEN = 3
   Public Const ERROR_CANTREAD = 4
   Public Const ERROR_CANTWRITE = 5
   Public Const ERROR_OUTOFMEMORY = 6
   Public Const ERROR_ARENA_TRASHED = 7
   Public Const ERROR_ACCESS_DENIED = 8
   Public Const ERROR_INVALID_PARAMETERS = 87
   Public Const ERROR_NO_MORE_ITEMS = 259


   Public Const KEY_QUERY_VALUE = &H1
   Public Const KEY_SET_VALUE = &H2
   Public Const KEY_ALL_ACCESS = &H3F


   Public Const REG_OPTION_NON_VOLATILE = 0
   
   #If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If


   Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" _
   (ByVal hKey As Long) As Long
   Declare PtrSafe Function RegCreateKeyEx Lib "advapi32.dll" Alias _
   "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
   ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _
   As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _
   As Long, phkResult As Long, lpdwDisposition As Long) As Long
   Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias _
   "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
   ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As _
   Long) As Long
   Declare PtrSafe Function RegQueryValueExString Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
   String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
   As String, lpcbData As Long) As Long
   Declare PtrSafe Function RegQueryValueExLong Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
   String, ByVal lpReserved As Long, lpType As Long, lpData As _
   Long, lpcbData As Long) As Long
   Declare PtrSafe Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
   String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
   As Long, lpcbData As Long) As Long
   Declare PtrSafe Function RegSetValueExString Lib "advapi32.dll" Alias _
   "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
   String, ByVal cbData As Long) As Long
   Declare PtrSafe Function RegSetValueExLong Lib "advapi32.dll" Alias _
   "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
   ByVal cbData As Long) As Long
   
   'CreateNewKey "TestKey\SubKey1\SubKey2", HKEY_LOCAL_MACHINE
   Private Sub CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)
       Dim hNewKey As Long         'handle to the new key
       Dim lRetVal As Long         'result of the RegCreateKeyEx function


       lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, _
                 vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
                 0&, hNewKey, lRetVal)
       RegCloseKey (hNewKey)
   End Sub
   
   'SetKeyValue "TestKey\SubKey1", "StringValue", "Hello", REG_SZ
   Private Sub SetKeyValue(sKeyName As String, sValueName As String, _
   vValueSetting As Variant, lValueType As Long)
       Dim lRetVal As Long         'result of the SetValueEx function
       Dim hKey As Long         'handle of open key


       'open the specified key
       lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, _
                                 KEY_SET_VALUE, hKey)
       lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
       RegCloseKey (hKey)
   End Sub
   
   'QueryValue "TestKey\SubKey1", "StringValue"
  Private Sub QueryValue(sKeyName As String, sValueName As String)
       Dim lRetVal As Long         'result of the API functions
       Dim hKey As Long         'handle of opened key
       Dim vValue As Variant      'setting of queried value


       lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, _
   KEY_QUERY_VALUE, hKey)
       lRetVal = QueryValueEx(hKey, sValueName, vValue)
       MsgBox vValue
       RegCloseKey (hKey)
   End Sub
   
   'SetValueEx and QueryValueEx Wrapper Functions:
   Public Function SetValueEx(ByVal hKey As Long, sValueName As String, _
   lType As Long, vValue As Variant) As Long
       Dim lValue As Long
       Dim sValue As String
       Select Case lType
           Case REG_SZ
               sValue = vValue & Chr$(0)
               SetValueEx = RegSetValueExString(hKey, sValueName, 0&, _
                                              lType, sValue, Len(sValue))
           Case REG_DWORD
               lValue = vValue
               SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, _
   lType, lValue, 4)
           End Select
   End Function


   Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
   String, vValue As Variant) As Long
       Dim cch As Long
       Dim lrc As Long
       Dim lType As Long
       Dim lValue As Long
       Dim sValue As String


       On Error GoTo QueryValueExError


       ' Determine the size and type of data to be read
       lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
       If lrc <> ERROR_NONE Then Error 5


       Select Case lType
           ' For strings
           Case REG_SZ:
               sValue = String(cch, 0)


   lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
   sValue, cch)
               If lrc = ERROR_NONE Then
                   vValue = Left$(sValue, cch - 1)
               Else
                   vValue = Empty
               End If
           ' For DWORDS
           Case REG_DWORD:
   lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
   lValue, cch)
               If lrc = ERROR_NONE Then vValue = lValue
           Case Else
               'all other data types not supported
               lrc = -1
       End Select


QueryValueExExit:
       QueryValueEx = lrc
       Exit Function


QueryValueExError:
       Resume QueryValueExExit
   End Function


'Ken
   Public Function HKeyQueryValue(sRoot As Long, sKeyName As String, _
    sValueName As String) As Variant
       Dim lRetVal As Long         'result of the API functions
       Dim hKey As Long         'handle of opened key
       Dim vValue As Variant      'setting of queried value


       lRetVal = RegOpenKeyEx(sRoot, sKeyName, 0, _
   KEY_QUERY_VALUE, hKey)
       lRetVal = QueryValueEx(hKey, sValueName, vValue)
       RegCloseKey (hKey)
       HKeyQueryValue = vValue
   End Function

[Kenneth Hobs]

Chip Pearson's routines are similar and work too when I used the same path. Insert his mod (Module) BAS file. Some may need Private changed to Public if you Call from another Module or Object.

' See http://www.cpearson.com/excel/registry.htm for details about these procedures.Sub Chip()
  MsgBox RegistryValueExists(HKEY_CURRENT_USER, _
    "\Software\Microsoft\Office\" & Application.Version & _
    "\ClickToRun\DistributedEvents", "Global\FF_INTEGRATED6836")
End Sub

[GTO]

@Kenneth:

I tried your code as written at #9 and in WIN7 with Excel 2010, it indeed returned empty :-)

Mark

[bishop3000]

Wow Kenneth, I really appreciate it. (And thanks Mark for trying the code.)

Your #9 code also returned empty for me in WIN7 with Excel 2010 (am I'm not accessing Excel through Office 365). I'll try on a few different computers, some running Excel through Office 365, and will confirm success.

Michael

[bishop3000]

Unfortunately, an empty string is also returned in Excel 2016 accessed through Office 365: screencast.com/t/wWrMDsp9

And I get an error when I run Chip's code. screencast.com/t/UsmqtSkyW5

I really appreciate the help though.

Michael

[Kenneth Hobs]

Manually check your registry to see if that key and value exists.
Win+R
Regedit
Browse to: HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\ClickToRun\DistributedEvents\Global\FF_INTE GRATED6836

[bishop3000]

The ClickToRun folder doesn't exist.