| Attribute VB_Name = "Office10Issues" | |
| '************************************************************************* | |
| ' | |
| ' Licensed to the Apache Software Foundation (ASF) under one | |
| ' or more contributor license agreements. See the NOTICE file | |
| ' distributed with this work for additional information | |
| ' regarding copyright ownership. The ASF licenses this file | |
| ' to you under the Apache License, Version 2.0 (the | |
| ' "License"); you may not use this file except in compliance | |
| ' with the License. You may obtain a copy of the License at | |
| ' | |
| ' http://www.apache.org/licenses/LICENSE-2.0 | |
| ' | |
| ' Unless required by applicable law or agreed to in writing, | |
| ' software distributed under the License is distributed on an | |
| ' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY | |
| ' KIND, either express or implied. See the License for the | |
| ' specific language governing permissions and limitations | |
| ' under the License. | |
| ' | |
| '************************************************************************* | |
| 'Disable Option Explicit so this will compile on earlier Office versions | |
| 'Option Explicit | |
| Public Declare Function RegCloseKey Lib "advapi32.dll" _ | |
| (ByVal hKey As Long) As Long | |
| Public Declare Function RegQueryValueEx Lib "advapi32.dll" _ | |
| Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _ | |
| ByVal lpReserved As Long, lpType As Long, lpData As Any, _ | |
| lpcbData As Long) As Long | |
| Public Declare Function RegSetValueEx Lib "advapi32.dll" _ | |
| Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _ | |
| ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _ | |
| ByVal cbData As Long) As Long | |
| Public Declare 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, lpSecurityAttributes _ | |
| As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long | |
| Public Declare Function RegOpenKey Lib "advapi32.dll" _ | |
| Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _ | |
| phkResult As Long) As Long | |
| Public Declare Function RegCreateKey Lib "advapi32.dll" _ | |
| Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _ | |
| phkResult As Long) As Long | |
| Public Declare Function RegDeleteValue Lib "advapi32.dll" _ | |
| Alias "RegDeleteValueA" (ByVal hKey As Long, _ | |
| ByVal lpValueName As String) As Long | |
| Public Declare 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 | |
| Type SECURITY_ATTRIBUTES | |
| nLength As Long | |
| lpSecurityDescriptor As Long | |
| bInheritHandle As Long | |
| End Type | |
| Enum RegHive | |
| 'HKEY_CLASSES_ROOT = &H80000000 | |
| HK_CR = &H80000000 | |
| HKEY_CURRENT_USER = &H80000001 | |
| HK_CU = &H80000001 | |
| HKEY_LOCAL_MACHINE = &H80000002 | |
| HK_LM = &H80000002 | |
| HKEY_USERS = &H80000003 | |
| HK_US = &H80000003 | |
| HKEY_CURRENT_CONFIG = &H80000005 | |
| HK_CC = &H80000005 | |
| HKEY_DYN_DATA = &H80000006 | |
| HK_DD = &H80000006 | |
| End Enum | |
| Enum RegType | |
| REG_SZ = 1 'Unicode nul terminated string | |
| REG_BINARY = 3 'Free form binary | |
| REG_DWORD = 4 '32-bit number | |
| End Enum | |
| Const ERROR_SUCCESS = 0 | |
| Const KEY_WRITE = &H20006 | |
| Const APP_EXCEL = "Excel" | |
| Const APP_WORD = "Word" | |
| Const APP_PP = "PowerPoint" | |
| Public Function CreateRegKey(hKey As RegHive, strPath As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "CreateRegKey" | |
| Dim heKey As Long | |
| Dim secattr As SECURITY_ATTRIBUTES ' security settings for the key | |
| Dim subkey As String ' name of the subkey to create or open | |
| Dim neworused As Long ' receives flag for if the key was created or opened | |
| Dim stringbuffer As String ' the string to put into the registry | |
| Dim retval As Long ' return value | |
| ' Set the name of the new key and the default security settings | |
| secattr.nLength = Len(secattr) | |
| secattr.lpSecurityDescriptor = 0 | |
| secattr.bInheritHandle = 1 | |
| retval = RegCreateKeyEx(hKey, strPath, 0, "", 0, KEY_WRITE, _ | |
| secattr, heKey, neworused) | |
| If retval = 0 Then | |
| retval = RegCloseKey(hKey) | |
| Exit Function | |
| End If | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| End Function | |
| Public Function CreateRegKey2(hKey As RegHive, strPath As String) As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "CreateRegKey" | |
| CreateRegKey2 = 0 | |
| Dim heKey As Long | |
| Dim secattr As SECURITY_ATTRIBUTES ' security settings for the key | |
| Dim subkey As String ' name of the subkey to create or open | |
| Dim neworused As Long ' receives flag for if the key was created or opened | |
| Dim stringbuffer As String ' the string to put into the registry | |
| Dim retval As Long ' return value | |
| ' Set the name of the new key and the default security settings | |
| secattr.nLength = Len(secattr) | |
| secattr.lpSecurityDescriptor = 0 | |
| secattr.bInheritHandle = 1 | |
| retval = RegCreateKeyEx(hKey, strPath, 0, "", 0, KEY_WRITE, _ | |
| secattr, heKey, neworused) | |
| If retval = ERROR_SUCCESS Then | |
| CreateRegKey2 = heKey | |
| Exit Function | |
| End If | |
| FinalExit: | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| CreateRegKey2 = 0 | |
| GoTo FinalExit | |
| End Function | |
| Public Function GetRegLong(ByVal hKey As RegHive, ByVal strPath As String, ByVal strValue As String) As Long | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "GetRegLong" | |
| Dim lRegResult As Long | |
| Dim lValueType As Long | |
| Dim lBuffer As Long | |
| Dim lDataBufferSize As Long | |
| Dim hCurKey As Long | |
| GetRegLong = 0 | |
| lRegResult = RegOpenKey(hKey, strPath, hCurKey) | |
| lDataBufferSize = 4 '4 bytes = 32 bits = long | |
| lRegResult = RegQueryValueEx(hCurKey, strValue, 0, REG_DWORD, lBuffer, lDataBufferSize) | |
| If lRegResult = ERROR_SUCCESS Then | |
| GetRegLong = lBuffer | |
| End If | |
| lRegResult = RegCloseKey(hCurKey) | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| End Function | |
| Public Function SaveRegLong(ByVal hKey As RegHive, ByVal strPath As String, ByVal strValue As String, ByVal lData As Long) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SaveRegLong" | |
| Const NumofByte = 4 | |
| Dim hCurKey As Long | |
| Dim lRegResult As Long | |
| lRegResult = RegCreateKey(hKey, strPath, hCurKey) | |
| lRegResult = RegSetValueEx(hCurKey, strValue, 0&, REG_DWORD, lData, NumofByte) | |
| If lRegResult = ERROR_SUCCESS Then | |
| lRegResult = RegCloseKey(hCurKey) | |
| Exit Function | |
| End If | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| End Function | |
| Public Function GiveAccessToMacroProject(application As String, sVersion As String, oldvalue As Long) As Boolean | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SaveRegLong" | |
| GiveAccessToMacroProject = False | |
| Const OfficePath = "Software\Policies\Microsoft\Office\" | |
| Const security = "\Security" | |
| Const AccessVBOM = "AccessVBOM" | |
| Const AccessVBOMValue = 1 | |
| Dim subpath As String | |
| Dim RegistryValue As Long | |
| subpath = OfficePath & sVersion & "\" & application & security | |
| CreateRegKey HKEY_CURRENT_USER, subpath | |
| RegistryValue = GetRegLong(HKEY_CURRENT_USER, subpath, AccessVBOM) | |
| oldvalue = RegistryValue | |
| SaveRegLong HKEY_CURRENT_USER, subpath, AccessVBOM, AccessVBOMValue | |
| GiveAccessToMacroProject = True | |
| Exit Function | |
| HandleErrors: | |
| GiveAccessToMacroProject = False | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| End Function | |
| Public Function SetDefaultRegValue(application As String, sVersion As String, sValue As Long) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SaveRegLong" | |
| Const OfficePath = "Software\Policies\Microsoft\Office\" | |
| Const security = "\Security" | |
| Const AccessVBOM = "AccessVBOM" | |
| Dim subpath As String | |
| subpath = OfficePath & sVersion & "\" & application & security | |
| SaveRegLong HKEY_CURRENT_USER, subpath, AccessVBOM, sValue | |
| Exit Function | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| End Function | |
| Public Function DeleteRegValue(application As String, sVersion As String) | |
| On Error GoTo HandleErrors | |
| Dim currentFunctionName As String | |
| currentFunctionName = "SaveRegLong" | |
| Const OfficePath = "Software\Policies\Microsoft\Office\" | |
| Const security = "\Security" | |
| Const AccessVBOM = "AccessVBOM" | |
| Dim subpath As String | |
| Dim retval As Long | |
| Dim hKey As Long | |
| subpath = OfficePath & sVersion & "\" & application & security | |
| retval = RegOpenKeyEx(HKEY_CURRENT_USER, subpath, 0, KEY_WRITE, hKey) | |
| If retval = ERROR_SUCCESS Then | |
| retval = RegDeleteValue(hKey, AccessVBOM) | |
| retval = RegCloseKey(hKey) | |
| Exit Function | |
| End If | |
| HandleErrors: | |
| WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
| End Function | |
| Public Function CheckForAccesToWordVBProject1(wrd As Word.application, RestoreValue As Long) As Boolean | |
| On Error Resume Next | |
| CheckForAccesToWordVBProject1 = True | |
| RestoreValue = -1 | |
| If val(wrd.Version) < 10# Then Exit Function | |
| Set myProject = wrd.ActiveDocument.VBProject | |
| If Err.Number <> 0 Then | |
| Dim RegValue As Long | |
| If GiveAccessToMacroProject(APP_WORD, wrd.Version, RegValue) Then | |
| CheckForAccesToWordVBProject1 = True | |
| RestoreValue = RegValue | |
| Else | |
| CheckForAccesToWordVBProject1 = False | |
| End If | |
| End If | |
| End Function | |
| Public Function CheckForAccesToWordVBProject(wrd As Word.application) As Boolean | |
| On Error Resume Next | |
| CheckForAccesToWordVBProject = True | |
| If val(wrd.Version) < 10# Then Exit Function | |
| Set myProject = wrd.ActiveDocument.VBProject | |
| If Err.Number <> 0 Then | |
| CheckForAccesToWordVBProject = False | |
| End If | |
| End Function | |
| Public Function CheckForAccesToExcelVBProject1(xl As Excel.application, RestoreValue As Long) As Boolean | |
| On Error Resume Next | |
| CheckForAccesToExcelVBProject1 = True | |
| RestoreValue = -1 | |
| If val(xl.Version) < 10# Then Exit Function | |
| Dim displayAlerts As Boolean | |
| displayAlerts = xl.displayAlerts | |
| xl.displayAlerts = False | |
| Set myProject = xl.ActiveWorkbook.VBProject | |
| If Err.Number <> 0 Then | |
| Dim RegValue As Long | |
| If GiveAccessToMacroProject(APP_EXCEL, xl.Version, RegValue) Then | |
| CheckForAccesToExcelVBProject1 = True | |
| RestoreValue = RegValue | |
| Else | |
| CheckForAccesToExcelVBProject1 = False | |
| End If | |
| End If | |
| xl.displayAlerts = displayAlerts | |
| End Function | |
| Public Function CheckForAccesToExcelVBProject(xl As Excel.application) As Boolean | |
| On Error Resume Next | |
| CheckForAccesToExcelVBProject = True | |
| If val(xl.Version) < 10# Then Exit Function | |
| Dim displayAlerts As Boolean | |
| displayAlerts = xl.displayAlerts | |
| xl.displayAlerts = False | |
| Set myProject = xl.ActiveWorkbook.VBProject | |
| If Err.Number <> 0 Then | |
| CheckForAccesToExcelVBProject = False | |
| End If | |
| xl.displayAlerts = displayAlerts | |
| End Function | |
| Public Function CheckForAccesToPPVBProject1(pp As PowerPoint.application, pres As PowerPoint.Presentation, RestoreValue As Long) As Boolean | |
| On Error Resume Next | |
| CheckForAccesToPPVBProject1 = True | |
| RestoreValue = -1 | |
| If val(pp.Version) < 10# Then Exit Function | |
| Set myProject = pres.VBProject | |
| If Err.Number <> 0 Then | |
| Dim RegValue As Long | |
| If GiveAccessToMacroProject(APP_PP, pp.Version, RegValue) Then | |
| CheckForAccesToPPVBProject1 = True | |
| RestoreValue = RegValue | |
| Else | |
| CheckForAccesToPPVBProject1 = False | |
| End If | |
| End If | |
| End Function | |
| Public Function CheckForAccesToPPVBProject(pp As PowerPoint.application, pres As PowerPoint.Presentation) As Boolean | |
| On Error Resume Next | |
| CheckForAccesToPPVBProject = True | |
| If val(pp.Version) < 10# Then Exit Function | |
| Set myProject = pres.VBProject | |
| If Err.Number <> 0 Then | |
| CheckForAccesToPPVBProject = False | |
| End If | |
| End Function |