如何将VARIANT转换为托管对象?

Posted

tags:

篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了如何将VARIANT转换为托管对象?相关的知识,希望对你有一定的参考价值。

这是原始VBA代码的来源:Original VBA code

我将这些功能转换为VB.Net

FilePropertyExplorer

Class_Initialize

继承了我到目前为止的代码(注意我为了简洁而删除了一些代码)

Imports System.Runtime.InteropServices

Public Class VirtualCOMObject
    Private Const OPTION_BASE As Long = 0
    Private Const OPTION_FLAGS As Long = 2
    Private Const OPTION_INCLUDE_REFERENCEDOCS As Long = 0
    Private Const OPTION_DISABLEDCLASSES As String = ""
    Private Const DECOMPRESSED_EXT As Long = 56493
    Private Const SIZEOF_PTR32 As Long = &H4
    Private Const SIZEOF_PTR64 As Long = &H8
    Private Const PAGE_EXECUTE_RW As Long = &H40
    Private Const MEM_RESERVE_AND_COMMIT As Long = &H3000
    Private Const ERR_OUT_OF_MEMORY As Long = &H7

    Private m_ClassFactory As Object

    <DllImport("kernel32.dll", CharSet:=CharSet.None, ExactSpelling:=False, SetLastError:=True)>
    Private Shared Function VirtualAlloc(
                ByVal lpAddress As IntPtr,
                ByVal dwSize As UIntPtr,
                ByVal flAllocationType As AllocationType,
                ByVal flProtect As MemoryProtection) As IntPtr
    End Function

    <DllImport("kernel32.dll", CharSet:=CharSet.Auto, SetLastError:=True)>
    Public Shared Function GetModuleHandleA(ByVal lpModuleName As String) As IntPtr
    End Function

    <DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True)>
    Public Shared Function GetProcAddress(ByVal hModule As IntPtr, ByVal procName As String) As IntPtr
    End Function

    <DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True, EntryPoint:="RtlMoveMemory")>
    Public Shared Sub CopyMemoryAnsi(ByVal Dest As IntPtr, ByVal Source As String, ByVal Size As IntPtr)
    End Sub

    <DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True, EntryPoint:="RtlMoveMemory")>
    Public Shared Sub CastToObject(ByRef Dest As Object, ByRef Source As IntPtr, ByVal Size As IntPtr)
    End Sub

    Declare Sub CopyMemoryByref Lib "Kernel32.dll" Alias "RtlMoveMemory" (ByRef dest As Integer, ByRef source As Integer, ByVal numBytes As Integer)

    <Flags>
    Public Enum AllocationType As UInteger
        COMMIT = 4096
        RESERVE = 8192
        RESET = 524288
        TOP_DOWN = 1048576
        WRITE_WATCH = 2097152
        PHYSICAL = 4194304
        LARGE_PAGES = 536870912
    End Enum

    <Flags>
    Public Enum MemoryProtection As UInteger
        NOACCESS = 1
        [READONLY] = 2
        READWRITE = 4
        WRITECOPY = 8
        EXECUTE = 16
        EXECUTE_READ = 32
        EXECUTE_READWRITE = 64
        EXECUTE_WRITECOPY = 128
        GUARD_Modifierflag = 256
        NOCACHE_Modifierflag = 512
        WRITECOMBINE_Modifierflag = 1024
    End Enum


    Public Sub Class_Initialize()

        Dim NativeCode As String
        Dim LoaderVTable As IDispatchVTable
        Dim Ignore As Boolean
        Dim ClassFactoryLoader As Object

#If VBA7 = False Then
        Dim Kernel32Handle As Long
        Dim GetProcAddressPtr As Long
        Dim NativeCodeAddr As Long
        Dim LoaderVTablePtr As Long
        Dim LoaderObj As Long
#Else
        Dim Kernel32Handle As LongPtr
        Dim GetProcAddressPtr As LongPtr
        Dim NativeCodeAddr As LongPtr
        Dim LoaderVTablePtr As LongPtr
        Dim LoaderObj As LongPtr
#End If

        '#If Win64 = False Then
        '        Const SIZEOF_PTR = SIZEOF_PTR32
        '#Else
        Const SIZEOF_PTR = SIZEOF_PTR64
        '#End If

        'NativeCode string initialized here

        NativeCode = NativeCode & "%EEEE%::::RPZPPPh$#$$j PPPPH+T$ t5AYAZkDTX 5j7{{L3TQ@M3LR@A)DR@Xf5@@fA)AUXI3DR@ZZZZZZ?!, @RY3LDl3TA@PY,VH)DJ@XXXXXXXXXX%EEEE%::::VSPPPPj PPPPPPPP4T)D$04P)D$,4  '4 )D$($ PZ3D$@+D$ YQ3H +L$ XP3Q +T$0XPf55nf)BUR[YQ^VXP2Cf<0tF1+++ 
'==========================================================================     
'Code removed for brevity. The full string can be found on the links above
'==========================================================================
ij DdEXXZPEdkHOqrLSKGZT;pOCUHvFst;z??qapyyZtzrUuhX_;hnJmp;n;kGQF^AF oqvSDDS^;TufXPumRLDVQSzCbT]x]keCb?fWgTwFvTwEj0" 

        ClassFactoryLoader = New Object()
        ' Allocate the executable memory for the object
        NativeCodeAddr = VirtualAlloc(0, Len(NativeCode) + DECOMPRESSED_EXT, MEM_RESERVE_AND_COMMIT, PAGE_EXECUTE_RW)

        If NativeCodeAddr <> 0 Then

            ' Copy the x86 and x64 native code into the allocated memory
            Call CopyMemoryAnsi(NativeCodeAddr, NativeCode, Len(NativeCode))

            ' Force the memory address into an Object variable (also triggers the shell code)
            LoaderVTable.QueryInterface = NativeCodeAddr    'longptr
            LoaderVTablePtr = VarPtr(LoaderVTable)          'ptr to LoaderVTable(IDispatchVTable structure)
            LoaderObj = VarPtr(LoaderVTablePtr)

            '==========================================================================
            'ERROR: Managed Debugging Assistant 'InvalidVariant' : 'An invalid VARIANT was detected during a conversion from an unmanaged VARIANT to a managed object. Passing invalid VARIANTs to the CLR can cause unexpected exceptions, corruption or data loss.'
            '==========================================================================
            Call CastToObject(ClassFactoryLoader, LoaderObj, SIZEOF_PTR)    'CastToObject=RtlMoveMemory
            Ignore = TypeOf ClassFactoryLoader Is VBA.Collection            'ClassFactoryLoader(object type)
            m_ClassFactory = (ClassFactoryLoader)                       'object

            ' Initialize our COM object
            Kernel32Handle = GetModuleHandleA("kernel32")
            GetProcAddressPtr = GetProcAddress(Kernel32Handle, "GetProcAddress")

            'With m_ClassFactory
            '    Call .Init(Kernel32Handle, GetProcAddressPtr, OPTION_BASE + OPTION_FLAGS, NativeCode, New FilePropertyExplorer_Helper)
            '    Ignore = TypeOf .FileProperties Is FileProperties And TypeOf .FileProperty Is FileProperty
            'End With

        Else

            Err.Raise(ERR_OUT_OF_MEMORY)

        End If
    End Sub

    Function OpenFile(ByVal FilePath As String, Optional ByVal WriteSupport As Boolean = False) As FileProperties
        OpenFile = m_ClassFactory.OpenFile(FilePath, WriteSupport)
    End Function

End Class

<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Ansi, Pack:=1)>
Public Structure IDispatchVTable
    Public QueryInterface As IntPtr
    Public AddRef As IntPtr
    Public Release As IntPtr
    Public GetTypeInfoCount As IntPtr
    Public GetTypeInfo As IntPtr
    Public GetIDsOfNames As IntPtr
    Public Invoke As IntPtr
End Structure

VarToPtr。我不确定这段代码。在互联网上找到它并稍加修改

Module VarPtrSupport
    ' a delegate that can point to the VarPtrCallback method
    Private Delegate Function VarPtrCallbackDelegate(
       ByVal address As Integer, ByVal unused1 As Integer,
       ByVal unused2 As Integer, ByVal unused3 As Integer) As Integer

    ' two aliases for the CallWindowProcA Windows API method
    ' notice that 2nd argument is passed by-reference
    Private Declare Function CallWindowProc Lib "user32" _
       Alias "CallWindowProcA" _
       (ByVal wndProc As VarPtrCallbackDelegate, ByRef var As Short,
       ByVal unused1 As Integer, ByVal unused2 As Integer,
       ByVal unused3 As Integer) As Integer

    Private Declare Function CallWindowProc Lib "user32" _
       Alias "CallWindowProcA" _
       (ByVal wndProc As VarPtrCallbackDelegate, ByRef var As Integer,
       ByVal unused1 As Integer, ByVal unused2 As Integer,
       ByVal unused3 As Integer) As Integer
    ' ...add more overload to support other data types...

    Private Declare Function CallWindowProc Lib "user32" _
       Alias "CallWindowProcA" _
       (ByVal wndProc As VarPtrCallbackDelegate, ByRef var As IDispatchVTable,
       ByVal unused1 As Integer, ByVal unused2 As Integer,
       ByVal unused3 As Integer) As Integer
    Private Declare Function CallWindowProc Lib "user32" _
       Alias "CallWindowProcA" _
       (ByVal wndProc As VarPtrCallbackDelegate, ByRef var As Long,
       ByVal unused1 As Integer, ByVal unused2 As Integer,
       ByVal unused3 As Integer) As Integer
    Private Declare Function CallWindowProc Lib "user32" _
       Alias "CallWindowProcA" _
       (ByVal wndProc As VarPtrCallbackDelegate, ByRef var As IntPtr,
       ByVal unused1 As Integer, ByVal unused2 As Integer,
       ByVal unused3 As Integer) As Integer

    ' the method that is indirectly executed when calling CallVarPtrSupport 
    ' notice that 1st argument is declared by-value (this is the
    ' argument that receives the 2nd value passed to CallVarPtrSupport)
    Private Function VarPtrCallback(ByVal address As Integer,
          ByVal unused1 As Integer, ByVal unused2 As Integer,
          ByVal unused3 As Integer) As Integer
        Return address
    End Function

    ' two overloads of VarPtr
    Public Function VarPtr(ByRef var As Short) As Integer
        Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
    End Function
    Public Function VarPtr(ByRef var As Integer) As Integer
        Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
    End Function
    Public Function VarPtr(ByRef var As IDispatchVTable) As Integer
        Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
    End Function
    Public Function VarPtr(ByRef var As Long) As Integer
        Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
    End Function
    Public Function VarPtr(ByRef var As IntPtr) As Integer
        Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
    End Function
    ' ...add more overload to support other data types...
End Module

现在我得到错误(我在代码中添加了注释): 错误:托管调试助手'InvalidVariant':'在从非托管VARIANT到托管对象的转换过程中检测到无效的VARIANT。将无效的VARIANT传递给CLR可能会导致意外的异常,损坏或数据丢失。

但整体而言......我实际上不确定我是否正确地将正确转换VBA代码放在正确的轨道上,因为我不必安装excel来测试VBA。

该代码实质上创建了一个动态COM对象,然后用于获取扩展文件属性。

如果有人能告诉我我做错了什么,我们将不胜感激。此外,代码需要在.Net中,而不是导入任何VBA / VB DLL。

答案

在参考@ Jimi的评论时,我已经为你创建了几个vba函数。

这是vba代码,您可以将其粘贴到excel“ThisWorkbook”对象中。

它将在与传递给它的文件相同的目录中创建文本文件名“ExtendedProperties.txt”。

    Sub GetExtendedProperties(strInFullFilePath)
        Dim objShell As Object
        Dim objFolder As Object
        Dim objFolderItem As Object
        Dim strPath As String
        Dim strFldr As String
        Dim vntInfo As Variant
        Dim intI As Integer
        Dim strName As String
        Dim strTemp As String
        Dim fso As Object
        Dim strOut As String
        Dim ts As Object

        Set fso = CreateObject("Scripting.FileSystemObject")

        strPath = fso.GetAbsolutePathName(strInFullFilePath)
        strFldr = fso.GetParentFolderName(strPath)
        strName = fso.GetFileName(strPath)

        strOut = strFldr & "ExtendedProperties.txt"

        Set ts = fso.CreateTextFile(strOut, True)

        Set objShell = CreateObject("shell.application")

        If (Not (objShell Is Nothing)) Then

            Set objFolder = objShell.Namespace(CStr(strFldr))

            If (Not (objFolder Is Nothing)) Then
                Set objFolderItem = objFolder.ParseName(CStr(strName))
                If (Not (objFolderItem Is Nothing)) Then

                    For intI = 0 To 321
                    If intI <> 31 Then
                        vntInfo = objFolder.GetDetailsOf(Nothing, intI)
                        strTemp = CStr(vntInfo)
                        If (InStr(1, strTemp, vbNull) > 0) Then strTemp = Replace(strTemp, vbNull, "")
                        If IsNull(strTemp) = False Then
                            ts.WriteLine "File Detail Attribute: " & CheckString(strTemp)
                        Else
                            ts.WriteLine "File Detail Attribute: NULL"
                        End If

                        vntInfo = objFolder.GetDetailsOf(objFolderItem, intI)
                        strTemp = CStr(vntInfo)
                        If (InStr(1, strTemp, vbNull) > 0) Then strTemp = Replace(strTemp, vbNull, "")
                        If IsNull(strTemp) = False Then
                            ts.WriteLine "Value: """ & CheckString(strTemp) & """"
                        Else
                            ts.WriteLine "Value: NULL"
                        End If
                        End If
                    Next intI
                End If
                Set objFolderItem = Nothing
            End If
            Set objFolder = Nothing
        End If

        ts.Close
        Set ts = Nothing

        Set objShell = Nothing
    End Sub

    Private Function CheckString(strInString As String) As String
        Dim strOut As String
        Dim strTemp As String
        Dim blnValid As Boolean
        Dim intI As Integer
        Dim intJ As Integer
        Dim strChar As String
        Dim bytChars() As Byte


        'This Function is used to check the string to see if there are any problem
        '  characters in the string (as there are at intI=31 in the above function).

        strTemp = strInString

        strOut = ""
        For intI = 1 To Len(strTemp)
            strChar = Mid(strTemp, intI, 1)

            If (AscW(strChar) = 32) Or (AscW(strChar) >= 48) And (AscW(strChar) <= 57) Or _
                (AscW(strChar) >= 65) And (AscW(strChar) <= 90) Or _
                (AscW(strChar) >= 97) And (AscW(strChar) <= 122) Then
                strOut = strOut & strChar
            End If
        Next intI

        CheckString = strOut
    End Function

以上是关于如何将VARIANT转换为托管对象?的主要内容,如果未能解决你的问题,请参考以下文章

如何将 boost::hana::tuple 转换为 std::variant

将 VARIANT 转换为字节,反之亦然? [复制]

C++ 和 .NET - 从 'System::String ^' 转换为 '_variant_t'

如何快速将核心数据托管对象数组转换为“可识别”列表? (Xcode 11,测试版 5)

在java中运行时将DBus Variant的值转换为正确的类型

从 C# 如何调用需要 *VARIANT 参数的非托管 OLE 接口?