xref: /aoo42x/main/migrationanalysis/src/wizard/Office10Issues.bas (revision e76eebc6)

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