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 |