Question

Это источник исходного кода VBA: Оригинальный код VBA

Я преобразую эти функции в VB.Net

Вот код, который у меня есть до сих пор (заметьте, я для краткости удалил несколько строк)

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.

IAmNerd2000 · Answer 1 · 23 января 2019

Что касается комментария @ 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 в управляемый объект?

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

1 Ответ

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Как мне преобразовать VARIANT в управляемый объект?

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

1 Ответ

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Похожие темы