I am using some interesting code to perform dynamic unmanaged dll calling:
Imports System.Runtime.InteropServices
Module NativeMethods
Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal dllToLoad As String) As IntPtr
Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As IntPtr, ByVal procedureName As String) As IntPtr
Declare Function FreeLibrary Lib "kernel32" (ByVal hModule As IntPtr) As Boolean
End Module
Module Program
<UnmanagedFunctionPointer(CallingConvention.Cdecl)> _
Delegate Function MultiplyByTen(ByVal numberToMultiply As Integer) As Integer
Sub Main()
Dim pDll As IntPtr = NativeMethods.LoadLibrary("MultiplyByTen.dll")
Dim pAddressOfFunctionToCall As IntPtr = NativeMethods.GetProcAddress(pDll, "MultiplyByTen")
Dim multiplyByTen As MultiplyByTen = DirectCast(Marshal.GetDelegateForFunctionPointer(pAddressOfFunctionToCall, GetType(MultiplyByTen)), MultiplyByTen)
Dim theResult As Integer = multiplyByTen(10)
Console.WriteLine(theResult)
NativeMethods.FreeLibrary(pAddressOfFunctionToCall)
End Sub
End Module
I want to be able to change the parameter signature and type of the delegate to void or to a function returning integer, string, or boolean.
Basically, I want my program (interpreter) to be able to call upon any method in any unmanaged dll that the programmer has access to... since I cannot predict what method the programmer will want to have access to - I'd like to enable them to have access to any useful method.
This seems like it's possible in vb.net - perhaps with reflection? - but I'm just not sure how to do it.
--- EDIT: Here's what I've come up with:
<UnmanagedFunctionPointer(CallingConvention.Cdecl)> _
Delegate Function DelegateInteger(<[ParamArray]()> ByVal args() As Object) As Integer
...
Dim GetStdHandle = NativeDllCallIntegerMethod("kernel32", "GetStdHandle", -11)
...
Function NativeDllCallIntegerMethod(ByVal DllPath As String, ByVal DllMethod As String, ByVal ParamArray Arguments() As Object) As Integer
Dim pDll As IntPtr = NativeMethods.LoadLibrary(DllPath)
Dim pAddressOfFunctionToCall As IntPtr = NativeMethods.GetProcAddress(pDll, DllMethod)
Dim IntegerFunction As DelegateInteger = DirectCast(Marshal.GetDelegateForFunctionPointer(pAddressOfFunctionToCall, GetType(DelegateInteger)), DelegateInteger)
Dim theResult As Object = IntegerFunction.DynamicInvoke(Arguments)
NativeDllCallIntegerMethod = theResult
NativeMethods.FreeLibrary(pAddressOfFunctionToCall)
End Function
This raises a complaint on the line with 'Dim theResult = ...' on it. The error is "Object of type 'System.Int32' cannot be converted to type 'System.Object[]'."
I seem to be getting somewhere but... where? I don't really know.
I've got it. I can now dynamically call methods:
Imports System
Imports System.Reflection
Imports System.Reflection.Emit
Imports System.Runtime.InteropServices
Module DynamicInvocation
Sub Main()
Dim DI As New DynamicInvoke
DI.Invoke("FreeConsole", "Kernel32", GetType(Boolean), Nothing)
DI.Invoke("AllocConsole", "Kernel32", GetType(Boolean), Nothing)
Dim StandardOutputHandle = DI.Invoke("GetStdHandle", "Kernel32", GetType(Integer), -11)
DI.Invoke("WriteConsoleA", "Kernel32", GetType(Integer), StandardOutputHandle, "Testing!", 8, 0, 0)
End Sub
End Module
Public Class DynamicInvoke
', Optional ByVal AssemblyName As String = "DynamicInvoke", Optional ByVal TypeName As String = "DynamicType", Optional ByVal Convention As CallingConvention = CallingConvention.Winapi, Optional ByVal CharacterSet As CharSet = CharSet.Ansi
Public AssemblyName As String = "DynamicInvoke"
Public TypeName As String = "DynamicType"
Public Convention As CallingConvention = CallingConvention.Winapi
Public CharacterSet As CharSet = CharSet.Ansi
Function Invoke(ByVal MethodName As String, ByVal LibraryName As String, ByVal ReturnType As Type, ByVal ParamArray Parameters() As Object)
Dim ParameterTypesArray As Array
If Parameters IsNot Nothing Then
ParameterTypesArray = Array.CreateInstance(GetType(Type), Parameters.Length)
Dim PTIndex As Integer = 0
For Each Item In Parameters
If Item IsNot Nothing Then
ParameterTypesArray(PTIndex) = Item.GetType
Else
'ParameterTypesArray(PTIndex) = 0
End If
PTIndex += 1
Next
Else
ParameterTypesArray = Nothing
End If
Dim ParameterTypes() As Type = ParameterTypesArray
Dim asmName As New AssemblyName(AssemblyName)
Dim dynamicAsm As AssemblyBuilder = _
AppDomain.CurrentDomain.DefineDynamicAssembly(asmName, _
AssemblyBuilderAccess.RunAndSave)
' Create the module.
Dim dynamicMod As ModuleBuilder = _
dynamicAsm.DefineDynamicModule(asmName.Name, asmName.Name & ".dll")
' Create the TypeBuilder for the class that will contain the
' signature for the PInvoke call.
Dim tb As TypeBuilder = dynamicMod.DefineType(TypeName, _
TypeAttributes.Public Or TypeAttributes.UnicodeClass)
Dim mb As MethodBuilder = tb.DefinePInvokeMethod( _
MethodName, _
LibraryName, _
MethodAttributes.Public Or MethodAttributes.Static Or MethodAttributes.PinvokeImpl, _
CallingConventions.Standard, _
ReturnType, _
ParameterTypes, _
Convention, _
CharacterSet)
' Add PreserveSig to the method implementation flags. NOTE: If this line
' is commented out, the return value will be zero when the method is
' invoked.
mb.SetImplementationFlags( _
mb.GetMethodImplementationFlags() Or MethodImplAttributes.PreserveSig)
' The PInvoke method does not have a method body.
' Create the class and test the method.
Dim t As Type = tb.CreateType()
Dim mi As MethodInfo = t.GetMethod(MethodName)
Return mi.Invoke(Me, Parameters)
'' Produce the .dll file.
'Console.WriteLine("Saving: " & asmName.Name & ".dll")
'dynamicAsm.Save(asmName.Name & ".dll")
End Function
End Class
Related
This is the source of the original VBA code: Original VBA code
Im converting these functions to VB.Net
FilePropertyExplorer
Class_Initialize
Heres the code I have thus far (note I removed some lines for brevity)
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 . Im unsure of this code. Found it on the internet and slightly modified it
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
Now I currently get the error (I placed a comment in the code):
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.'
But overall... Im actually unsure if Im even on the right track in properly converting the VBA code as Im having to do it without for example excel installed to test the VBA out on.
The code essentially creates a dynamic COM object which will then be used to fetch extended file properties.
If someone could perhaps tell me what Im doing wrong it will be appreciated. Also the code needs to be in .Net and not import any VBA/VB dll's.
In reference to #Jimi's comment, I have created a couple of vba functions for you.
Here is the vba Code which you can just paste into an excel "ThisWorkbook" object.
It will create a text file name "ExtendedProperties.txt" in the same directory as the file that is passed to it.
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
I'm working on programm on VB.net to retrieve data from Firefox browser. I have an error while trying to use "PK11SDR_Decrypt" method from nss3.lib. "PK11SDR_Decrypt" returns -1. I don't have master password. I think that the problem in Ctypes/marshalling/base64 decoding. This is the code of function.
Public Function DecryptFF(ByVal str As String)
On Error Resume Next
Dim tSecDec As New TSECItem
Dim e As Integer
Dim sb As New System.Text.StringBuilder(str)
Dim hi2 As Integer = NSSBase64_DecodeBuffer(IntPtr.Zero, IntPtr.Zero, sb, sb.Length)
Dim item As TSECItem = DirectCast(Marshal.PtrToStructure(New IntPtr(hi2), GetType(TSECItem)), TSECItem)
e = PK11SDR_Decrypt(item, tSecDec, 0)
If e = 0 Then
If tSecDec.SECItemLen <> 0 Then
Dim mozDecryptedData = New Byte(tSecDec.SECItemLen - 1) {}
Marshal.Copy(New IntPtr(tSecDec.SECItemData), mozDecryptedData, 0, tSecDec.SECItemLen)
Return Encoding.UTF8.GetString(mozDecryptedData)
End If
End If
Return String.Empty
End Function
And other code part.
Public NSS3 As IntPtr
Public hModuleList As New List(Of IntPtr)
<StructLayout(LayoutKind.Sequential)>
Public Structure TSECItem
Public SECItemType As Integer
Public SECItemData As Integer
Public SECItemLen As Integer
End Structure
Public Function NSS_Init(ByVal configdir As String) As Long
Dim PathM = FindFirefoxInstallationPath()
hModuleList.Add(LoadLibrary(PathM & "\msvcp140.dll"))
hModuleList.Add(LoadLibrary(PathM & "\mozglue.dll"))
hModuleList.Add(LoadLibrary(PathM & "\mozavutils.dll"))
NSS3 = LoadLibrary(PathM & "\nss3.dll")
hModuleList.Add(NSS3)
Return CreateAPI(Of DLLFunctionDelegate)(NSS3, "NSS_Init")(configdir)
End Function
Public Function CreateAPI(Of T)(ByVal hModule As IntPtr, ByVal method As String) As T 'Simple overload to avoid loading the same library every time
Return DirectCast(DirectCast(Marshal.GetDelegateForFunctionPointer(GetProcAddress(hModule, method), GetType(T)), Object), T)
End Function
Public Function NSSBase64_DecodeBuffer(ByVal arenaOpt As IntPtr, ByVal outItemOpt As IntPtr, ByVal inStr As System.Text.StringBuilder, ByVal inLen As Integer) As Integer
Dim pProc As IntPtr = GetProcAddress(NSS3, "NSSBase64_DecodeBuffer")
Dim dll As DLLFunctionDelegate4 = DirectCast(Runtime.InteropServices.Marshal.GetDelegateForFunctionPointer(pProc, GetType(DLLFunctionDelegate4)), DLLFunctionDelegate4)
Return dll(arenaOpt, outItemOpt, inStr, inLen)
End Function
Public Function PK11SDR_Decrypt(ByRef data As TSECItem, ByRef result As TSECItem, ByVal cx As Integer) As Integer
Dim pProc As IntPtr = GetProcAddress(NSS3, "PK11SDR_Decrypt")
Dim dll As DLLFunctionDelegate5 = DirectCast(Marshal.GetDelegateForFunctionPointer(pProc, GetType(DLLFunctionDelegate5)), DLLFunctionDelegate5)
Return dll(data, result, cx)
End Function
<UnmanagedFunctionPointer(CallingConvention.Cdecl)>
Public Delegate Function DLLFunctionDelegate5(ByRef data As TSECItem, ByRef result As TSECItem, ByVal cx As Integer) As Integer
<UnmanagedFunctionPointer(CallingConvention.Cdecl)>
Public Delegate Function DLLFunctionDelegate6() As Long
Public Function NSS_Shutdown() As Long
Return CreateAPI(Of DLLFunctionDelegate6)(NSS3, "NSS_Shutdown")()
End Function
<DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
Public Shared Function LoadLibrary(ByVal dllFilePath As String) As IntPtr
End Function
<DllImport("kernel32.dll", SetLastError:=True, EntryPoint:="FreeLibrary")>
Public Shared Function FreeLibrary(ByVal hModule As IntPtr) As Boolean
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
DecryptFF get as argument the encrypted login fron logins.json file. Here is the part of code
Dim JSONRegex As New Regex("\""(hostname|encryptedPassword|encryptedUsername)"":""(.*?)""")
Dim mozMC = JSONRegex.Matches(Logins)
For I = 0 To mozMC.Count - 1 Step 3
Dim host = mozMC(I).Groups(2).Value
Dim usr = mozMC(I + 1).Groups(2).Value
Dim pas = mozMC(I + 2).Groups(2).Value
Account = (DecryptFF(usr))
Thank you for your help!
Trying to convert VB6 line of code to VB.net. Code will serve as identification if printer is OFF or ON
Thanks
"PRINTERFOUND = OpenPrinterW(StrPtr(PrinterName), hPrinter)" Particular StrPtr function...
Can't get OpenPrinter to work - Tries to print I simply want to to know if printer is OFF or ON
changing line to
PRINTERFOUND = OpenPrinterW(PrinterName.Normalize(), hPrinter, Nothing)
does not work, thanks
Tried to convert VB6 declaration to VB.net per previous suggestions but it still a same error cant convert String to Integer please see below
'Private Declare Function GetPrinterApi Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, ByRef BUFFER As Long, ByVal pbSize As Long, ByRef pbSizeNeeded As Long) As Long
<DllImport("winspool.Drv", EntryPoint:="GetPrinterA", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Function GetPrinterApi(<MarshalAs(UnmanagedType.LPStr)> ByVal hPrinter As String, ByVal Level As IntPtr, ByVal BUFFER As IntPtr, ByVal pbSize As IntPtr, ByRef pbSizeNeeded As IntPtr) As Boolean
End Function
'Private Declare Function OpenPrinterW Lib "winspool.drv" (ByVal pPrinterName As Long, ByRef phPrinter As Long, Optional ByVal pDefault As Long = 0) As Long
<DllImport("winspool.Drv", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Function OpenPrinterW(ByVal pPrinterName As IntPtr, ByVal phPrinter As Int32, <[In](), MarshalAs(UnmanagedType.LPStruct)> ByVal pDefault As IntPtr) As Boolean
End Function
'Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
<DllImport("winspool.Drv", EntryPoint:="ClosePrinter", SetLastError:=True, ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Function ClosePrinter(ByVal hPrinter As IntPtr) As Boolean
End Function
'Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Long, ByRef Source As Long, ByVal Length As Long)
<DllImport("kernel32.dll", SetLastError:=True, EntryPoint:="RtlMoveMemory")> _
Public Function CopyMemory(ByRef Destination As Long, ByVal Source As IntPtr, ByVal Length As String) As IntPtr
End Function
Full code Below
'Acknowledgements : This program has been written making extensive use of the
'Merrion article http://www.merrioncomputing.com/Programming/PrintStatus.htm
'It has also benefited from the contributors to VBForums thread # 733849
'http://www.vbforums.com/showthread.php?t=733849&goto=newpost - especially the code
'suggested by "Bonnie West"
'Program written 14 Sept. 2013 by C.A. Moore
Option Explicit
Dim PRINTERFOUND As Long
Dim GETPRINTER As Long
Dim BUFFER() As Long
Dim pbSizeNeeded As Long
Dim PRINTERINFO As PRINTER_INFO_2
Dim N As Integer
Dim M As Integer
Dim CHAR As String
Dim prnPrinter As Printer
Dim BUF13BINARY As String
' Note : PRINTERREADY as an Integer variable is Dim'd
'"Public PRINTERREADY As Integer" at Form1 Option Explicit
Private Type PRINTER_INFO_2
pServerName As String
pPrinterName As String
pShareName As String
pPortName As String
pDriverName As String
pComment As String
pLocation As String
pDevMode As Long
pSepFile As String
pPrintProcessor As String
pDatatype As String
pParameters As String
pSecurityDescriptor As Long
Attributes As Long
Priority As Long
DefaultPriority As Long
StartTime As Long
UntilTime As Long
Status As Long
JobsCount As Long
AveragePPM As Long
End Type
Private Declare Function GetPrinterApi Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, BUFFER As Long, ByVal pbSize As Long, pbSizeNeeded As Long) As Long
Private Declare Function OpenPrinterW Lib "winspool.drv" (ByVal pPrinterName As Long, ByRef phPrinter As Long, Optional ByVal pDefault As Long) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Function StringFromPointer(lpString As Long, lMaxLength As Long) As String
'this service function extracts a string (sRet) when fed with a pointer (lpstring)
'from a buffer
Dim sRet As String
Dim lret As Long
If lpString = 0 Then
StringFromPointer = ""
Exit Function
End If
'\\ Pre-initialise the return string...
sRet = Space$(lMaxLength)
CopyMemory ByVal sRet, ByVal lpString, ByVal Len(sRet)
If Err.LastDllError = 0 Then
If InStr(sRet, Chr$(0)) > 0 Then
sRet = Left$(sRet, InStr(sRet, Chr$(0)) - 1)
End If
End If
StringFromPointer = sRet
End Function
Public Function IsPrinterReady(ByRef PrinterName As String)
Form1.PRINTERREADY = 0
'first select the named printer and check if it is installed
For Each prnPrinter In Printers
CHAR = prnPrinter.DeviceName
If CHAR = PrinterName Then
Set Printer = prnPrinter 'sets this as printer
Form1.PRINTERREADY = 1
End If
Next
If Form1.PRINTERREADY = 0 Then GoTo Line1000 'exit. printer not installed
Dim hPrinter As Long
Dim PI6 As PRINTER_INFO_2
PRINTERFOUND = 0
Form1.PRINTERREADY = 0
PRINTERFOUND = OpenPrinterW(StrPtr(PrinterName), hPrinter)
'(OpenPrinterW(ByVal pPrinterName As Long, ByRef phPrinter As Long) As Long)
If PRINTERFOUND = 0 Then 'ie. printer not found
Form1.PRINTERREADY = 0
Debug.Assert ClosePrinter(hPrinter)
GoTo Line100
End If
'If we get here named printer was found and accessed and its hPrinter handle is
'known
'Dim BUFFER() As Long
'Dim pbSizeNeeded As Long
ReDim Preserve BUFFER(0 To 1) As Long
GETPRINTER = GetPrinterApi(hPrinter, 2&, BUFFER(0), UBound(BUFFER), pbSizeNeeded)
ReDim Preserve BUFFER(0 To (pbSizeNeeded / 4) + 3) As Long
GETPRINTER = GetPrinterApi(hPrinter, 2&, BUFFER(0), UBound(BUFFER) * 4, pbSizeNeeded)
If GETPRINTER = 0 Then 'ie. some problem with printer access
Form1.PRINTERREADY = 0
GoTo Line100
End If
'If we get here then GETPRINTER = 1, ie. printer found and accessed OK
With PRINTERINFO '\\ This variable is of type PRINTER_INFO_2
'These quantities are defined here because the Merrion article
'so specifies. However they are not used by this program, and most
'have been found to be void
.pServerName = StringFromPointer(BUFFER(0), 1024)
.pPrinterName = StringFromPointer(BUFFER(1), 1024)
.pShareName = StringFromPointer(BUFFER(2), 1024)
.pPortName = StringFromPointer(BUFFER(3), 1024)
.pDriverName = StringFromPointer(BUFFER(4), 1024)
.pComment = StringFromPointer(BUFFER(5), 1024)
.pLocation = StringFromPointer(BUFFER(6), 1024)
.pDevMode = BUFFER(7)
.pSepFile = StringFromPointer(BUFFER(8), 1024)
.pPrintProcessor = StringFromPointer(BUFFER(9), 1024)
.pDatatype = StringFromPointer(BUFFER(10), 1024)
.pParameters = StringFromPointer(BUFFER(11), 1024)
.pSecurityDescriptor = BUFFER(12)
.Attributes = BUFFER(13)
.Priority = BUFFER(14)
.DefaultPriority = BUFFER(15)
.StartTime = BUFFER(16)
.UntilTime = BUFFER(17)
.Status = BUFFER(18)
.JobsCount = BUFFER(19)
.AveragePPM = BUFFER(20)
End With
'This next code is for interest and program development only.
'It writes into List1 the value of each buffer 1 - 20
'To by-pass it, add a "Go To Line15" statement at this point.
Form1.List1.Clear
N = 0
Line5:
On Error GoTo Line15
Form1.List1.AddItem "Buffer No. " & N & " Buffer Value " & BUFFER(N)
N = (N + 1)
If N = 21 Then GoTo Line15
GoTo Line5
'Now to convert the decimal value of Buffer(13) into a binary
'bit pattern and store this in BUF13BINARY
Line15: 'and to show Buffer(13) as a binary bit pattern at Form1.Label1
N = BUFFER(13)
BUF13BINARY = ""
M = 4196
Line16:
If N < M Then
BUF13BINARY = BUF13BINARY & "0"
GoTo Line20
End If
BUF13BINARY = BUF13BINARY & "1"
N = (N - M)
Line20:
If M = 1 Then GoTo Line10
M = M / 2
GoTo Line16
Line10: 'BUF13BINARY is now the 13 bit binary value of Buffer(13)
'eg. 0011000100010
Form1.Label1.Caption = BUF13BINARY 'display this binary value at form 1
'we now examine the value of the third binary bit in BUF13BINARY
If Mid$(BUF13BINARY, 3, 1) = "0" Then Form1.PRINTERREADY = 1
If Mid$(BUF13BINARY, 3, 1) = "1" Then Form1.PRINTERREADY = 0
Line100:
ClosePrinter (hPrinter)
Line1000:
End Function
and
Option Explicit
Public PRINTERREADY As Integer
Private Sub Command1_Click()
IsPrinterReady ("Brother QL-500")
'IsPrinterReady ("EPSON Stylus CX5400")
MsgBox PRINTERREADY '0 = Not Ready 1 = Ready
End Sub
You cannot convert VarPtr, StrPtr, or ObjPtr, because in .NET you do not directly control memory. These functions were used to extract a pointer from an instance, a variable, or a Unicode string. But in .NET, object locations in memory is managed by the garbage collector, and the GC can move objects around in memory at any time.
Consider the following code, but do not use it! I put it here only to explain why these functions do not exist in .NET.
Private Function VarPtr(ByVal obj As Object) As Integer
' Obtain a pinned handle to the object
Dim handle As GCHandle = GCHandle.Alloc(obj, GCHandleType.Pinned)
Dim pointer As Integer = handle.AddrOfPinnedObject.ToInt32
' Free the allocated handle. At this point the GC can move the object in memory, this is
' why this function does not exist in .NET. If you were to use this pointer as a destination
' for memcopy for example, you could overwrite unintended memory, which would crash the
' application or cause unexpected behavior. For this function to work you would need to
' maintain the handle until after you are finished using it.
handle.Free()
Return pointer
End Function
Edit:
The correct way to get the printer status is through the managed interface for it, in this case through WMI:
Imports System.Management
Public Class Form1
Private Enum PrinterStatus As Integer
Other = 1
Unknown = 2
Idle = 3
Printing = 4
Warmup = 5
Stopped = 6
Offline = 7
End Enum
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dim mos = New ManagementObjectSearcher("SELECT * FROM Win32_Printer")
For Each p In mos.Get()
Debug.Print(p.Properties("Name").Value.ToString() & " : " & CType(CInt(p.Properties("PrinterStatus").Value), PrinterStatus).ToString())
Next
End Sub
End Class
You can get more information about the Win32_Printer class here: https://msdn.microsoft.com/en-us/library/aa394363(v=vs.85).aspx
In particular take note of this:
Note If you are retrieving PrinterStatus = 3 or PrinterState = 0, the
printer driver may not be feeding accurate information into WMI. WMI
retrieves the printer information from the spoolsv.exe process. It is
possible the printer driver does not report its status to the spooler.
In this case, Win32_Printer reports the printer as Idle.
From there you can get information about and manage just about any peripheral connected. Just figure out the appropriate WMI classes and read up on the docs.
Thanks Everyone, especially Drunken Code Monkey for all the information provided, I was able to finally achieve what I wanted after reading on https://msdn.microsoft.com/en-us/library/aa394363(v=vs.85).aspx figured need to is boolean WorkOffline; Pew... made it more simple then VB6 language even using that feels kinda hmm old. Also lucky me found codes that did the same thing as I wanted here is link to VB.NET "https://bytes.com/topic/visual-basic-net/answers/524957-detecting-if-printer-connected-pc" And my modification of this code below
Imports System.Management
Public Class Form1
Public Class CheckPrinterStatus
Public Function PrinterIsOnline(ByVal sPrinterName As String) As Boolean
'// Set management scope
Dim scope As ManagementScope = New ManagementScope("\root\cimv2")
scope.Connect()
'// Select Printers from WMI Object Collections
Dim searcher As ManagementObjectSearcher = New ManagementObjectSearcher("SELECT * FROM Win32_Printer")
Dim printerName As String = String.Empty
For Each printer As ManagementObject In searcher.Get()
printerName = printer("Name").ToString() '.ToLower()
If (printerName.Equals(sPrinterName)) Then
MsgBox(printerName)
If (printer("WorkOffline").ToString().ToLower().Equals("true")) Then
MsgBox("Offline")
' Printer is offline by user
Return False
Else
' Printer is not offline
MsgBox("Online")
Return True
End If
End If
Next
Return False
End Function ' PrinterIsOnline
End Class
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Dim PrinterSatus As New CheckPrinterStatus
PrinterSatus.PrinterIsOnline("Brother QL-500") 'Name of The printer HERE
End Sub
End Class
I have taken parts of the code from Shazzam Shader Editor (http://shazzam.codeplex.com/) and modified the code to use the Compile From file instead of memory
(https://msdn.microsoft.com/en-us/library/windows/desktop/hh446872(v=vs.85).aspx)
<Guid("8BA5FB08-5195-40e2-AC58-0D989C3A0102"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> _
Private Interface ID3DBlob
<PreserveSig> _
Function GetBufferPointer() As IntPtr
<PreserveSig> _
Function GetBufferSize() As Integer
End Interface
<PreserveSig> _
<DllImport("d3dcompiler_47.dll", CharSet:=CharSet.Auto, CallingConvention:=CallingConvention.Cdecl)> _
Private Function D3DCompileFromFile(<MarshalAs(UnmanagedType.LPTStr)> pFilename As String,
pDefines As IntPtr,
pInclude As IntPtr,
<MarshalAs(UnmanagedType.LPTStr)> pEntrypoint As String,
<MarshalAs(UnmanagedType.LPTStr)> pTarget As String,
flags1 As Integer,
flags2 As Integer,
ByRef ppCode As ID3DBlob,
ByRef ppErrorMsgs As ID3DBlob) As Integer
End Function
Public Sub Compile(ByVal File As HLSLFileHelperClass)
Dim pFilename As String = File.GetSourceFileFullName ' C:\MyPSFiles\GaussianFilter.fx
Dim pDefines As IntPtr = IntPtr.Zero
Dim pInclude As IntPtr = IntPtr.Zero
Dim pEntrypoint As String = File.HLSLEntryPoint ' main
Dim pTarget As String = File.ShaderCompilerVersion.ToString ' ps_3_0
Dim flags1 As Integer = 0
Dim flags2 As Integer = 0
Dim ppCode As ID3DBlob
Dim ppErrorMsgs As ID3DBlob
Dim CompileResult As Integer = 0
CompileResult = D3DCompileFromFile(pFilename,
pDefines,
pInclude,
pEntrypoint,
pTarget,
flags1,
flags2,
ppCode,
ppErrorMsgs)
If CompileResult <> 0 Then
Dim errors As IntPtr = ppErrorMsgs.GetBufferPointer()
Dim size As Integer = ppErrorMsgs.GetBufferSize()
ErrorText = Marshal.PtrToStringAnsi(errors)
IsCompiled = False
Else
ErrorText = ""
IsCompiled = True
Dim psPath = File.GetCompiledFileFullName
Dim pCompiledPs As IntPtr = ppCode.GetBufferPointer()
Dim compiledPsSize As Integer = ppCode.GetBufferSize()
Dim compiledPs = New Byte(compiledPsSize - 1) {}
Marshal.Copy(pCompiledPs, compiledPs, 0, compiledPs.Length)
Using psFile = IO.File.Open(psPath, FileMode.Create, FileAccess.Write)
psFile.Write(compiledPs, 0, compiledPs.Length)
End Using
End If
If ppCode IsNot Nothing Then
Marshal.ReleaseComObject(ppCode)
End If
ppCode = Nothing
If ppErrorMsgs IsNot Nothing Then
Marshal.ReleaseComObject(ppErrorMsgs)
End If
ppErrorMsgs = Nothing
End Sub
The code as it is now gives me the error:
A call to PInvoke function '::D3DCompileFromFile' has
unbalanced the stack. This is likely because the managed PInvoke
signature does not match the unmanaged target signature. Check that
the calling convention and parameters of the PInvoke signature match
the target unmanaged signature.
If I remove the line:
CallingConvention:=CallingConvention.Cdecl
The compiler seems to run, but now I get the error message:
X3506 unrecognized compiler target 'p'
It seems to just read the first char in the string? So, what am I doing wrong here?
Got it working and I did two things:
First I moved it all into a Module:
Module Extend
<Guid("8BA5FB08-5195-40e2-AC58-0D989C3A0102"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> _
Public Interface ID3DBlob
<PreserveSig> _
Function GetBufferPointer() As IntPtr
<PreserveSig> _
Function GetBufferSize() As Integer
End Interface
<PreserveSig> _
<DllImport("d3dcompiler_47.dll", CharSet:=CharSet.Auto)> _
Public Function D3DCompileFromFile(<MarshalAs(UnmanagedType.LPTStr)> pFilename As String,
pDefines As IntPtr,
pInclude As IntPtr,
<MarshalAs(UnmanagedType.LPStr)> pEntrypoint As String,
<MarshalAs(UnmanagedType.LPStr)> pTarget As String,
flags1 As Integer,
flags2 As Integer,
ByRef ppCode As ID3DBlob,
ByRef ppErrorMsgs As ID3DBlob) As Integer
End Function
End Module
Secondly I changed the:
<MarshalAs(UnmanagedType.LPTStr)>
to
<MarshalAs(UnmanagedType.LPStr)>
Seems I got a bit frustrated and changed things that worked too :S
I'm trying to send structured data from a VB 2010 app that I'm developing to an existing library which expects strings to be converted into byte arrays. I'm having trouble with the sending the data as byte arrays - I can send the plain string that should be converted to bytes to a test program that I've written.
Here are the two apps. Firstly the listener process:
Imports System.Runtime.InteropServices
Public Class frmTest
Protected Overrides Sub WndProc(ByRef m As System.Windows.Forms.Message)
If m.Msg = frmTest.WM_COPYDATA Then
Dim data As CopyData
Dim message As String
' get the data...
data = CType(m.GetLParam(GetType(CopyData)), CopyData)
message = data.lpData
' add the message
txtTest.Text = message
' let them know we processed the message...
m.Result = New IntPtr(1)
Else
MyBase.WndProc(m)
End If
End Sub
Private Function UnicodeBytesToString(ByVal bytes() As Byte) As String
Return System.Text.Encoding.Unicode.GetString(bytes)
End Function
Private Const WM_COPYDATA As Integer = &H4A
<StructLayout(LayoutKind.Sequential)> _
Private Structure CopyData
Public dwData As IntPtr
Public cbData As Integer
Public lpData As String
End Structure
End Class
Secondly the process that sends the data:
Imports System.Runtime.InteropServices
Imports System.Collections.Generic
Public Class frmMain
<StructLayout(LayoutKind.Sequential)> _
Private Structure CopyData
Public dwData As IntPtr
Public cbData As Integer
Public lpData As String
End Structure
Private Declare Auto Function SendMessage Lib "user32" _
(ByVal hWnd As IntPtr, _
ByVal Msg As Integer, _
ByVal wParam As IntPtr, _
ByRef lParam As CopyData) As Boolean
Private Declare Auto Function FindWindow Lib "user32" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As IntPtr
Private Const WM_COPYDATA As Integer = &H4A
Private Sub cmdSend_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdSend.Click
Dim ClientWindow As IntPtr
Dim a() As System.Diagnostics.Process = System.Diagnostics.Process.GetProcesses
For Each p In a
Console.WriteLine(p.ProcessName)
If p.ProcessName = "Listener" Then
ClientWindow = p.MainWindowHandle
Exit For
End If
Next
' make sure we found an active client window
If Not ClientWindow.Equals(IntPtr.Zero) Then
' if there is text to send
If txtText.Text.Length > 0 Then
Dim message As String = txtText.Text
Dim data As CopyData
' set up the data...
data.lpData = message
data.cbData = message.Length * Marshal.SystemDefaultCharSize
' send the data
frmMain.SendMessage(ClientWindow, frmMain.WM_COPYDATA, Me.Handle, data)
End If
Else
MsgBox("Could Not Find Active Client Window.")
End If
End Sub
Private Function UnicodeStringToBytes(
ByVal str As String) As Byte()
Return System.Text.Encoding.Unicode.GetBytes(str)
End Function
End Class
This all works but if I change 'Public lpData As String' to 'Public lpData As Byte()' in both and then amend 'data.lpData = message' to 'data.lpData = UnicodeStringToBytes(message)' in the sender process and 'message = data.lpData' to 'message = UnicodeBytesToString(data.lpData)' in the listener process it crashes.
How can I send a string encoded as a byte array from the sender to the listener so that the listener can decode it back to a string ?
I realise it would be easier to send the string as a string but the existing library needs it as a byte array so I'm trying to get my sender working against this test listener where I can see what's happening.
Thanks in advance !
Variable-length arrays in structures are always a pain.
Declare lpData as IntPtr in both applications.
Then in the sending app:
' set up the data...
Dim string_bytes = UnicodeStringToBytes(message)
Dim pinned = GCHandle.Alloc(string_bytes, GCHandleType.Pinned)
Try
data.dwData = New IntPtr(message.Length)
data.cbData = string_bytes.Length
data.lpData = pinned.AddrOfPinnedObject()
' send the data
frmMain.SendMessage(ClientWindow, frmMain.WM_COPYDATA, Me.Handle, data)
Finally
If pinned.IsAllocated Then pinned.Free()
End Try
In the receiving app:
' get the data...
data = CType(m.GetLParam(GetType(CopyData)), CopyData)
Dim message(0 To data.cbData - 1) As Byte
Marshal.Copy(data.lpData, message, 0, data.cbData)
' add the message
txtTest.Text = UnicodeBytesToString(message)