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

时间:2019-01-22 08:22:15

标签: vba vb.net 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可能会导致意外的异常,损坏或数据丢失。'

但是总的来说...我实际上不确定Im是否在正确转换VBA代码方面是否正确,因为Im必须这样做,例如没有安装excel来测试VBA。

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

如果有人可以告诉我我做错了什么,将不胜感激。此外,代码还必须位于.Net中,并且不能导入任何VBA / VB dll。

1 个答案:

答案 0 :(得分:0)

关于@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