Excel vba - RegOpenKeyExA & функция возвращает разные значения при вызове из модуля или из класса

Question

Недавно я нашел код для получения соответствующих значков для объектов, добавленных через VBA, на следующем веб-сайте:

https://www.excelforum.com/excel-programming-vba-macros/569810-icons-for-attachments-added-via-vba.html

Этот код прекрасно работает, возвращая соответствующий путь к значку, давая файлрасширение в качестве входного параметра (например, «.pdf»).Проблема в том, что он работает только при помещении кода в модуль и при вызове функции «getIcon» из того же или другого модуля.Когда я вызываю «getIcon» из класса, а не из модуля, я не получаю никакого пути к значку, просто «» значение.Я пытался поместить весь код в сам класс, но все еще получал пустую строку.После отладки я понял, что функция RegOpenKeyExA & возвращает значение «5», если вызов сделан из класса, и значение «0», если вызов сделан из модуля.Я надеюсь, что кто-то может объяснить мне это поведение, а также предоставить обходной путь, потому что мне нужно позвонить из класса.Заранее большое спасибо, и здесь идет код, который я получил от веб-сайта, на который ссылаются, и вызывающего подпрограммы с именем "Test".

Код, который я получил от сети:

            Declare Function RegCloseKey& Lib "advapi32.dll" (ByVal hKey&)
            Declare Function RegOpenKeyExA& Lib "advapi32.dll" (ByVal hKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&)
            Declare Function RegQueryValueExA& Lib "advapi32.dll" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
            Declare Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, lpDataBuff&, nSize&)

            Const HKEY_CLASSES_ROOT = &H80000000
            Const HKEY_CURRENT_USER = &H80000001
            Const HKEY_LOCAL_MACHINE = &H80000002
            Const HKEY_USERS = &H80000003

            Const ERROR_SUCCESS = 0&
            Const REG_SZ = 1& ' Unicode nul terminated string
            Const REG_DWORD = 4& ' 32-bit number

            Const KEY_QUERY_VALUE = &H1&
            Const KEY_SET_VALUE = &H2&
            Const KEY_CREATE_SUB_KEY = &H4&
            Const KEY_ENUMERATE_SUB_KEYS = &H8&
            Const KEY_NOTIFY = &H10&
            Const KEY_CREATE_LINK = &H20&
            Const READ_CONTROL = &H20000
            Const WRITE_DAC = &H40000
            Const WRITE_OWNER = &H80000
            Const SYNCHRONIZE = &H100000
            Const STANDARD_RIGHTS_REQUIRED = &HF0000
            Const STANDARD_RIGHTS_READ = READ_CONTROL
            Const STANDARD_RIGHTS_WRITE = READ_CONTROL
            Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
            Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
            Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
            Const KEY_EXECUTE = KEY_READ


            Function RegGetValue$(MainKey&, SubKey$, value$)
            ' MainKey must be one of the Publicly declared HKEY constants.
            Dim sKeyType& 'to return the key type. This function expects REG_SZ or REG_DWORD
            Dim ret& 'returned by registry functions, should be 0&
            Dim lpHKey& 'return handle to opened key
            Dim lpcbData& 'length of data in returned string
            Dim ReturnedString$ 'returned string value
            Dim ReturnedLong& 'returned long value
            If MainKey >= &H80000000 And MainKey <= &H80000006 Then
            ' Open key
            ret = RegOpenKeyExA(MainKey, SubKey, 0&, KEY_READ, lpHKey)
            If ret <> ERROR_SUCCESS Then
            RegGetValue = ""
            Exit Function 'No key open, so leave
            End If

            ' Set up buffer for data to be returned in.
            ' Adjust next value for larger buffers.
            lpcbData = 255
            ReturnedString = Space$(lpcbData)

            ' Read key
            ret& = RegQueryValueExA(lpHKey, value, ByVal 0&, sKeyType, ReturnedString, lpcbData)
            If ret <> ERROR_SUCCESS Then
            RegGetValue = "" 'Value probably doesn't exist
            Else
            If sKeyType = REG_DWORD Then
            ret = RegQueryValueEx(lpHKey, value, ByVal 0&, sKeyType, ReturnedLong, 4)
            If ret = ERROR_SUCCESS Then RegGetValue = CStr(ReturnedLong)
            Else
            RegGetValue = Left$(ReturnedString, lpcbData - 1)
            End If
            End If
            ' Always close opened keys.
            ret = RegCloseKey(lpHKey)
            End If
            End Function

            Function GetIcon(strExtension As String) As String
            GetIcon = RegGetValue$(HKEY_CLASSES_ROOT, RegGetValue$(HKEY_CLASSES_ROOT, strExtension, "") & "\DefaultIcon", "")
            If InStr(GetIcon, ",") > 0 Then GetIcon = Left(GetIcon, InStr(GetIcon, ",") - 1)
            End Function

вызывающий абонент:

            Sub Test()                
                Dim str As String
                Dim str_ext As String                    
                str_ext = ".pdf"
                str = GetIcon(str_ext)
                'If calling from module: str = "C:\Windows\Installer\{AC76BA86-7AD7-1033-7B44-AC0F074E4100}\PDFFile_8.ico"
                'If calling from class:  str = ""          
            End Sub

Answer 1

Как вы звоните getIcon из класса? Следующий код работал для меня, так что это может быть жизнеспособным решением.

'''   class module named TestClass
Option Explicit

Private Sub Class_Initialize()
    Call Me.Test
End Sub

Sub Test()
    Dim str As String
    Dim str_ext As String
    str_ext = ".pdf"
    str = GetIcon(str_ext)
    'from module or class: str = "C:\Windows\Installer\{AC76BA86-7AD7-1033-7B44-AC0F074E4100}\PDFFile_8.ico"
End Sub

Вот код для его проверки (код для создания экземпляра класса TestClass)

'''   any regular module
Sub classTest()
    Dim a As TestClass
    Set a = New TestClass
End Sub

Если это не помогло, вы можете также попытаться добавить ключевое слово PtrSafe в свои объявления. Рекомендуется использовать синтаксис для обеспечения совместимости как с 32-разрядными, так и с 64-разрядными платформами, см. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/ptrsafe-keyword. Объявления будут выглядеть следующим образом:

Declare PtrSafe Function RegCloseKey& Lib "advapi32.dll" (ByVal hKey&)
Declare PtrSafe Function RegOpenKeyExA& Lib "advapi32.dll" (ByVal hKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&)
Declare PtrSafe Function RegQueryValueExA& Lib "advapi32.dll" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
Declare PtrSafe Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, lpDataBuff&, nSize&)