How to get whether a speaker plugged or unplugged - vb.net

I use Visual Studio 2013 for Visual Basic and I want to be able to test whether a speaker is plugged in or unplugged from the speaker jack. Is it possible?

It can be done with Device Topology API. IKsJackDescription interface can be used to get KSJACK_DESCRIPTION structure, which has IsConnected member. However, not every device supports cable presence detection, in case it doesn't the API will always report it's connected.
COM objects declarations
Imports System
Imports System.Collections.Generic
Imports System.Text
Imports System.Runtime.InteropServices
Imports System.IO
Imports System.Runtime.CompilerServices
Namespace com_test
Class Native
<DllImport("ole32.Dll")> _
Public Shared Function CoCreateInstance(ByRef clsid As Guid, <MarshalAs(UnmanagedType.IUnknown)> inner As Object, context As UInteger, ByRef uuid As Guid, <MarshalAs(UnmanagedType.IUnknown)> ByRef rReturnedComObject As Object) As UInteger
End Function
'************************************************************************
<DllImport("ole32.dll")> _
Private Shared Function PropVariantClear(ByRef pvar As PropVariant) As Integer
End Function
Public Const DEVICE_STATE_ACTIVE As Integer = &H1
Public Const DEVICE_STATE_DISABLE As Integer = &H2
Public Const DEVICE_STATE_NOTPRESENT As Integer = &H4
Public Const DEVICE_STATE_UNPLUGGED As Integer = &H8
Public Const DEVICE_STATEMASK_ALL As Integer = &Hf
Public Shared PKEY_Device_FriendlyName As New PROPERTYKEY(&Ha45c254eUI, &Hdf1c, &H4efd, &H80, &H20, &H67, _
&Hd1, &H46, &Ha8, &H50, &He0, 14)
Public Shared PKEY_AudioEndpoint_FormFactor As New PROPERTYKEY(&H1da5d803, &Hd492, &H4edd, &H8c, &H23, &He0, _
&Hc0, &Hff, &Hee, &H7f, &He, 0)
End Class
Enum EndpointFormFactor
RemoteNetworkDevice = 0
Speakers = (RemoteNetworkDevice + 1)
LineLevel = (Speakers + 1)
Headphones = (LineLevel + 1)
Microphone = (Headphones + 1)
Headset = (Microphone + 1)
Handset = (Headset + 1)
UnknownDigitalPassthrough = (Handset + 1)
SPDIF = (UnknownDigitalPassthrough + 1)
DigitalAudioDisplayDevice = (SPDIF + 1)
UnknownFormFactor = (DigitalAudioDisplayDevice + 1)
EndpointFormFactor_enum_count = (UnknownFormFactor + 1)
End Enum
Enum EPcxConnectionType
eConnTypeUnknown = 0
eConnType3Point5mm
eConnTypeQuarter
eConnTypeAtapiInternal
eConnTypeRCA
eConnTypeOptical
eConnTypeOtherDigital
eConnTypeOtherAnalog
eConnTypeMultichannelAnalogDIN
eConnTypeXlrProfessional
eConnTypeRJ11Modem
eConnTypeCombination
End Enum
Enum EPcxGeoLocation
eGeoLocRear = &H1
eGeoLocFront
eGeoLocLeft
eGeoLocRight
eGeoLocTop
eGeoLocBottom
eGeoLocRearPanel
eGeoLocRiser
eGeoLocInsideMobileLid
eGeoLocDrivebay
eGeoLocHDMI
eGeoLocOutsideMobileLid
eGeoLocATAPI
eGeoLocNotApplicable
eGeoLocReserved6
EPcxGeoLocation_enum_count
End Enum
Public Enum EDataFlow
eRender
eCapture
eAll
EDataFlow_enum_count
End Enum
Public Enum ERole
eConsole
eMultimedia
eCommunications
ERole_enum_count
End Enum
Public Enum CLSCTX
CLSCTX_INPROC_SERVER = &H1
CLSCTX_INPROC_HANDLER = &H2
CLSCTX_LOCAL_SERVER = &H4
CLSCTX_REMOTE_SERVER = &H10
CLSCTX_SERVER = (CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER Or CLSCTX_REMOTE_SERVER)
CLSCTX_ALL = (CLSCTX_INPROC_HANDLER Or CLSCTX_SERVER)
End Enum
'Windows Core Audio API declarations
'http://www.java2s.com/Code/CSharp/Windows/SoundUtils.htm
<Guid("0BD7A1BE-7A1A-44DB-8397-CC5392387B5E"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> _
Public Interface IMMDeviceCollection
Function GetCount(ByRef pcDevices As UInteger) As Integer
Function Item(nDevice As UInteger, <Out, MarshalAs(UnmanagedType.[Interface])> ByRef ppDevice As Object) As Integer
End Interface
<Guid("D666063F-1587-4E43-81F1-B948E807363F"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> _
Public Interface IMMDevice
Function Activate(ByRef iid As Guid, dwClsCtx As UInteger, pActivationParams As IntPtr, <Out, MarshalAs(UnmanagedType.[Interface])> ByRef ppInterface As Object) As Integer
Function OpenPropertyStore(stgmAccess As Integer, <Out, MarshalAs(UnmanagedType.[Interface])> ByRef ppProperties As Object) As Integer
Function GetId(ByRef ppstrId As StringBuilder) As Integer
Function GetState(ByRef pdwState As Integer) As Integer
End Interface
<ComImport, Guid("BCDE0395-E52F-467C-8E3D-C4579291692E")> _
Class MMDeviceEnumerator
End Class
<Guid("A95664D2-9614-4F35-A746-DE8DB63617E6"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> _
Public Interface IMMDeviceEnumerator
Function EnumAudioEndpoints(dataFlow As EDataFlow, dwStateMask As Integer, <Out, MarshalAs(UnmanagedType.[Interface])> ByRef ppDevices As Object) As Integer
Function GetDefaultAudioEndpoint(dataFlow As EDataFlow, role As ERole, <Out, MarshalAs(UnmanagedType.[Interface])> ByRef ppEndpoint As Object) As Integer
Function GetDevice(pwstrId As String, ByRef ppDevice As IntPtr) As Integer
Function RegisterEndpointNotificationCallback(pClient As IntPtr) As Integer
Function UnregisterEndpointNotificationCallback(pClient As IntPtr) As Integer
End Interface
'*********** Property store *****************************
' https://blogs.msdn.microsoft.com/adamroot/2008/04/11/interop-with-propvariants-in-net/
<ComImport, Guid("886D8EEB-8CF2-4446-8D02-CDBA1DBDCF99"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> _
Interface IPropertyStore
<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType := MethodCodeType.Runtime)> _
Sub GetCount(<Out> ByRef cProps As UInteger)
<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType := MethodCodeType.Runtime)> _
Sub GetAt(<[In]> iProp As UInteger, ByRef pkey As PROPERTYKEY)
<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType := MethodCodeType.Runtime)> _
Function GetValue(<[In]> ByRef key As PROPERTYKEY, ByRef pv As PropVariant) As Integer
<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType := MethodCodeType.Runtime)> _
Sub SetValue(<[In]> ByRef key As PROPERTYKEY, <[In]> ByRef pv As Object)
<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType := MethodCodeType.Runtime)> _
Sub Commit()
End Interface
<StructLayout(LayoutKind.Sequential, Pack := 4)> _
Structure PROPERTYKEY
Public fmtid As Guid
Public pid As UInteger
Public Sub New(guid As Guid, propertyId As Integer)
Me.fmtid = guid
Me.pid = CUInt(propertyId)
End Sub
Public Sub New(formatId As String, propertyId As Integer)
Me.New(New Guid(formatId), propertyId)
End Sub
Public Sub New(a As UInteger, b As UInteger, c As UInteger, d As UInteger, e As UInteger, f As UInteger, _
g As UInteger, h As UInteger, i As UInteger, j As UInteger, k As UInteger, propertyId As Integer)
Me.New(New Guid(CUInt(a), CUShort(b), CUShort(c), CByte(d), CByte(e), CByte(f), _
CByte(g), CByte(h), CByte(i), CByte(j), CByte(k)), propertyId)
End Sub
End Structure
<StructLayout(LayoutKind.Sequential)> _
Public Structure PropVariant
Private vt As UShort
Private wReserved1 As UShort
Private wReserved2 As UShort
Private wReserved3 As UShort
Private p As IntPtr
Private p2 As Integer
Private Function GetDataBytes() As Byte()
Dim ret As Byte() = New Byte(IntPtr.Size + (4 - 1)) {}
If IntPtr.Size = 4 Then
BitConverter.GetBytes(p.ToInt32()).CopyTo(ret, 0)
ElseIf IntPtr.Size = 8 Then
BitConverter.GetBytes(p.ToInt64()).CopyTo(ret, 0)
End If
BitConverter.GetBytes(p2).CopyTo(ret, IntPtr.Size)
Return ret
End Function
Private ReadOnly Property cVal() As SByte
' CHAR cVal;
Get
Return CSByte(GetDataBytes()(0))
End Get
End Property
Private ReadOnly Property iVal() As Short
' SHORT iVal;
Get
Return BitConverter.ToInt16(GetDataBytes(), 0)
End Get
End Property
Private ReadOnly Property lVal() As Integer
' LONG lVal;
Get
Return BitConverter.ToInt32(GetDataBytes(), 0)
End Get
End Property
Private ReadOnly Property hVal() As Long
' LARGE_INTEGER hVal;
Get
Return BitConverter.ToInt64(GetDataBytes(), 0)
End Get
End Property
Private ReadOnly Property fltVal() As Single
' FLOAT fltVal;
Get
Return BitConverter.ToSingle(GetDataBytes(), 0)
End Get
End Property
Public ReadOnly Property Value() As Object
Get
Select Case CType(vt, VarEnum)
Case VarEnum.VT_I1
Return cVal
Case VarEnum.VT_I2
Return iVal
Case VarEnum.VT_I4, VarEnum.VT_INT
Return lVal
Case VarEnum.VT_UI4, VarEnum.VT_I8
Return hVal
Case VarEnum.VT_R4
Return fltVal
Case VarEnum.VT_FILETIME
Return DateTime.FromFileTime(hVal)
Case VarEnum.VT_BSTR
Return Marshal.PtrToStringBSTR(p)
Case VarEnum.VT_BLOB
Dim blobData As Byte() = New Byte(lVal - 1) {}
Dim pBlobData As IntPtr
If IntPtr.Size = 4 Then
pBlobData = New IntPtr(p2)
ElseIf IntPtr.Size = 8 Then
pBlobData = New IntPtr(BitConverter.ToInt64(GetDataBytes(), 4))
Else
Throw New NotSupportedException()
End If
Marshal.Copy(pBlobData, blobData, 0, lVal)
Return blobData
Case VarEnum.VT_LPSTR
Return Marshal.PtrToStringAnsi(p)
Case VarEnum.VT_LPWSTR
Return Marshal.PtrToStringUni(p)
Case VarEnum.VT_UNKNOWN
Return Marshal.GetObjectForIUnknown(p)
Case VarEnum.VT_DISPATCH
Return p
Case Else
Throw New NotSupportedException("0x" + vt.ToString("X4") + " type not supported")
End Select
End Get
End Property
End Structure
'*****************************************************
'Device Topology declarations
<Guid("2A07407E-6497-4A18-9787-32F79BD0D98F"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> _
Public Interface IDeviceTopology
Function GetConnectorCount(<Out> ByRef pConnectorCount As Integer) As Integer
Function GetConnector(nIndex As Integer, ByRef ppConnector As IConnector) As Integer
Function GetSubunitCount(<Out> ByRef pCount As Integer) As Integer
'ISubunit
Function GetSubunit(nIndex As Integer, ByRef ppSubunit As Object) As Integer
Function GetPartById(nId As Integer, ByRef ppPart As IPart) As Integer
Function GetDeviceId(<Out, MarshalAs(UnmanagedType.LPWStr)> ByRef ppwstrDeviceId As String) As Integer
'IPartsList
Function GetSignalPath(pIPartFrom As IPart, pIPartTo As IPart, bRejectMixedPaths As Boolean, ppParts As Object) As Integer
End Interface
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown), Guid("9c2c4058-23f5-41de-877a-df3af236a09e")> _
Public Interface IConnector
Function [GetType](ByRef pType As Integer) As Integer
Function GetDataFlow(ByRef dataFlow As EDataFlow) As Integer
Function ConnectTo(<[In]> connector As IConnector) As Integer
Function Disconnect() As Integer
Function IsConnected(ByRef pbConnected As Boolean) As Integer
Function GetConnectedTo(<MarshalAs(UnmanagedType.[Interface])> ByRef ppConTo As Object) As Integer
Function GetConnectorIdConnectedTo(ByRef ppwstrConnectorId As String) As Integer
Function GetDeviceIdConnectedTo(ByRef ppwstrDeviceId As String) As Integer
End Interface
<Guid("AE2DE0E4-5BCA-4F2D-AA46-5D13F8FDB3A9"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> _
Public Interface IPart
Function GetName(ByRef ppwstrName As StringBuilder) As Integer
Function GetLocalId(ByRef pnId As Integer) As Integer
Function GetGlobalId(ByRef ppwstrGlobalId As StringBuilder) As Integer
Function GetPartType(ByRef pPartType As Integer) As Integer
Function GetSubType(ByRef pSubType As Guid) As Integer
Function GetControlInterfaceCount(ByRef pCount As UInteger) As Integer
'IControlInterface
Function GetControlInterface(nIndex As Integer, ByRef ppFunction As Object) As Integer
'IPartsList[]
Function EnumPartsIncoming(ByRef ppParts As Object) As Integer
'IPartsList[]
Function EnumPartsOutgoing(ByRef ppParts As Object) As Integer
Function GetTopologyObject(<Out, MarshalAs(UnmanagedType.[Interface])> ByRef ppTopology As Object) As Integer
Function Activate(dwClsContext As UInteger, ByRef refiid As Guid, <MarshalAs(UnmanagedType.[Interface])> ByRef interfacePointer As Object) As Integer
'IControlChangeNotify
Function RegisterControlChangeCallback(ByRef riid As Guid, pNofity As Object) As Integer
'IControlChangeNotify
Function UnregisterControlChangeCallback(pNotify As Object) As Integer
End Interface
<ComVisible(False)> _
<ComImport, InterfaceType(ComInterfaceType.InterfaceIsIUnknown), Guid("4509F757-2D46-4637-8E62-CE7DB944F57B")> _
Public Interface IKsJackDescription
Function GetJackCount(ByRef jacks As UInteger) As Integer
Function GetJackDescription(jack As UInteger, ByRef pDescription As KSJACK_DESCRIPTION) As Integer
End Interface
<StructLayout(LayoutKind.Sequential)> _
Public Structure KSJACK_DESCRIPTION
Public ChannelMapping As UInteger
Public Color As UInteger
Public ConnectionType As UInteger
Public GeoLocation As UInteger
Public GenLocation As UInteger
Public PortConnection As UInteger
Public IsConnected As UInteger
End Structure
End Namespace
Example how to get info about current default device's jack information
Imports System
Imports System.Collections.Generic
Imports System.Data
Imports System.Text
Imports System.Windows.Forms
Imports System.Runtime.InteropServices
Imports System.ComponentModel
Namespace com_test
Public Partial Class Form1
Inherits Form
'displays device
Private Function PrintDevice(dev As IMMDevice) As String
Dim propertyStore As IPropertyStore = Nothing
Dim pDeviceTopology As IDeviceTopology = Nothing
Dim pConnFrom As IConnector = Nothing
Dim pConnTo As IConnector = Nothing
Dim pPart As IPart = Nothing
Dim pJackDesc As IKsJackDescription = Nothing
Dim desc As New KSJACK_DESCRIPTION()
Dim res As New StringBuilder(300)
Dim o As Object = Nothing
Dim state As Integer = 0
Dim con_count As UInteger = 0
Try
'device name
'STGM_READ
dev.OpenPropertyStore(0, o)
propertyStore = TryCast(o, IPropertyStore)
Dim friendlyName As New PropVariant()
propertyStore.GetValue(Native.PKEY_Device_FriendlyName, friendlyName)
res.AppendLine(friendlyName.Value.ToString())
'form factor
Dim FormFactor As New PropVariant()
propertyStore.GetValue(Native.PKEY_AudioEndpoint_FormFactor, FormFactor)
Dim f As EndpointFormFactor = EndpointFormFactor.UnknownFormFactor
[Enum].TryParse(Of EndpointFormFactor)(FormFactor.Value.ToString(), f)
res.AppendLine("Form factor: " + f.ToString())
dev.GetState(state)
Dim str As String = ""
Select Case state
Case Native.DEVICE_STATE_DISABLE
str = ("Disabled")
Exit Select
Case Native.DEVICE_STATE_NOTPRESENT
str = ("Not present")
Exit Select
Case Native.DEVICE_STATE_UNPLUGGED
str = ("Unplugged")
Exit Select
End Select
If str <> "" Then
res.AppendLine(str)
End If
' DEVICE TOPOLOGY
Dim iidDeviceTopology As New Guid("2A07407E-6497-4A18-9787-32F79BD0D98F")
dev.Activate(iidDeviceTopology, CUInt(CLSCTX.CLSCTX_ALL), IntPtr.Zero, o)
pDeviceTopology = TryCast(o, IDeviceTopology)
pDeviceTopology.GetConnector(0, pConnFrom)
Try
o = Nothing
pConnFrom.GetConnectedTo(o)
pConnTo = TryCast(o, IConnector)
pPart = CType(pConnTo, IPart)
'QueryInterface
Dim iidKsJackDescription As New Guid("4509F757-2D46-4637-8E62-CE7DB944F57B")
pPart.Activate(CUInt(CLSCTX.CLSCTX_INPROC_SERVER), iidKsJackDescription, o)
pJackDesc = CType(o, IKsJackDescription)
If pJackDesc IsNot Nothing Then
con_count = 0
pJackDesc.GetJackCount(con_count)
If con_count > 0 Then
Dim sb As StringBuilder
'display jacks
For i As UInteger = 0 To con_count - 1
pJackDesc.GetJackDescription(i, desc)
sb = New StringBuilder(100)
Dim con_type As EPcxConnectionType = CType(desc.ConnectionType, EPcxConnectionType)
Dim loc As EPcxGeoLocation = CType(desc.GeoLocation, EPcxGeoLocation)
res.Append("* ")
Select Case con_type
Case EPcxConnectionType.eConnType3Point5mm
sb.Append("Jack 3.5 mm ")
Exit Select
Case EPcxConnectionType.eConnTypeAtapiInternal
sb.Append("ATAPI jack")
Exit Select
Case EPcxConnectionType.eConnTypeRCA
sb.Append("RCA jack")
Exit Select
Case EPcxConnectionType.eConnTypeQuarter
sb.Append("1/2 in. jack ")
Exit Select
Case EPcxConnectionType.eConnTypeOtherAnalog
sb.Append("Analog jack ")
Exit Select
Case EPcxConnectionType.eConnTypeOtherDigital
sb.Append("Digital jack ")
Exit Select
Case Else
sb.Append(con_type.ToString() + " ")
Exit Select
End Select
sb.Append("- " + loc.ToString())
'jack location
res.Append(sb.ToString())
If desc.IsConnected = 0 Then
res.AppendLine(": Disconnected")
Else
res.AppendLine(": Connected")
End If
'end for
Next
Else
res.AppendLine("* No jacks")
End If
Else
res.AppendLine("* Unable to get jacks")
End If
Catch ex As COMException
If CUInt(ex.HResult) = &H80070490UI Then
'E_NOTFOUND
res.AppendLine("Disconnected")
Else
res.AppendLine("COM error while getting jacks: " + ex.Message)
End If
Catch ex As Exception
res.AppendLine("Error while getting jacks: " + ex.Message)
End Try
Finally
'clean up resources
If dev IsNot Nothing Then
Marshal.ReleaseComObject(dev)
End If
If propertyStore IsNot Nothing Then
Marshal.ReleaseComObject(propertyStore)
End If
If pDeviceTopology IsNot Nothing Then
Marshal.ReleaseComObject(pDeviceTopology)
pDeviceTopology = Nothing
End If
If pConnFrom IsNot Nothing Then
Marshal.ReleaseComObject(pConnFrom)
pConnFrom = Nothing
End If
If pConnTo IsNot Nothing Then
Marshal.ReleaseComObject(pConnTo)
pConnTo = Nothing
End If
If pPart IsNot Nothing Then
Marshal.ReleaseComObject(pPart)
pPart = Nothing
End If
If pJackDesc IsNot Nothing Then
Marshal.ReleaseComObject(pJackDesc)
pJackDesc = Nothing
End If
End Try
Return res.ToString()
End Function
Public Sub New()
InitializeComponent()
End Sub
Private Sub button_Click(sender As Object, e As EventArgs)
Dim devenum As New MMDeviceEnumerator()
'Create enumerator
Dim deviceEnumerator As IMMDeviceEnumerator = CType(devenum, IMMDeviceEnumerator)
Dim defDevice As IMMDevice = Nothing
Dim propertyStore As IPropertyStore = Nothing
Try
Dim o As Object = Nothing
' * get default device *
deviceEnumerator.GetDefaultAudioEndpoint(EDataFlow.eRender, ERole.eConsole, o)
defDevice = TryCast(o, IMMDevice)
textBox1.Text = "Default sound device: " + Environment.NewLine + Environment.NewLine
textBox1.Text += PrintDevice(defDevice)
Catch ex As Exception
MessageBox.Show(ex.ToString())
Finally
'clean up resources
If devenum IsNot Nothing Then
Marshal.ReleaseComObject(devenum)
End If
If deviceEnumerator IsNot Nothing Then
Marshal.ReleaseComObject(deviceEnumerator)
End If
If defDevice IsNot Nothing Then
Marshal.ReleaseComObject(defDevice)
End If
If propertyStore IsNot Nothing Then
Marshal.ReleaseComObject(propertyStore)
End If
End Try
End Sub
End Class
End Namespace

Related

How do I convert a VARIANT to a managed object?

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

An error while trying to retrieve and decrypt login in Firefox

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!

Log in to remote computer

I am trying to log into a remote computer to pull some file information. I know how to do it in batch, but am not sure in VB.net.
Set /P pinghost=Enter server IP address:
net use \\%pinghost% /user:domain\username password
That is how I do it in batch, but no clue where to start in VB.net
End goal is log into the remote computer. Run a search in a program, and get the results pasted to vb.net textbox
Remotely connecting like this is quite a task, luckily there is a class available (see end of the answer for the code), that can be used by:
Dim Impersonator As New Impersonator("domain\user", "password")
Impersonator.BeginImpersonation()
File.Copy(SourcePath, DestPath, True)
Impersonator.EndImpersonation()
You can use File.GetCreationTime to verify that it is the file which is wanted, and the following to list the files and folders in a directory, how you display is up to you:
For Each Dir As String In Directory.GetDirectories("c:\Program Files")
The Impersonator class appears to cleverly mimic the environment of the application so it has access to the filesystem of the remote computer, therefore you might be able to use a simple FileOpenDialog.
The below is from here, I copied it here as I find Experts-Exchange often removes questions you actually need and want. Please respect the copyright of the code, which is FamousMortimer, 2014-02-07 at 09:43:26.
Public Class Impersonator
Private _username As String
Private _password As String
Private _domainname As String
Private _tokenHandle As New IntPtr(0)
Private _dupeTokenHandle As New IntPtr(0)
Private _impersonatedUser As System.Security.Principal.WindowsImpersonationContext
#Region "Constructor"
Public Sub New(ByVal username As String, _
ByVal password As String)
Dim nameparts() As String = username.Split(Convert.ToChar("\"))
If nameparts.Length > 1 Then
_domainname = nameparts(0)
_username = nameparts(1)
Else
_username = username
End If
_password = password
End Sub
Public Sub New(ByVal username As String, _
ByVal password As String, _
ByVal domainname As String)
_username = username
_password = password
_domainname = domainname
End Sub
#End Region
#Region "Properties"
Public ReadOnly Property username() As String
Get
Return _username
End Get
End Property
Public ReadOnly Property domainname() As String
Get
Return _domainname
End Get
End Property
Public ReadOnly Property currentWindowsUsername() As String
Get
Return System.Security.Principal.WindowsIdentity.GetCurrent().Name
End Get
End Property
#End Region
#Region "Impersonation"
Public Sub BeginImpersonation()
'Const LOGON32_PROVIDER_DEFAULT As Integer = 0
'Const LOGON32_LOGON_INTERACTIVE As Integer = 2
Const LOGON32_LOGON_NEW_CREDENTIALS As Integer = 9
Const LOGON32_PROVIDER_WINNT50 As Integer = 3
Const SecurityImpersonation As Integer = 2
Dim win32ErrorNumber As Integer
_tokenHandle = IntPtr.Zero
_dupeTokenHandle = IntPtr.Zero
If Not LogonUser(_username, _domainname, _password, LOGON32_LOGON_NEW_CREDENTIALS, LOGON32_PROVIDER_WINNT50, _tokenHandle) Then
win32ErrorNumber = System.Runtime.InteropServices.Marshal.GetLastWin32Error()
Throw New ImpersonationException(win32ErrorNumber, GetErrorMessage(win32ErrorNumber), _username, _domainname)
End If
If Not DuplicateToken(_tokenHandle, SecurityImpersonation, _dupeTokenHandle) Then
win32ErrorNumber = System.Runtime.InteropServices.Marshal.GetLastWin32Error()
CloseHandle(_tokenHandle)
Throw New ImpersonationException(win32ErrorNumber, "Unable to duplicate token!", _username, _domainname)
End If
Dim newId As New System.Security.Principal.WindowsIdentity(_dupeTokenHandle)
_impersonatedUser = newId.Impersonate()
End Sub
Public Sub EndImpersonation()
If Not _impersonatedUser Is Nothing Then
_impersonatedUser.Undo()
_impersonatedUser = Nothing
If Not System.IntPtr.op_Equality(_tokenHandle, IntPtr.Zero) Then
CloseHandle(_tokenHandle)
End If
If Not System.IntPtr.op_Equality(_dupeTokenHandle, IntPtr.Zero) Then
CloseHandle(_dupeTokenHandle)
End If
End If
End Sub
#End Region
#Region "Exception Class"
Public Class ImpersonationException
Inherits System.Exception
Public ReadOnly win32ErrorNumber As Integer
Public Sub New(ByVal win32ErrorNumber As Integer, ByVal msg As String, ByVal username As String, ByVal domainname As String)
MyBase.New(String.Format("Impersonation of {1}\{0} failed! [{2}] {3}", username, domainname, win32ErrorNumber, msg))
Me.win32ErrorNumber = win32ErrorNumber
End Sub
End Class
#End Region
#Region "External Declarations and Helpers"
Private Declare Auto Function LogonUser Lib "advapi32.dll" (ByVal lpszUsername As [String], _
ByVal lpszDomain As [String], ByVal lpszPassword As [String], _
ByVal dwLogonType As Integer, ByVal dwLogonProvider As Integer, _
ByRef phToken As IntPtr) As Boolean
Private Declare Auto Function DuplicateToken Lib "advapi32.dll" (ByVal ExistingTokenHandle As IntPtr, _
ByVal SECURITY_IMPERSONATION_LEVEL As Integer, _
ByRef DuplicateTokenHandle As IntPtr) As Boolean
Private Declare Auto Function CloseHandle Lib "kernel32.dll" (ByVal handle As IntPtr) As Boolean
<System.Runtime.InteropServices.DllImport("kernel32.dll")> _
Private Shared Function FormatMessage(ByVal dwFlags As Integer, ByRef lpSource As IntPtr, _
ByVal dwMessageId As Integer, ByVal dwLanguageId As Integer, ByRef lpBuffer As [String], _
ByVal nSize As Integer, ByRef Arguments As IntPtr) As Integer
End Function
Private Function GetErrorMessage(ByVal errorCode As Integer) As String
Dim FORMAT_MESSAGE_ALLOCATE_BUFFER As Integer = &H100
Dim FORMAT_MESSAGE_IGNORE_INSERTS As Integer = &H200
Dim FORMAT_MESSAGE_FROM_SYSTEM As Integer = &H1000
Dim messageSize As Integer = 255
Dim lpMsgBuf As String = ""
Dim dwFlags As Integer = FORMAT_MESSAGE_ALLOCATE_BUFFER Or FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS
Dim ptrlpSource As IntPtr = IntPtr.Zero
Dim prtArguments As IntPtr = IntPtr.Zero
Dim retVal As Integer = FormatMessage(dwFlags, ptrlpSource, errorCode, 0, lpMsgBuf, messageSize, prtArguments)
If 0 = retVal Then
Throw New System.Exception("Failed to format message for error code " + errorCode.ToString() + ". ")
End If
Return lpMsgBuf
End Function
#End Region
End Class

Implementing D3DCompileFromFile in VB.NET gives me a "has unbalanced the stack." error

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

Get url from all open tabs in Google Chrome using VB .Net and UI Automation

Hello I have this code working to get current url on Chrome, but only get active tab url. I need to get url from all open tabs using UI Automation.
My working code:
Function GetChromeUrl(ByVal proc As Process) As String
If proc.MainWindowHandle = IntPtr.Zero Then
Return Nothing
End If
Dim element As System.Windows.Automation.AutomationElement = AutomationElement.FromHandle(proc.MainWindowHandle)
If element Is Nothing Then
Return Nothing
End If
Dim edit As System.Windows.Automation.AutomationElement = element.FindFirst(TreeScope.Children, New PropertyCondition(AutomationElement.ControlTypeProperty, ControlType.Edit))
Return (edit.GetCurrentPattern(ValuePattern.Pattern)).Current.Value.ToString
End Function
and call it using this code in Form Load event:
For Each proc As Process In Process.GetProcessesByName("chrome")
MsgBox(proc.MainWindowTitle + " " + GetChromeUrl(proc))
Next
you better try this way
Imports NDde.Client 'import the NDde library for firefox
Imports System.Runtime.InteropServices
'For Chrome
Private Const WM_GETTEXTLENGTH As Integer = &He
Private Const WM_GETTEXT As Integer = &Hd
<DllImport("user32.dll")> _
Private Shared Function SendMessage(hWnd As IntPtr, Msg As UInteger, wParam As Integer, lParam As Integer) As Integer
End Function
<DllImport("user32.dll")> _
Private Shared Function SendMessage(hWnd As IntPtr, Msg As UInteger, wParam As Integer, lParam As StringBuilder) As Integer
End Function
<DllImport("user32.dll", SetLastError := True)> _
Private Shared Function FindWindowEx(parentHandle As IntPtr, childAfter As IntPtr, className As String, windowTitle As String) As IntPtr
End Function
Public Shared Function getChromeUrl(winHandle As IntPtr) As String
Dim browserUrl As String = Nothing
Dim urlHandle As IntPtr = FindWindowEx(winHandle, IntPtr.Zero, "Chrome_AutocompleteEditView", Nothing)
Const nChars As Integer = 256
Dim Buff As New StringBuilder(nChars)
Dim length As Integer = SendMessage(urlHandle, WM_GETTEXTLENGTH, 0, 0)
If length > 0 Then
SendMessage(urlHandle, WM_GETTEXT, nChars, Buff)
browserUrl = Buff.ToString()
Return browserUrl
Else
Return browserUrl
End If
End Function
Public shared Function GetChromeHandle() As Intptr
Dim ChromeHandle As IntPtr = Nothing
Dim Allpro() As Process = Process.GetProcesses();
For Each pro As Process in Allpro
if pro.ProcessName = "chrome"
ChromeHandle = pro.MainWindowHandle
Exit For
End if
Next
Return ChromeHandle
End Function
'USAGE FOR CHROME
Dim CHandle As IntPtr = GetChromeHandle()
If Not CHandle,Equals(Intptr.Zero)
Dim url As String = getChromeUrl(CHandle)
End If
Source and read more
EDIT :
i found my own way and it worked for me
Dim appAs String = "chrome"
Dim proc As System.Diagnostics.Process = GetBrowser(app)
...
Private Function GetBrowser(ByVal appName) As System.Diagnostics.Process
Dim pList() As System.Diagnostics.Process =
System.Diagnostics.Process.GetProcessesByName(app)
For Each proc As System.Diagnostics.Process In pList
If proc.ProcessName = appThen
Return proc
End If
Next
Return Nothing
End Function
usage :
If proc IsNot Nothing Then
Dim browserName as string = "Google Chrome"
Dim className as String = "Edit"
Dim s As String =
GetCurrentUrl(proc.MainWindowHandle, browserName, className, ComboBox1)
If s <> "" Then
Msgbox.show(s)
ComboBox1.SelectedIndex = 0 'Window list
Else
End If
Else
Label1.Text = browserName & " is not available"
end If
hope it helps :))))