1Attribute VB_Name = "Office10Issues"
2'*************************************************************************
3'
4'  Licensed to the Apache Software Foundation (ASF) under one
5'  or more contributor license agreements.  See the NOTICE file
6'  distributed with this work for additional information
7'  regarding copyright ownership.  The ASF licenses this file
8'  to you under the Apache License, Version 2.0 (the
9'  "License"); you may not use this file except in compliance
10'  with the License.  You may obtain a copy of the License at
11'
12'    http://www.apache.org/licenses/LICENSE-2.0
13'
14'  Unless required by applicable law or agreed to in writing,
15'  software distributed under the License is distributed on an
16'  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
17'  KIND, either express or implied.  See the License for the
18'  specific language governing permissions and limitations
19'  under the License.
20'
21'*************************************************************************
22
23'Disable Option Explicit so this will compile on earlier Office versions
24'Option Explicit
25Public Declare Function RegCloseKey Lib "advapi32.dll" _
26    (ByVal hKey As Long) As Long
27Public Declare Function RegQueryValueEx Lib "advapi32.dll" _
28    Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
29    ByVal lpReserved As Long, lpType As Long, lpData As Any, _
30    lpcbData As Long) As Long
31Public Declare Function RegSetValueEx Lib "advapi32.dll" _
32    Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
33    ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _
34    ByVal cbData As Long) As Long
35Public Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal _
36    hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass _
37    As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes _
38    As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
39Public Declare Function RegOpenKey Lib "advapi32.dll" _
40    Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _
41    phkResult As Long) As Long
42Public Declare Function RegCreateKey Lib "advapi32.dll" _
43    Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _
44    phkResult As Long) As Long
45Public Declare Function RegDeleteValue Lib "advapi32.dll" _
46    Alias "RegDeleteValueA" (ByVal hKey As Long, _
47    ByVal lpValueName As String) As Long
48Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal _
49    hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired _
50    As Long, phkResult As Long) As Long
51
52Type SECURITY_ATTRIBUTES
53    nLength As Long
54    lpSecurityDescriptor As Long
55    bInheritHandle As Long
56End Type
57
58Enum RegHive
59    'HKEY_CLASSES_ROOT = &H80000000
60    HK_CR = &H80000000
61    HKEY_CURRENT_USER = &H80000001
62    HK_CU = &H80000001
63    HKEY_LOCAL_MACHINE = &H80000002
64    HK_LM = &H80000002
65    HKEY_USERS = &H80000003
66    HK_US = &H80000003
67    HKEY_CURRENT_CONFIG = &H80000005
68    HK_CC = &H80000005
69    HKEY_DYN_DATA = &H80000006
70    HK_DD = &H80000006
71End Enum
72
73Enum RegType
74    REG_SZ = 1 'Unicode nul terminated string
75    REG_BINARY = 3 'Free form binary
76    REG_DWORD = 4 '32-bit number
77End Enum
78
79Const ERROR_SUCCESS = 0
80Const KEY_WRITE = &H20006
81Const APP_EXCEL = "Excel"
82Const APP_WORD = "Word"
83Const APP_PP = "PowerPoint"
84
85Public Function CreateRegKey(hKey As RegHive, strPath As String)
86    On Error GoTo HandleErrors
87    Dim currentFunctionName As String
88    currentFunctionName = "CreateRegKey"
89
90    Dim heKey As Long
91    Dim secattr As SECURITY_ATTRIBUTES  ' security settings for the key
92    Dim subkey As String        ' name of the subkey to create or open
93    Dim neworused As Long       ' receives flag for if the key was created or opened
94    Dim stringbuffer As String  ' the string to put into the registry
95    Dim retval As Long          ' return value
96
97    ' Set the name of the new key and the default security settings
98    secattr.nLength = Len(secattr)
99    secattr.lpSecurityDescriptor = 0
100    secattr.bInheritHandle = 1
101
102     retval = RegCreateKeyEx(hKey, strPath, 0, "", 0, KEY_WRITE, _
103        secattr, heKey, neworused)
104    If retval = 0 Then
105        retval = RegCloseKey(hKey)
106        Exit Function
107    End If
108
109HandleErrors:
110    WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
111End Function
112
113Public Function CreateRegKey2(hKey As RegHive, strPath As String) As Long
114    On Error GoTo HandleErrors
115    Dim currentFunctionName As String
116    currentFunctionName = "CreateRegKey"
117    CreateRegKey2 = 0
118
119    Dim heKey As Long
120    Dim secattr As SECURITY_ATTRIBUTES  ' security settings for the key
121    Dim subkey As String        ' name of the subkey to create or open
122    Dim neworused As Long       ' receives flag for if the key was created or opened
123    Dim stringbuffer As String  ' the string to put into the registry
124    Dim retval As Long          ' return value
125
126    ' Set the name of the new key and the default security settings
127    secattr.nLength = Len(secattr)
128    secattr.lpSecurityDescriptor = 0
129    secattr.bInheritHandle = 1
130
131    retval = RegCreateKeyEx(hKey, strPath, 0, "", 0, KEY_WRITE, _
132        secattr, heKey, neworused)
133    If retval = ERROR_SUCCESS Then
134        CreateRegKey2 = heKey
135        Exit Function
136    End If
137
138FinalExit:
139    Exit Function
140
141HandleErrors:
142    WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
143    CreateRegKey2 = 0
144    GoTo FinalExit
145End Function
146
147
148Public Function GetRegLong(ByVal hKey As RegHive, ByVal strPath As String, ByVal strValue As String) As Long
149    On Error GoTo HandleErrors
150    Dim currentFunctionName As String
151    currentFunctionName = "GetRegLong"
152
153    Dim lRegResult As Long
154    Dim lValueType As Long
155    Dim lBuffer As Long
156    Dim lDataBufferSize As Long
157    Dim hCurKey As Long
158
159    GetRegLong = 0
160    lRegResult = RegOpenKey(hKey, strPath, hCurKey)
161    lDataBufferSize = 4 '4 bytes = 32 bits = long
162
163    lRegResult = RegQueryValueEx(hCurKey, strValue, 0, REG_DWORD, lBuffer, lDataBufferSize)
164    If lRegResult = ERROR_SUCCESS Then
165        GetRegLong = lBuffer
166    End If
167        lRegResult = RegCloseKey(hCurKey)
168        Exit Function
169
170HandleErrors:
171    WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
172End Function
173
174Public Function SaveRegLong(ByVal hKey As RegHive, ByVal strPath As String, ByVal strValue As String, ByVal lData As Long)
175    On Error GoTo HandleErrors
176    Dim currentFunctionName As String
177    currentFunctionName = "SaveRegLong"
178
179    Const NumofByte = 4
180    Dim hCurKey As Long
181    Dim lRegResult As Long
182
183    lRegResult = RegCreateKey(hKey, strPath, hCurKey)
184    lRegResult = RegSetValueEx(hCurKey, strValue, 0&, REG_DWORD, lData, NumofByte)
185    If lRegResult = ERROR_SUCCESS Then
186        lRegResult = RegCloseKey(hCurKey)
187        Exit Function
188    End If
189
190HandleErrors:
191    WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
192End Function
193
194
195Public Function GiveAccessToMacroProject(application As String, sVersion As String, oldvalue As Long) As Boolean
196    On Error GoTo HandleErrors
197    Dim currentFunctionName As String
198    currentFunctionName = "SaveRegLong"
199    GiveAccessToMacroProject = False
200
201    Const OfficePath = "Software\Policies\Microsoft\Office\"
202    Const security = "\Security"
203    Const AccessVBOM = "AccessVBOM"
204    Const AccessVBOMValue = 1
205    Dim subpath As String
206    Dim RegistryValue As Long
207
208    subpath = OfficePath & sVersion & "\" & application & security
209    CreateRegKey HKEY_CURRENT_USER, subpath
210    RegistryValue = GetRegLong(HKEY_CURRENT_USER, subpath, AccessVBOM)
211    oldvalue = RegistryValue
212    SaveRegLong HKEY_CURRENT_USER, subpath, AccessVBOM, AccessVBOMValue
213    GiveAccessToMacroProject = True
214    Exit Function
215
216HandleErrors:
217    GiveAccessToMacroProject = False
218    WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
219End Function
220
221Public Function SetDefaultRegValue(application As String, sVersion As String, sValue As Long)
222    On Error GoTo HandleErrors
223    Dim currentFunctionName As String
224    currentFunctionName = "SaveRegLong"
225
226    Const OfficePath = "Software\Policies\Microsoft\Office\"
227    Const security = "\Security"
228    Const AccessVBOM = "AccessVBOM"
229    Dim subpath As String
230
231    subpath = OfficePath & sVersion & "\" & application & security
232    SaveRegLong HKEY_CURRENT_USER, subpath, AccessVBOM, sValue
233    Exit Function
234
235HandleErrors:
236    WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
237End Function
238Public Function DeleteRegValue(application As String, sVersion As String)
239    On Error GoTo HandleErrors
240    Dim currentFunctionName As String
241    currentFunctionName = "SaveRegLong"
242
243    Const OfficePath = "Software\Policies\Microsoft\Office\"
244    Const security = "\Security"
245    Const AccessVBOM = "AccessVBOM"
246    Dim subpath As String
247    Dim retval As Long
248    Dim hKey As Long
249
250    subpath = OfficePath & sVersion & "\" & application & security
251    retval = RegOpenKeyEx(HKEY_CURRENT_USER, subpath, 0, KEY_WRITE, hKey)
252    If retval = ERROR_SUCCESS Then
253        retval = RegDeleteValue(hKey, AccessVBOM)
254        retval = RegCloseKey(hKey)
255        Exit Function
256    End If
257
258HandleErrors:
259    WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
260End Function
261
262Public Function CheckForAccesToWordVBProject1(wrd As Word.application, RestoreValue As Long) As Boolean
263    On Error Resume Next
264    CheckForAccesToWordVBProject1 = True
265    RestoreValue = -1
266    If val(wrd.Version) < 10# Then Exit Function
267
268    Set myProject = wrd.ActiveDocument.VBProject
269    If Err.Number <> 0 Then
270        Dim RegValue As Long
271        If GiveAccessToMacroProject(APP_WORD, wrd.Version, RegValue) Then
272            CheckForAccesToWordVBProject1 = True
273            RestoreValue = RegValue
274        Else
275            CheckForAccesToWordVBProject1 = False
276        End If
277    End If
278
279End Function
280Public Function CheckForAccesToWordVBProject(wrd As Word.application) As Boolean
281    On Error Resume Next
282    CheckForAccesToWordVBProject = True
283    If val(wrd.Version) < 10# Then Exit Function
284
285    Set myProject = wrd.ActiveDocument.VBProject
286    If Err.Number <> 0 Then
287        CheckForAccesToWordVBProject = False
288    End If
289
290End Function
291Public Function CheckForAccesToExcelVBProject1(xl As Excel.application, RestoreValue As Long) As Boolean
292    On Error Resume Next
293    CheckForAccesToExcelVBProject1 = True
294    RestoreValue = -1
295    If val(xl.Version) < 10# Then Exit Function
296
297    Dim displayAlerts As Boolean
298    displayAlerts = xl.displayAlerts
299    xl.displayAlerts = False
300    Set myProject = xl.ActiveWorkbook.VBProject
301    If Err.Number <> 0 Then
302        Dim RegValue As Long
303        If GiveAccessToMacroProject(APP_EXCEL, xl.Version, RegValue) Then
304            CheckForAccesToExcelVBProject1 = True
305            RestoreValue = RegValue
306        Else
307            CheckForAccesToExcelVBProject1 = False
308        End If
309    End If
310    xl.displayAlerts = displayAlerts
311
312End Function
313Public Function CheckForAccesToExcelVBProject(xl As Excel.application) As Boolean
314    On Error Resume Next
315    CheckForAccesToExcelVBProject = True
316    If val(xl.Version) < 10# Then Exit Function
317
318    Dim displayAlerts As Boolean
319    displayAlerts = xl.displayAlerts
320    xl.displayAlerts = False
321    Set myProject = xl.ActiveWorkbook.VBProject
322    If Err.Number <> 0 Then
323        CheckForAccesToExcelVBProject = False
324    End If
325    xl.displayAlerts = displayAlerts
326
327End Function
328Public Function CheckForAccesToPPVBProject1(pp As PowerPoint.application, pres As PowerPoint.Presentation, RestoreValue As Long) As Boolean
329    On Error Resume Next
330    CheckForAccesToPPVBProject1 = True
331    RestoreValue = -1
332    If val(pp.Version) < 10# Then Exit Function
333
334    Set myProject = pres.VBProject
335    If Err.Number <> 0 Then
336        Dim RegValue As Long
337        If GiveAccessToMacroProject(APP_PP, pp.Version, RegValue) Then
338            CheckForAccesToPPVBProject1 = True
339            RestoreValue = RegValue
340        Else
341            CheckForAccesToPPVBProject1 = False
342        End If
343    End If
344End Function
345
346Public Function CheckForAccesToPPVBProject(pp As PowerPoint.application, pres As PowerPoint.Presentation) As Boolean
347    On Error Resume Next
348    CheckForAccesToPPVBProject = True
349    If val(pp.Version) < 10# Then Exit Function
350
351    Set myProject = pres.VBProject
352    If Err.Number <> 0 Then
353        CheckForAccesToPPVBProject = False
354    End If
355End Function
356