PDA

View Full Version : VBA: Detect whether Office 365 subscription or purchased Office version



bishop3000
08-01-2015, 03:37 PM
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
08-03-2015, 01:05 AM
Why? A 365 subscription gives you the current office version on your desktop (i.e. 2013 at the moment).

bishop3000
08-03-2015, 04:23 PM
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
08-04-2015, 01:26 AM
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
08-04-2015, 07:40 AM
This will tell you the version. It does not answer your question though.

MsgBox Application.Version

bishop3000
08-05-2015, 09:03 AM
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
08-05-2015, 11:51 AM
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
08-05-2015, 02:17 PM
Kenneth, thanks so much for the attempt.

Kenneth Hobs
08-05-2015, 07:37 PM
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
08-05-2015, 07:56 PM
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
08-06-2015, 12:45 AM
@Kenneth:

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

Mark

bishop3000
08-06-2015, 02:13 PM
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
08-11-2015, 02:23 PM
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
08-11-2015, 03:16 PM
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\DistributedEven ts\Global\FF_INTEGRATED6836

bishop3000
08-11-2015, 04:31 PM
The ClickToRun folder doesn't exist.