这是原始VBA代码的来源：原始VBA代码
我正在将这些函数转换为VB.Net
FilePropertyExplorer
类别初始化
这是我迄今为止的代码(注意，为了简洁起见，我删除了一些行)
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