时间戳

首页 > 解决方案 > Excel vba - 从模块或类调用时，RegOpenKeyExA& 函数返回不同的值

excel - Excel vba - 从模块或类调用时，RegOpenKeyExA& 函数返回不同的值

问题描述

我最近在以下网站找到了一个代码，可以为通过 VBA 添加的对象获取适当的图标：

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

此代码效果很好，返回适当的图标路径，提供文件扩展名作为输入参数（例如“.pdf”）。问题是我只有在将代码放在模块中并从同一个模块或另一个模块调用“getIcon”函数时才能让它工作。当我从类而不是模块调用“getIcon”时，我没有得到任何图标路径，只有“”值。我试图将所有代码放在类本身中，但仍然得到一个空白字符串。通过调试，我意识到 RegOpenKeyExA& 函数返回“5”值，如果调用是从一个类进行的，如果调用是从一个模块进行的，则返回“0”值。我希望有人可以向我解释这种行为，并提供一种解决方法，因为我需要从课堂上拨打电话。非常感谢提前，

我从网上得到的代码：

            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

标签： excelvba

解决方案

你如何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&)

推荐阅读