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