Generate MD5 and SHA1 - vb.net

I'm using the below function to generate an MD5\SH1 hash for SQL backup files.
This works well, has progress report etc but is slow if using large files.
Could I generate the MD5 at the same time as SH1 rather than having to process the file twice, doubling the time taken? What about converting an MD5 result to SHA1?
Imports System
Imports System.IO
Imports System.Security.Cryptography
Imports System.Text
Public Class ASyncFileHashAlgorithm
Protected hashAlgorithm As HashAlgorithm
Protected m_hash As Byte()
Protected cancel As Boolean = False
Protected m_bufferSize As Integer = 4096
Public Delegate Sub FileHashingProgressHandler(ByVal sender As Object, _
ByVal e As FileHashingProgressArgs)
Public Event FileHashingProgress As FileHashingProgressHandler
Public Sub New(ByVal hashAlgorithm As HashAlgorithm)
Me.hashAlgorithm = hashAlgorithm
End Sub
Public Function ComputeHash(ByVal stream As Stream) As Byte()
cancel = False
m_hash = Nothing
Dim _bufferSize As Integer = m_bufferSize
' this makes it impossible to change the buffer size while computing
Dim readAheadBuffer As Byte(), buffer As Byte()
Dim readAheadBytesRead As Integer, bytesRead As Integer
Dim size As Long, totalBytesRead As Long = 0
size = stream.Length
readAheadBuffer = New Byte(_bufferSize - 1) {}
readAheadBytesRead = stream.Read(readAheadBuffer, 0, _
readAheadBuffer.Length)
totalBytesRead += readAheadBytesRead
Do
bytesRead = readAheadBytesRead
buffer = readAheadBuffer
readAheadBuffer = New Byte(_bufferSize - 1) {}
readAheadBytesRead = stream.Read(readAheadBuffer, 0, _
readAheadBuffer.Length)
totalBytesRead += readAheadBytesRead
If readAheadBytesRead = 0 Then
hashAlgorithm.TransformFinalBlock(buffer, 0, bytesRead)
Else
hashAlgorithm.TransformBlock(buffer, 0, bytesRead, buffer, 0)
End If
RaiseEvent FileHashingProgress(Me, New _
FileHashingProgressArgs(totalBytesRead, size))
Loop While readAheadBytesRead <> 0 AndAlso Not cancel
If cancel Then
Return InlineAssignHelper(m_hash, Nothing)
End If
Return InlineAssignHelper(m_hash, hashAlgorithm.Hash)
End Function
Public Property BufferSize() As Integer
Get
Return m_bufferSize
End Get
Set(ByVal value As Integer)
m_bufferSize = value
End Set
End Property
Public ReadOnly Property Hash() As Byte()
Get
Return m_hash
End Get
End Property
'Public Sub Cancel()
' cancel = True
'End Sub
Public Overrides Function ToString() As String
Dim hex As String = ""
For Each b As Byte In Hash
hex += b.ToString("x2")
Next
Return hex
End Function
Private Shared Function InlineAssignHelper(Of T)(ByRef target As T, _
ByVal value As T) As T
target = value
Return value
End Function
End Class
Public Class FileHashingProgressArgs
Inherits EventArgs
Public Property TotalBytesRead() As Long
Get
Return m_TotalBytesRead
End Get
Set(ByVal value As Long)
m_TotalBytesRead = Value
End Set
End Property
Private m_TotalBytesRead As Long
Public Property Size() As Long
Get
Return m_Size
End Get
Set(ByVal value As Long)
m_Size = Value
End Set
End Property
Private m_Size As Long
Public Sub New(ByVal totalBytesRead__1 As Long, ByVal size__2 As Long)
TotalBytesRead = totalBytesRead__1
Size = size__2
End Sub
End Class
The following is how I'm generating a hash using the above:
Shared hasher As New ASyncFileHashAlgorithm(SHA1.Create())
Private Function Test(Byval (strFilePathAndName, as String)
Dim stream As IO.Stream = DirectCast(File.Open(strFilePathAndName, _
FileMode.Open), Stream)
AddHandler hasher.FileHashingProgress, _
AddressOf OnFileHashingProgress
Dim t = New Thread(AddressOf hasher.ComputeHash)
t.Start(stream)
While t.IsAlive
Application.DoEvents()
End While
'LblMD5.Text = hasher.ToString???
LblSHA1.Text = hasher.ToString
stream.Dispose()
End Sub
Public Sub OnFileHashingProgress(ByVal sender As Object, _
ByVal e As FileHashingProgressArgs)
SetControlPropertyValue(uxChildForm.ProgressBar, "Position", _
CInt(e.TotalBytesRead / e.Size * 100))
End Sub

You ToString method may create tremendous overhead for large strings since concatenation is expensive (it creates large temporary buffer) and you do it often. Use a StringBuilder (initialised with the correct size) instead.

Related

Implement pbkdf2 in aspnet membership provider - Non-negative number required

I have a requirement to implement Pbkdf2 to secure a very old application that uses aspnet membership provider. I am following this answer which is recent and useful, but unable to follow what is inside MyRfc2898DeriveBytes class and it is giving me following issue.. (also I am a c# dev but for this project working in vb.net)
So the issue could be related to language conversion.
I am getting
Non-negative number required. Parameter name: srcOffset
at the following
Buffer.BlockCopy(m_buffer, m_startIndex, password, 0, size)
the m_startIndex here somehow becomes -1
Here is my code in vb
Imports System.IO
Imports System.Security.Cryptography
Namespace custom.hashing.keyderivation
Public Class PBKDF2Hash
Inherits KeyedHashAlgorithm
Private Const kHashBytes As Integer = 64
Private _ms As System.IO.MemoryStream
Public Property WorkFactor As Integer
Public Sub New()
MyBase.New()
Me.WorkFactor = 128000
Me.Key = New Byte(31) {}
Using rngCsp = New RNGCryptoServiceProvider()
rngCsp.GetBytes(Me.Key)
End Using
End Sub
Public Overrides ReadOnly Property HashSize As Integer
Get
Return kHashBytes * 8
End Get
End Property
Protected Overrides Sub HashCore(ByVal array As Byte(), ByVal ibStart As Integer, ByVal cbSize As Integer)
If IsNothing(_ms) Then
_ms = New MemoryStream()
End If
_ms.Write(array, ibStart, cbSize)
'(CSharpImpl.__Assign(_ms, If(_ms, New System.IO.MemoryStream()))).Write(array, ibStart, cbSize)
End Sub
Protected Overrides Function HashFinal() As Byte()
If Me.Key Is Nothing OrElse Me.Key.Length = 0 Then
Throw New CryptographicException("Missing KeyedAlgorithm key")
End If
_ms.Flush()
Dim arr = _ms.ToArray()
_ms = Nothing
Using hmac As HMACSHA512 = New HMACSHA512()
Return New MyRfc2898DeriveBytes(arr, Me.Key, Me.WorkFactor, hmac).GetBytes(kHashBytes)
End Using
End Function
Public Overrides Sub Initialize()
_ms = Nothing
End Sub
End Class
End Namespace
Imports System.Diagnostics.Contracts
Imports System.Security
Imports System.Security.Cryptography
Public Class MyRfc2898DeriveBytes
Inherits DeriveBytes
Private m_buffer As Byte()
Private m_salt As Byte()
Private m_hmac As HMAC
Private m_iterations As UInteger
Private m_block As UInteger
Private m_startIndex As Integer = 0
Private m_endIndex As Integer = 0
Private m_blockSize As Integer = 0
<SecuritySafeCritical>
Public Sub New(ByVal password As Byte(), ByVal salt As Byte(), ByVal iterations As Integer, ByVal hmac As HMAC)
salt = salt
IterationCount = iterations
hmac.Key = password
m_hmac = hmac
m_blockSize = hmac.HashSize >> 3
'''
Initialize()
End Sub
Public Property IterationCount As Integer
Get
Return CInt(m_iterations)
End Get
Set(ByVal value As Integer)
If value <= 0 Then Throw New ArgumentOutOfRangeException("value", "Error: Iteration count is zero or less")
m_iterations = CUInt(value)
Initialize()
End Set
End Property
Public Property Salt As Byte()
Get
Return CType(m_salt.Clone(), Byte())
End Get
Set(ByVal value As Byte())
If value Is Nothing Then Throw New ArgumentNullException("value")
If value.Length < 8 Then Throw New ArgumentException("Error: Salt size is less than 8")
m_salt = CType(value.Clone(), Byte())
Initialize()
End Set
End Property
Public Overrides Function GetBytes(ByVal cb As Integer) As Byte()
If cb <= 0 Then
Throw New ArgumentOutOfRangeException("cb", "Error: Hash size is zero or less")
End If
Contract.Assert(m_blockSize > 0)
Dim password As Byte() = New Byte(cb - 1) {}
Dim offset As Integer = 0
Dim size As Integer = m_endIndex - m_startIndex
If size > 0 Then
If cb >= size Then
Buffer.BlockCopy(m_buffer, m_startIndex, password, 0, size)
m_startIndex = m_endIndex = 0
offset += size
Else
Buffer.BlockCopy(m_buffer, m_startIndex, password, 0, cb)
m_startIndex += cb
Return password
End If
End If
Contract.Assert(m_startIndex = 0 AndAlso m_endIndex = 0, "Invalid start or end index in the internal buffer.")
While offset < cb
Dim T_block As Byte() = Func()
Dim remainder As Integer = cb - offset
If remainder > m_blockSize Then
Buffer.BlockCopy(T_block, 0, password, offset, m_blockSize)
offset += m_blockSize
Else
Buffer.BlockCopy(T_block, 0, password, offset, remainder)
offset += remainder
Buffer.BlockCopy(T_block, remainder, m_buffer, m_startIndex, m_blockSize - remainder)
m_endIndex += (m_blockSize - remainder)
Return password
End If
End While
Return password
End Function
Public Overrides Sub Reset()
Initialize()
End Sub
Protected Overrides Sub Dispose(ByVal disposing As Boolean)
MyBase.Dispose(disposing)
If disposing Then
If m_hmac IsNot Nothing Then
m_hmac.Dispose()
End If
If m_buffer IsNot Nothing Then
Array.Clear(m_buffer, 0, m_buffer.Length)
End If
If m_salt IsNot Nothing Then
Array.Clear(m_salt, 0, m_salt.Length)
End If
End If
End Sub
Private Sub Initialize()
If m_buffer IsNot Nothing Then Array.Clear(m_buffer, 0, m_buffer.Length)
m_buffer = New Byte(m_blockSize - 1) {}
m_block = 1
m_startIndex = m_endIndex = 0
End Sub
Friend Shared Function GetBytesFromInt(ByVal i As UInteger) As Byte()
End Function
Private Function Func() As Byte()
Dim INT_block As Byte() = GetBytesFromInt(m_block)
m_hmac.TransformBlock(m_salt, 0, m_salt.Length, Nothing, 0)
m_hmac.TransformBlock(INT_block, 0, INT_block.Length, Nothing, 0)
m_hmac.TransformFinalBlock(New Byte(-1) {}, 0, 0)
Dim temp As Byte() = m_hmac.Hash
m_hmac.Initialize()
Dim ret As Byte() = temp
For i As Integer = 2 To m_iterations
m_hmac.TransformBlock(temp, 0, temp.Length, Nothing, 0)
m_hmac.TransformFinalBlock(New Byte(-1) {}, 0, 0)
temp = m_hmac.Hash
For j As Integer = 0 To m_blockSize - 1
ret(j) = ret(j) Xor temp(j)
Next
m_hmac.Initialize()
Next
If m_block = UInteger.MaxValue Then
Throw New InvalidOperationException("Derived key too long.")
End If
m_block += 1
Return ret
End Function
End Class
So yes it was c# to vb conversion issues:
double assignment does not work in vb, so the following line was changed from
m_startIndex = m_endIndex = 0
to
m_startIndex = 0
m_endIndex = 0
Other things that I found
Property with same name as variable was not converted properly so
Public Sub New(ByVal password As Byte(), ByVal salt As Byte(), ByVal iterations As Integer, ByVal hmac As HMAC)
salt = salt
was really supposed to be
Public Sub New(ByVal password As Byte(), ByVal salt As Byte(), ByVal iterations As Integer, ByVal hmac As HMAC)
Me.Salt = salt
as Salt was a property
GetBytesFromInt(m_block) was not properly converted to vb
Friend Shared Function GetBytesFromInt(ByVal i As UInteger) As Byte()
Dim vIn As UInteger = 0
Dim vOut As Byte() = BitConverter.GetBytes(i)
Return vOut
'return unchecked(new byte[] { (byte)(i >> 24), (byte)(i >> 16), (byte)(i >> 8), (byte)i });
End Function

How to change RichTextBox line endings from Lf to CrLf

As opposed to the TextBox control which use CrLf line endings the RichTextBox control use Lf line endings. I don't want that. I need consistency. I need a RichTextBox control whom use CrLf line endings.
I opened the control in reflector and noticed that the getter of the Text property calls the following function:
Private Function StreamOut(ByVal flags As Integer) As String
'...
Me.StreamOut(data, flags, False)
'...
End Function
Which ends up calling:
Private Sub StreamOut(ByVal data As Stream, ByVal flags As Integer, ByVal includeCrLfs As Boolean)
'...
Dim es As New EDITSTREAM
'...
ElseIf includeCrLfs Then
num = (num Or &H20)
Else
'...
es.dwCookie = DirectCast(num, IntPtr)
'...
End Sub
And as you can see, the includeCrLfs parameter will always be False.
So I subclassed the control and intercepted the EM_STREAMOUT message. The LParam of this message contains the pointer to the EDITSTREAM structure. I appended the &H20 flag as seen in the function above, but this didn't work. The Text property started to return an empty string. I believe that I might have to remove/append other flags, but I have no clue as to which flags. Also, MSDN do not provide any hints other than application-defined value.
dwCookieSpecifies an application-defined value that the rich edit control passes to the EditStreamCallback callback function specified by the pfnCallback member.
Here's my subclassed control:
Public Class UIRichTextBox
Inherits System.Windows.Forms.RichTextBox
Private Sub EmStreamOut(ByRef m As Message)
Dim es As New EDITSTREAM
es = DirectCast(Marshal.PtrToStructure(m.LParam, GetType(EDITSTREAM)), EDITSTREAM)
If (IntPtr.Size = 4) Then
Dim cookie As Int32 = es.dwCookie.ToInt32()
'cookie = (cookie Or &H20I) '<- Didn't work
es.dwCookie = New IntPtr(cookie)
Else
Dim cookie As Int64 = es.dwCookie.ToInt64()
'cookie = (cookie Or &H20L) '<- Didn't work
es.dwCookie = New IntPtr(cookie)
End If
Marshal.StructureToPtr(es, m.LParam, True)
MyBase.WndProc(m)
End Sub
Protected Overrides Sub WndProc(ByRef m As Message)
Select Case m.Msg
Case EM_STREAMOUT
Me.EmStreamOut(m)
Exit Select
Case Else
MyBase.WndProc(m)
Exit Select
End Select
End Sub
Private Const EM_STREAMOUT As Integer = &H44A
Private Delegate Function EDITSTREAMCALLBACK(ByVal dwCookie As IntPtr, ByVal buf As IntPtr, ByVal cb As Integer, <Out()> ByRef transferred As Integer) As Integer
<StructLayout(LayoutKind.Sequential)> _
Private Class EDITSTREAM
Public dwCookie As IntPtr = IntPtr.Zero
Public dwError As Integer
Public pfnCallback As EDITSTREAMCALLBACK
End Class
End Class
Update
So it turns out that the flags are not undocumented at all. They are part of the EM_GETEDITSTYLE and EM_SETEDITSTYLE messages. But as you can see, the flag is obsolete.
SES_USECRLF Obsolete. Do not use.
So I guess I'm back at square one overriding the text property.
Public Overrides Property Text() As String
Get
Dim value As String = MyBase.Text
If (Not value Is Nothing) Then
value = value.Replace(ChrW(13), "")
value = value.Replace(ChrW(10), Environment.NewLine)
End If
Return value
End Get
Set(value As String)
MyBase.Text = value
End Set
End Property
So I managed to create a working solution using reflection. I'm sure there must be a good reason as to why SES_USECRLF is obsolete, so proceed with caution.
Public Class UIRichTextBox
Inherits System.Windows.Forms.RichTextBox
Shared Sub New()
UIRichTextBox.InternalEditStream = GetType(System.Windows.Forms.RichTextBox).GetField("editStream", (BindingFlags.NonPublic Or BindingFlags.Instance))
UIRichTextBox.InternalStreamIn = GetType(System.Windows.Forms.RichTextBox).GetMethod("StreamIn", (BindingFlags.NonPublic Or BindingFlags.Instance), Nothing, New Type() {GetType(System.IO.Stream), GetType(System.Int32)}, Nothing)
UIRichTextBox.InternalStreamOut = GetType(System.Windows.Forms.RichTextBox).GetMethod("StreamOut", (BindingFlags.NonPublic Or BindingFlags.Instance), Nothing, New Type() {GetType(System.IO.Stream), GetType(System.Int32), GetType(System.Boolean)}, Nothing)
End Sub
Public Sub New()
Me.m_includeCrLfs = True
End Sub
<DefaultValue(True), Category("Behavior")> _
Public Property IncludeCrLfs() As Boolean
Get
Return Me.m_includeCrLfs
End Get
Set(value As Boolean)
If (value <> Me.m_includeCrLfs) Then
Me.m_includeCrLfs = value
Me.RecreateHandle()
End If
End Set
End Property
Public Overrides Property [Text]() As String
Get
Dim value As String = Nothing
If (Me.StreamOut(&H11, value)) Then
Return value
End If
Return MyBase.[Text]
End Get
Set(ByVal value As String)
If (Not Me.StreamIn(value, &H11)) Then
MyBase.[Text] = value
End If
End Set
End Property
Private Function StreamIn(ByVal str As String, ByVal flags As Integer) As Boolean
If (((Me.IsHandleCreated AndAlso ((Not Me.IsDisposed) AndAlso (Not Me.Disposing))) AndAlso ((Not str Is Nothing) AndAlso (str.Length > 0))) AndAlso ((Not UIRichTextBox.InternalEditStream Is Nothing) AndAlso (Not UIRichTextBox.InternalStreamIn Is Nothing))) Then
Dim bytes As Byte()
Dim index As Integer = str.IndexOf(ChrW(0))
If (index <> -1) Then
str = str.Substring(0, index)
End If
If ((flags And &H10) <> 0) Then
bytes = Encoding.Unicode.GetBytes(str)
Else
bytes = Encoding.Default.GetBytes(str)
End If
Dim data As New System.IO.MemoryStream()
UIRichTextBox.InternalEditStream.SetValue(Me, data)
data.Write(bytes, 0, bytes.Length)
data.Position = 0
UIRichTextBox.InternalStreamIn.Invoke(Me, New Object() {data, flags})
Return True
End If
Return False
End Function
Private Function StreamOut(ByVal flags As Integer, ByRef result As String) As Boolean
If ((Me.IsHandleCreated AndAlso ((Not Me.IsDisposed) AndAlso (Not Me.Disposing))) AndAlso (Not UIRichTextBox.InternalStreamOut Is Nothing)) Then
Dim data As New System.IO.MemoryStream()
UIRichTextBox.InternalStreamOut.Invoke(Me, New Object() {data, flags, Me.m_includeCrLfs})
data.Position = 0
Dim length As Integer = CInt(data.Length)
Dim str As String = String.Empty
If (length > 0) Then
Dim buffer As Byte() = New Byte(length - 1) {}
data.Read(buffer, 0, length)
If ((flags And &H10) <> 0) Then
str = Encoding.Unicode.GetString(buffer, 0, buffer.Length)
Else
str = Encoding.Default.GetString(buffer, 0, buffer.Length)
End If
If ((Not String.IsNullOrEmpty(str)) AndAlso (str.Chars((str.Length - 1)) = ChrW(0))) Then
str = str.Substring(0, (str.Length - 1))
End If
End If
result = str
Return True
End If
Return False
End Function
Private Shared ReadOnly InternalEditStream As FieldInfo
Private Shared ReadOnly InternalStreamIn As MethodInfo
Private Shared ReadOnly InternalStreamOut As MethodInfo
Private m_includeCrLfs As Boolean
End Class

show text box in FolderBrowserDialog

how i can show textbox in FolderBrowserDialog like below image,
This is not directly possible, you have to fallback to using the shell function. Project + Add Reference, Browse tab, select c:\windows\system32\shell32.dll. An example of how to use it in a Winforms app:
Private Sub Button1_Click(ByVal sender As Object, ByVal e As EventArgs) Handles Button1.Click
Dim options As Integer = &H40 + &H200 + &H20
options += &H10 '' Adds edit box
Dim shell = New Shell32.ShellClass
Dim root = Environment.GetFolderPath(Environment.SpecialFolder.Desktop)
Dim folder = CType(shell.BrowseForFolder(CInt(Me.Handle), _
"Select folder", options, root), Shell32.Folder2)
If folder IsNot Nothing Then
MsgBox("You selected " + folder.Self.Path)
End If
End Sub
Check this out : FolderBrowserDialogEx: A C# customization of FolderBrowserDialog
The code is in C#, Here is the VB Conversion
Imports System
Imports System.Collections.Generic
Imports System.Linq
Imports System.Text
Imports System.Drawing
Imports System.Runtime.InteropServices
Imports System.Windows.Forms
Imports System.Diagnostics
Namespace DaveChambers.FolderBrowserDialogEx
Public Class FolderBrowserDialogEx
#Region "Fields that mimic the same-named fields in FolderBrowserDialog"
Public Property RootFolder() As Environment.SpecialFolder
Get
Return m_RootFolder
End Get
Set
m_RootFolder = Value
End Set
End Property
Private m_RootFolder As Environment.SpecialFolder
Public Property SelectedPath() As String
Get
Return m_SelectedPath
End Get
Set
m_SelectedPath = Value
End Set
End Property
Private m_SelectedPath As String
Public Property ShowNewFolderButton() As Boolean
Get
Return m_ShowNewFolderButton
End Get
Set
m_ShowNewFolderButton = Value
End Set
End Property
Private m_ShowNewFolderButton As Boolean
Public Property StartPosition() As FormStartPosition
Get
Return m_StartPosition
End Get
Set
m_StartPosition = Value
End Set
End Property
Private m_StartPosition As FormStartPosition
#End Region
' Fields specific to CustomFolderBrowserDialog
Public Property Title() As String
Get
Return m_Title
End Get
Set
m_Title = Value
End Set
End Property
Private m_Title As String
Public Property ShowEditbox() As Boolean
Get
Return m_ShowEditbox
End Get
Set
m_ShowEditbox = Value
End Set
End Property
Private m_ShowEditbox As Boolean
' These are the control IDs used in the dialog
Private Structure CtlIds
Public Const PATH_EDIT As Integer = &H3744
'public const int PATH_EDIT_LABEL = 0x3748; // Only when BIF_NEWDIALOGSTYLE
Public Const TITLE As Integer = &H3742
Public Const TREEVIEW As Integer = &H3741
Public Const NEW_FOLDER_BUTTON As Integer = &H3746
Public Const IDOK As Integer = 1
Public Const IDCANCEL As Integer = 2
End Structure
<StructLayout(LayoutKind.Sequential, CharSet := CharSet.Unicode)> _
Public Structure InitData
' Titles shouldn't too long, should they?
<MarshalAs(UnmanagedType.ByValTStr, SizeConst := 128)> _
Public Title As String
<MarshalAs(UnmanagedType.ByValTStr, SizeConst := Win32.MAX_PATH)> _
Public InitialPath As String
Public ShowEditbox As Boolean
Public ShowNewFolderButton As Boolean
Public StartPosition As FormStartPosition
Public hParent As IntPtr
Public Sub New(dlg As FolderBrowserDialogEx, hParent As IntPtr)
' We need to make copies of these values from the dialog.
' I tried passing the dlg obj itself in this struct, but Windows will barf after repeated invocations.
Me.Title = dlg.Title
Me.InitialPath = dlg.SelectedPath
Me.ShowNewFolderButton = dlg.ShowNewFolderButton
Me.ShowEditbox = dlg.ShowEditbox
Me.StartPosition = dlg.StartPosition
Me.hParent = hParent
End Sub
End Structure
Public Sub New()
Title = "Browse For Folder"
' Default to same caption as std dialog
RootFolder = Environment.SpecialFolder.Desktop
SelectedPath = "c:\"
ShowEditbox = False
ShowNewFolderButton = False
StartPosition = FormStartPosition.WindowsDefaultLocation
End Sub
Public Function ShowDialog(owner As IWin32Window) As DialogResult
Dim initdata As New InitData(Me, owner.Handle)
Dim bi As New Win32.BROWSEINFO()
bi.iImage = 0
bi.hwndOwner = owner.Handle
If 0 <> Win32.SHGetSpecialFolderLocation(owner.Handle, CInt(Me.RootFolder), bi.pidlRoot) Then
bi.pidlRoot = IntPtr.Zero
End If
bi.lpszTitle = ""
bi.ulFlags = Win32.BIF_RETURNONLYFSDIRS
' do NOT use BIF_NEWDIALOGSTYLE or BIF_STATUSTEXT
If Me.ShowEditbox Then
bi.ulFlags = bi.ulFlags Or Win32.BIF_EDITBOX
End If
If Not Me.ShowNewFolderButton Then
bi.ulFlags = bi.ulFlags Or Win32.BIF_NONEWFOLDERBUTTON
End If
bi.lpfn = New Win32.BrowseCallbackProc(_browseCallbackHandler)
' Initialization data, used in _browseCallbackHandler
Dim hInit As IntPtr = Marshal.AllocHGlobal(Marshal.SizeOf(initdata))
Marshal.StructureToPtr(initdata, hInit, True)
bi.lParam = hInit
Dim pidlSelectedPath As IntPtr = IntPtr.Zero
Try
pidlSelectedPath = Win32.SHBrowseForFolder(bi)
Dim sb As New StringBuilder(256)
If Win32.SHGetPathFromIDList(pidlSelectedPath, sb) Then
SelectedPath = sb.ToString()
Return DialogResult.OK
End If
Finally
' Caller is responsible for freeing this memory.
Marshal.FreeCoTaskMem(pidlSelectedPath)
End Try
Return DialogResult.Cancel
End Function
Private Function _browseCallbackHandler(hDlg As IntPtr, msg As Integer, lParam As IntPtr, lpData As IntPtr) As Integer
Select Case msg
Case Win32.BFFM_INITIALIZED
' remove context help button from dialog caption
Dim lStyle As Integer = Win32.GetWindowLong(hDlg, Win32.GWL_STYLE)
lStyle = lStyle And Not Win32.DS_CONTEXTHELP
Win32.SetWindowLong(hDlg, Win32.GWL_STYLE, lStyle)
lStyle = Win32.GetWindowLong(hDlg, Win32.GWL_EXSTYLE)
lStyle = lStyle And Not Win32.WS_EX_CONTEXTHELP
Win32.SetWindowLong(hDlg, Win32.GWL_EXSTYLE, lStyle)
_adjustUi(hDlg, lpData)
Exit Select
Case Win32.BFFM_SELCHANGED
If True Then
Dim ok As Boolean = False
Dim sb As New StringBuilder(Win32.MAX_PATH)
If Win32.SHGetPathFromIDList(lParam, sb) Then
ok = True
Dim dir As String = sb.ToString()
Dim hEdit As IntPtr = Win32.GetDlgItem(hDlg, CtlIds.PATH_EDIT)
Win32.SetWindowText(hEdit, dir)
#If UsingStatusText Then
' We're not using status text, but if we were, this is how you'd set it
Win32.SendMessage(hDlg, Win32.BFFM_SETSTATUSTEXTW, 0, dir)
#End If
#If SHBrowseForFolder_lists_links Then
' This check doesn't seem to be necessary - the SHBrowseForFolder dirtree doesn't seem to list links
Dim sfi As New Win32.SHFILEINFO()
Win32.SHGetFileInfo(lParam, 0, sfi, Marshal.SizeOf(sfi), Win32.SHGFI_PIDL Or Win32.SHGFI_ATTRIBUTES)
' fail if pidl is a link
If (sfi.dwAttributes And Win32.SFGAO_LINK) = Win32.SFGAO_LINK Then
ok = False
#End If
End If
End If
' if invalid selection, disable the OK button
If Not ok Then
Win32.EnableWindow(Win32.GetDlgItem(hDlg, CtlIds.IDOK), False)
End If
Exit Select
End If
End Select
Return 0
End Function
Private Sub _adjustUi(hDlg As IntPtr, lpData As IntPtr)
' Only do the adjustments if InitData was supplied
If lpData = IntPtr.Zero Then
Return
End If
Dim obj As Object = Marshal.PtrToStructure(lpData, GetType(InitData))
If obj Is Nothing Then
Return
End If
Dim initdata As InitData = DirectCast(obj, InitData)
' Only do the adjustments if we can find the dirtree control
Dim hTree As IntPtr = Win32.GetDlgItem(hDlg, CtlIds.TREEVIEW)
If hTree = IntPtr.Zero Then
hTree = Win32.FindWindowEx(IntPtr.Zero, IntPtr.Zero, "SysTreeView32", IntPtr.Zero)
If hTree = IntPtr.Zero Then
' This usually means that BIF_NEWDIALOGSTYLE is enabled.
hTree = Win32.FindWindowEx(hDlg, IntPtr.Zero, "SHBrowseForFolder ShellNameSpace Control", IntPtr.Zero)
End If
End If
If hTree = IntPtr.Zero Then
Return
End If
' Prep the basic UI
Win32.SendMessage(hDlg, Win32.BFFM_SETSELECTIONW, 1, initdata.InitialPath)
Win32.SetWindowText(hDlg, initdata.Title)
If initdata.StartPosition = FormStartPosition.CenterParent Then
_centerTo(hDlg, initdata.hParent)
ElseIf initdata.StartPosition = FormStartPosition.CenterScreen Then
_centerTo(hDlg, Win32.GetDesktopWindow())
End If
' else we do nothing
' Prep the edit box
Dim rcEdit As New Win32.RECT()
Dim hEdit As IntPtr = Win32.GetDlgItem(hDlg, CtlIds.PATH_EDIT)
If hEdit <> IntPtr.Zero Then
If initdata.ShowEditbox Then
Win32.GetWindowRect(hEdit, rcEdit)
Win32.ScreenToClient(hEdit, rcEdit)
Else
Win32.ShowWindow(hEdit, Win32.SW_HIDE)
End If
End If
' make the dialog larger
Dim rcDlg As Win32.RECT
Win32.GetWindowRect(hDlg, rcDlg)
rcDlg.Right += 40
rcDlg.Bottom += 30
If hEdit <> IntPtr.Zero Then
rcDlg.Bottom += (rcEdit.Height + 5)
End If
Win32.MoveWindow(hDlg, rcDlg, True)
Win32.GetClientRect(hDlg, rcDlg)
Dim vMargin As Integer = 10
' Accomodate the resizing handle's width
Dim hMargin As Integer = 10
' SystemInformation.VerticalScrollBarWidth;
' Move the Cancel button
Dim rcCancel As New Win32.RECT()
Dim hCancel As IntPtr = Win32.GetDlgItem(hDlg, CtlIds.IDCANCEL)
If hCancel <> IntPtr.Zero Then
Win32.GetWindowRect(hCancel, rcCancel)
Win32.ScreenToClient(hDlg, rcCancel)
rcCancel = New Win32.RECT(rcDlg.Right - (rcCancel.Width + hMargin), rcDlg.Bottom - (rcCancel.Height + vMargin), rcCancel.Width, rcCancel.Height)
Win32.MoveWindow(hCancel, rcCancel, False)
End If
' Move the OK button
Dim rcOK As New Win32.RECT()
Dim hOK As IntPtr = Win32.GetDlgItem(hDlg, CtlIds.IDOK)
If hOK <> IntPtr.Zero Then
Win32.GetWindowRect(hOK, rcOK)
Win32.ScreenToClient(hDlg, rcOK)
rcOK = New Win32.RECT(rcCancel.Left - (rcCancel.Width + hMargin), rcCancel.Top, rcOK.Width, rcOK.Height)
Win32.MoveWindow(hOK, rcOK, False)
End If
' Manage the "Make New Folder" button
Dim hBtn As IntPtr = Win32.GetDlgItem(hDlg, CtlIds.NEW_FOLDER_BUTTON)
If Not initdata.ShowNewFolderButton Then
' Make sure this button is not visible
Win32.ShowWindow(hBtn, Win32.SW_HIDE)
ElseIf hBtn = IntPtr.Zero Then
' Create a button - button is only auto-created under BIF_NEWDIALOGSTYLE
' This is failing, and I don't know why!
hBtn = Win32.CreateWindowEx(&H50010000, "button", "&Make New Folder", &H4, hMargin, rcOK.Top, _
105, rcOK.Height, hDlg, New IntPtr(CtlIds.NEW_FOLDER_BUTTON), Process.GetCurrentProcess().Handle, IntPtr.Zero)
End If
' Position the path editbox and it's label
' We'll repurpose the Title (static) control as the editbox label
Dim treeTop As Integer = vMargin
If hEdit <> IntPtr.Zero Then
Dim xEdit As Integer = hMargin
Dim cxEdit As Integer = rcDlg.Width - (2 * hMargin)
Dim hLabel As IntPtr = Win32.GetDlgItem(hDlg, CtlIds.TITLE)
If hLabel <> IntPtr.Zero Then
Dim labelText As String = "Folder: "
Win32.SetWindowText(hLabel, labelText)
' This code obtains the required size of the static control that serves as the label for the editbox.
' All this GDI code is a bit excessive, but I figured "what the hell".
Dim hdc As IntPtr = Win32.GetDC(hLabel)
Dim hFont As IntPtr = Win32.SendMessage(hLabel, Win32.WM_GETFONT, IntPtr.Zero, IntPtr.Zero)
Dim oldfnt As IntPtr = Win32.SelectObject(hdc, hFont)
Dim szLabel As Size = Size.Empty
Win32.GetTextExtentPoint32(hdc, labelText, labelText.Length, szLabel)
Win32.SelectObject(hdc, oldfnt)
Win32.ReleaseDC(hLabel, hdc)
Dim rcLabel As New Win32.RECT(hMargin, vMargin + ((rcEdit.Height - szLabel.Height) / 2), szLabel.Width, szLabel.Height)
Win32.MoveWindow(hLabel, rcLabel, False)
xEdit += rcLabel.Width
cxEdit -= rcLabel.Width
End If
' Expand the folder tree to fill the dialog
rcEdit = New Win32.RECT(xEdit, vMargin, cxEdit, rcEdit.Height)
Win32.MoveWindow(hEdit, rcEdit, False)
treeTop = rcEdit.Bottom + 5
End If
Dim rcTree As New Win32.RECT(hMargin, treeTop, rcDlg.Width - (2 * hMargin), rcDlg.Bottom - (treeTop + (2 * vMargin) + rcOK.Height))
Win32.MoveWindow(hTree, rcTree, False)
End Sub
Private Sub _centerTo(hDlg As IntPtr, hRef As IntPtr)
Dim rcDlg As Win32.RECT
Win32.GetWindowRect(hDlg, rcDlg)
Dim rcRef As Win32.RECT
Win32.GetWindowRect(hRef, rcRef)
Dim cx As Integer = (rcRef.Width - rcDlg.Width) / 2
Dim cy As Integer = (rcRef.Height - rcDlg.Height) / 2
Dim rcNew As New Win32.RECT(rcRef.Left + cx, rcRef.Top + cy, rcDlg.Width, rcDlg.Height)
Win32.MoveWindow(hDlg, rcNew, True)
End Sub
End Class
End Namespace
'=======================================================
'Service provided by Telerik (www.telerik.com)
'Conversion powered by NRefactory.
'Twitter: #telerik, #toddanglin
'Facebook: facebook.com/telerik
'=======================================================
I see two issues with the above dialogboxes (and any other dialog I've seen):
1: You cannot specify a custom start folder which will be preselected when the dialogbox opens, let's say "c:\temp"
2: When you type a path in the textbox and push TAB or ENTER this should NOT be seen as the final selected folder, but the treeview should instead move and expand to that path (just as if you did the same in Windows Explorer).
(sorry for putting this as an answer, cannot make a comment)

Vb.net app to track webbrowser popup

I have a webbrowser control on my form, when I navigate to a certain page it opens a popup which opens the page in the current default browser for windows, in this case IE. I would like to access the source code for this page. I dont want to close it, I just want to grab the html.
Thanks for your help.
Edit:
Slution:
eWebbrowser.vb :
Imports System
Imports System.Text
Imports System.Windows.Forms
Imports System.ComponentModel
Imports System.Collections.Generic
Imports System.Runtime.InteropServices
Imports System.Security.Permissions
<PermissionSet(SecurityAction.Demand, Name:="FullTrust")> _
<System.Runtime.InteropServices.ComVisibleAttribute(True)> _
Public Class eWebbrowser
Inherits System.Windows.Forms.WebBrowser
#Region " COM Imports Etc..."
<StructLayout(LayoutKind.Sequential)> _
Public Structure OLECMDTEXT
Public cmdtextf As UInt32
Public cwActual As UInt32
Public cwBuf As UInt32
Public rgwz As Char
End Structure
<StructLayout(LayoutKind.Sequential)> _
Public Structure OLECMD
Public cmdID As Long
Public cmdf As UInt64
End Structure
' Interop - IOleCommandTarget (See MSDN - http://support.microsoft.com/?kbid=311288)
<ComImport(), Guid("b722bccb-4e68-101b-a2bc-00aa00404770"), _
InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> _
Public Interface IOleCommandTarget
Sub QueryStatus(ByRef pguidCmdGroup As Guid, ByVal cCmds As UInt32, _
<MarshalAs(UnmanagedType.LPArray, SizeParamIndex:=1)> ByVal prgCmds As OLECMD, _
ByRef pCmdText As OLECMDTEXT)
Sub Exec(ByRef pguidCmdGroup As Guid, ByVal nCmdId As Long, _
ByVal nCmdExecOpt As Long, ByRef pvaIn As Object, _
ByRef pvaOut As Object)
End Interface
Private cmdGUID As New Guid(&HED016940, -17061, _
&H11CF, &HBA, &H4E, &H0, &HC0, &H4F, &HD7, &H8, &H16)
#Region " Commands Enumeration "
'There are a ton of ole commands, we are only using a couple, msdn research will
'allow you to figure out which ones you want to use.
Enum oCommands As Long
Options
Find = 1
ViewSource = 2
'////////////////////////////////////////
ID_FILE_SAVEAS = 32771
ID_FILE_PAGESETUP = 32772
ID_FILE_IMPORTEXPORT = 32774
ID_FILE_PRINTPREVIEW = 32776
ID_FILE_NEWIE = 32779
ID_FILE_NEWMAIL = 32780
PID_FILE_NEWINTERNETCALL = 32781
ID_FILE_ADDTRUST = 32782
ID_FILE_ADDLOCAL = 32783
DLCTL_BGSOUNDS = &H40
DLCTL_DLIMAGES = &H10
DLCTL_DOWNLOADONLY = &H800
DLCTL_FORCEOFFLINE = &H10000000
DLCTL_NO_BEHAVIORS = &H800
DLCTL_NO_CLIENTPULL = &H20000000
DLCTL_NO_DLACTIVEXCTLS = &H400
DLCTL_NO_FRAMEDOWNLOAD = &H1000
DLCTL_NO_JAVA = &H100
DLCTL_NO_METACHARSET = &H10000
DLCTL_NO_RUNACTIVEXCTLS = &H200
DLCTL_NO_SCRIPTS = &H80
'DLCTL_OFFLINE DLCTL_OFFLINEIFNOTCONNECTED
DLCTL_OFFLINEIFNOTCONNECTED = &H80000000
DLCTL_PRAGMA_NO_CACHE = &H4000
DLCTL_RESYNCHRONIZE = &H2000
DLCTL_SILENT = &H40000000
DLCTL_URL_ENCODING_DISABLE_UTF8 = &H20000
DLCTL_URL_ENCODING_ENABLE_UTF8 = &H40000
DLCTL_VIDEOS = &H20
End Enum
#End Region
#End Region
'Just a little easier way to get at it.
Public ReadOnly Property CurrentURL() As String
Get
Return Me.Document.Url.ToString
End Get
End Property
Public Sub New()
MyBase.New()
End Sub
#Region " Dialogs "
Public Sub ShowOpen()
Dim cdlOpen As New OpenFileDialog
Try
cdlOpen.Filter = "HTML Files (*.htm)|*.htm|HTML Files (*.html)|*.html|TextFiles" & _
"(*.txt)|*.txt|Gif Files (*.gif)|*.gif|JPEG Files (*.jpg)|*.jpeg|" & _
"PNG Files (*.png)|*.png|Art Files (*.art)|*.art|AU Fles (*.au)|*.au|" & _
"AIFF Files (*.aif|*.aiff|XBM Files (*.xbm)|*.xbm|All Files (*.*)|*.*"
cdlOpen.Title = " Open File "
cdlOpen.ShowDialog()
If cdlOpen.FileName > Nothing Then
Me.Navigate(cdlOpen.FileName)
End If
Catch ex As Exception
Throw New Exception(ex.Message.ToString)
End Try
End Sub
Public Sub ShowSource()
Dim cmdt As IOleCommandTarget
Dim o As Object = Nothing
Dim oIE As Object = Nothing
Try
cmdt = CType(Me.Document.DomDocument, IOleCommandTarget)
cmdt.Exec(cmdGUID, oCommands.ViewSource, 1, o, o)
Catch ex As Exception
Throw New Exception(ex.Message.ToString, ex.InnerException)
Finally
cmdt = Nothing
End Try
End Sub
Public Sub ShowFindDialog()
Dim cmdt As IOleCommandTarget
Dim o As Object = Nothing
Dim oIE As Object = Nothing
Try
cmdt = CType(Me.Document.DomDocument, IOleCommandTarget)
cmdt.Exec(cmdGUID, oCommands.Find, 0, o, o)
Catch ex As Exception
Throw New Exception(ex.Message.ToString, ex.InnerException)
Finally
cmdt = Nothing
End Try
End Sub
Public Sub AddToFavorites(Optional ByVal strURL As String = "", Optional ByVal strTitle As String = "")
Dim oHelper As Object = Nothing
Try
oHelper = New ShellUIHelper
oHelper.AddFavorite(Me.Document.Url.ToString, Me.DocumentTitle.ToString)
Catch ex As Exception
Throw New Exception(ex.Message.ToString)
End Try
If oHelper IsNot Nothing AndAlso Marshal.IsComObject(oHelper) Then
Marshal.ReleaseComObject(oHelper)
End If
End Sub
Public Sub ShowOrganizeFavorites()
'Organize Favorites
Dim helper As Object = Nothing
Try
helper = New ShellUIHelper()
helper.ShowBrowserUI("OrganizeFavorites", 0)
Finally
If helper IsNot Nothing AndAlso Marshal.IsComObject(helper) Then
Marshal.ReleaseComObject(helper)
End If
End Try
End Sub
Public Sub SendToDesktop()
'Shortcut to desktop
Dim helper As Object = Nothing
Try
helper = New ShellUIHelper()
helper.AddDesktopComponent(Me.Document.Url.ToString, "website")
Finally
If helper IsNot Nothing AndAlso Marshal.IsComObject(helper) Then
Marshal.ReleaseComObject(helper)
End If
End Try
End Sub
''' <summary>
''' This Will launch the internet option dialog.
''' </summary>
''' <remarks></remarks>
Public Sub ShowInternetOptions()
Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0", vbNormalFocus)
End Sub
Public Sub ShowPrivacyReport()
Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,2", vbNormalFocus)
End Sub
#End Region
#Region " Extended "
<ComImport(), _
Guid("34A715A0-6587-11D0-924A-0020AFC7AC4D"), _
InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIDispatch), _
TypeLibType(TypeLibTypeFlags.FHidden)> _
Public Interface DWebBrowserEvents2
<DispId(250)> _
Sub BeforeNavigate2(<[In](), MarshalAs(UnmanagedType.IDispatch)> ByVal pDisp As Object, _
<InAttribute(), MarshalAs(UnmanagedType.BStr)> ByRef URL As String, _
<InAttribute()> ByRef flags As Object, _
<InAttribute(), MarshalAs(UnmanagedType.BStr)> ByRef targetFrameName As String, _
<InAttribute()> ByRef postdata As Object, _
<InAttribute(), MarshalAs(UnmanagedType.BStr)> ByRef headers As String, _
<InAttribute(), OutAttribute()> ByRef cancel As Boolean)
'Note: Postdata is a SafeArray but for some reason, if I do a proper declaration, the event will not be raised:
'<[In](), MarshalAs(UnmanagedType.SafeArray, safearraysubtype:=VarEnum.VT_UI1)> ByRef postdata() As Byte, _
<DispId(273)> _
Sub NewWindow3(<InAttribute(), MarshalAs(UnmanagedType.IDispatch)> ByVal pDisp As Object, _
<InAttribute(), OutAttribute()> ByRef cancel As Boolean, _
<InAttribute()> ByRef Flags As Object, _
<InAttribute(), MarshalAs(UnmanagedType.BStr)> ByRef UrlContext As String, _
<InAttribute(), MarshalAs(UnmanagedType.BStr)> ByRef Url As String)
End Interface
Public Enum NWMF
NWMF_UNLOADING = &H1&
NWMF_USERINITED = &H2&
NWMF_FIRST_USERINITED = &H4&
NWMF_OVERRIDEKEY = &H8&
NWMF_SHOWHELP = &H10&
NWMF_HTMLDIALOG = &H20&
NWMF_FROMPROXY = &H40&
End Enum
Private cookie As AxHost.ConnectionPointCookie
Private wevents As WebBrowserExtendedEvents
'This method will be called to give you a chance to create your own event sink
Protected Overrides Sub CreateSink()
'MAKE SURE TO CALL THE BASE or the normal events won't fire
MyBase.CreateSink()
wevents = New WebBrowserExtendedEvents(Me)
cookie = New AxHost.ConnectionPointCookie(Me.ActiveXInstance, wevents, GetType(DWebBrowserEvents2))
End Sub
Protected Overrides Sub DetachSink()
If Not cookie Is Nothing Then
cookie.Disconnect()
cookie = Nothing
End If
MyBase.DetachSink()
End Sub
'This new event will fire when the page is navigating
Public Delegate Sub WebBrowserNavigatingExtendedEventHandler(ByVal sender As Object, ByVal e As WebBrowserNavigatingExtendedEventArgs)
Public Event NavigatingExtended As WebBrowserNavigatingExtendedEventHandler
'This event will fire when a new window is about to be opened
Public Delegate Sub WebBrowserNewWindowExtendedEventHandler(ByVal sender As Object, ByVal e As WebBrowserNewWindowExtendedEventArgs)
Public Event NewWindowExtended As WebBrowserNewWindowExtendedEventHandler
Protected Friend Sub OnNavigatingExtended(ByVal Url As String, ByVal Frame As String, ByVal Postdata As Byte(), ByVal Headers As String, ByRef Cancel As Boolean)
Dim e As WebBrowserNavigatingExtendedEventArgs = New WebBrowserNavigatingExtendedEventArgs(Url, Frame, Postdata, Headers)
RaiseEvent NavigatingExtended(Me, e)
Cancel = e.Cancel
End Sub
Protected Friend Sub OnNewWindowExtended(ByVal Url As String, ByRef Cancel As Boolean, ByVal Flags As NWMF, ByVal UrlContext As String)
Dim e As WebBrowserNewWindowExtendedEventArgs = New WebBrowserNewWindowExtendedEventArgs(Url, UrlContext, Flags)
RaiseEvent NewWindowExtended(Me, e)
Cancel = e.Cancel
End Sub
Public Overloads Sub Navigate2(ByVal URL As String)
MyBase.Navigate(URL)
End Sub
#End Region
#Region " Extended Event Classes "
'This class will capture events from the WebBrowser
Friend Class WebBrowserExtendedEvents
Inherits System.Runtime.InteropServices.StandardOleMarshalObject
Implements DWebBrowserEvents2
Private m_Browser As eWebbrowser
Public Sub New(ByVal browser As eWebbrowser)
m_Browser = browser
End Sub
'Implement whichever events you wish
Public Sub BeforeNavigate2(ByVal pDisp As Object, ByRef URL As String, ByRef flags As Object, ByRef targetFrameName As String, ByRef postData As Object, ByRef headers As String, ByRef cancel As Boolean) Implements DWebBrowserEvents2.BeforeNavigate2
m_Browser.OnNavigatingExtended(URL, targetFrameName, CType(postData, Byte()), headers, cancel)
End Sub
Public Sub NewWindow3(ByVal pDisp As Object, ByRef Cancel As Boolean, ByRef Flags As Object, ByRef UrlContext As String, ByRef Url As String) Implements DWebBrowserEvents2.NewWindow3
m_Browser.OnNewWindowExtended(Url, Cancel, CType(Flags, NWMF), UrlContext)
End Sub
End Class
Public Class WebBrowserNewWindowExtendedEventArgs
Inherits CancelEventArgs
Private m_Url As String
Private m_UrlContext As String
Private m_Flags As NWMF
Public ReadOnly Property Url() As String
Get
Return m_Url
End Get
End Property
Public ReadOnly Property UrlContext() As String
Get
Return m_UrlContext
End Get
End Property
Public ReadOnly Property Flags() As NWMF
Get
Return m_Flags
End Get
End Property
Public Sub New(ByVal url As String, ByVal urlcontext As String, ByVal flags As NWMF)
m_Url = url
m_UrlContext = urlcontext
m_Flags = flags
End Sub
End Class
'First define a new EventArgs class to contain the newly exposed data
Public Class WebBrowserNavigatingExtendedEventArgs
Inherits CancelEventArgs
Private m_Url As String
Private m_Frame As String
Private m_Postdata() As Byte
Private m_Headers As String
Public ReadOnly Property Url() As String
Get
Return m_Url
End Get
End Property
Public ReadOnly Property Frame() As String
Get
Return m_Frame
End Get
End Property
Public ReadOnly Property Headers() As String
Get
Return m_Headers
End Get
End Property
Public ReadOnly Property Postdata() As String
Get
Return PostdataToString(m_Postdata)
End Get
End Property
Public ReadOnly Property PostdataByte() As Byte()
Get
Return m_Postdata
End Get
End Property
Public Sub New(ByVal url As String, ByVal frame As String, ByVal postdata As Byte(), ByVal headers As String)
m_Url = url
m_Frame = frame
m_Postdata = postdata
m_Headers = headers
End Sub
Private Function PostdataToString(ByVal p() As Byte) As String
'not sexy but it works...
Dim tabpd() As Byte, bstop As Boolean = False, stmp As String = "", i As Integer = 0
tabpd = p
If tabpd Is Nothing OrElse tabpd.Length = 0 Then
Return ""
Else
For i = 0 To tabpd.Length - 1
stmp += ChrW(tabpd(i))
Next
stmp = Replace(stmp, ChrW(13), "")
stmp = Replace(stmp, ChrW(10), "")
stmp = Replace(stmp, ChrW(0), "")
End If
If stmp = Nothing Then
Return ""
Else
Return stmp
End If
End Function
End Class
#End Region
<ComImport(), Guid("64AB4BB7-111E-11D1-8F79-00C04FC2FBE1")> _
Public Class ShellUIHelper
'
End Class
End Class
form load:
Public WithEvents wb As eWebbrowser
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Dim brws As New eWebbrowser
wb = brws
End Sub
Events:
Private Sub wb_NewWindow(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) Handles wb.NewWindow
e.Cancel = True
End Sub
The New Event:
Private Sub wb_NewWindowExtended(ByVal sender As Object, ByVal e As eWebbrowser.WebBrowserNewWindowExtendedEventArgs) Handles wb.NewWindowExtended
e.Cancel = True
Dim url As String = e.Url
msgbox(url) //This Is The Url!!
End Sub

Facebook Connect Email hash function for vb.net

Does anyone have a working class or function to create the hashed email that is sent to facebook to register email addresses with connect.registerUsers?
Connect.registerUsers uses, I believe merely the normal MD5 hash as implemented in the .NET runtime.
The MD5 documentation page even includes an example code:
Function getMd5Hash(ByVal input As String) As String
' Create a new instance of the MD5 object. '
Dim md5Hasher As MD5 = MD5.Create()
' Convert the input string to a byte array and compute the hash. '
Dim data As Byte() = md5Hasher.ComputeHash(Encoding.Default.GetBytes(input))
' Create a new Stringbuilder to collect the bytes '
' and create a string. '
Dim sBuilder As New StringBuilder()
' Loop through each byte of the hashed data '
' and format each one as a hexadecimal string. '
For i As Integer = 0 To data.Length - 1
sBuilder.Append(data(i).ToString("x2"))
Next
' Return the hexadecimal string. '
Return sBuilder.ToString()
End Function
However, there’s a .NET client library for Facebook anyway, why not use it?
Duh. The .NET library doesn’t have support for Connect (yet)
figured this out on my own
Imports System.Net
Imports tb2CoreLib
Imports Microsoft.Xml.Schema.Linq
Imports System.Security.Cryptography
Imports facebook.Utility
Imports Microsoft.Xml
Imports System.Xml
Imports System.Web
Public Class FacebookConnect
Public Function EmailHash(ByVal email As String) As String
email = email.ToLower().Trim()
Dim rawBytes As Byte() = System.Text.UTF8Encoding.UTF8.GetBytes(email)
Dim crc As New Crc32()
Dim crcResult As Byte() = crc.ComputeHash(rawBytes)
Dim hexstring As String = Me.ToHexString(crcResult)
Dim crcLResult As Long = Me.HexToDec(hexstring)
Dim md5 As MD5 = New MD5CryptoServiceProvider()
Dim md5Result As Byte() = md5.ComputeHash(rawBytes)
Dim md5Data As String = Me.ToHexString(md5Result).ToLower()
Return (crcLResult.ToString() & "_") + md5Data
End Function
end class
Imports System
Imports System.Security.Cryptography
Public Class Crc32
Inherits HashAlgorithm
Public Const DefaultPolynomial As UInt32 = &HEDB88320UI
Public Const DefaultSeed As UInt32 = &HFFFFFFFFUI
Private Shadows hash As UInt32
Private seed As UInt32
Private table As UInt32()
Private Shared defaultTable As UInt32()
Public Sub New()
table = InitializeTable(DefaultPolynomial)
seed = DefaultSeed
Initialize()
End Sub
Public Sub New(ByVal polynomial As UInt32, ByVal seed As UInt32)
table = InitializeTable(polynomial)
Me.seed = seed
Initialize()
End Sub
Public Overloads Overrides Sub Initialize()
hash = seed
End Sub
Protected Overloads Overrides Sub HashCore(ByVal buffer As Byte(), ByVal start As Integer, ByVal length As Integer)
hash = CalculateHash(table, hash, buffer, start, length)
End Sub
Protected Overloads Overrides Function HashFinal() As Byte()
Dim hashBuffer As Byte() = UInt32ToBigEndianBytes(Not hash)
Me.HashValue = hashBuffer
Return hashBuffer
End Function
Public Overloads Overrides ReadOnly Property HashSize() As Integer
Get
Return 32
End Get
End Property
Public Shared Function Compute(ByVal buffer As Byte()) As UInt32
Return Not CalculateHash(InitializeTable(DefaultPolynomial), DefaultSeed, buffer, 0, buffer.Length)
End Function
Public Shared Function Compute(ByVal seed As UInt32, ByVal buffer As Byte()) As UInt32
Return Not CalculateHash(InitializeTable(DefaultPolynomial), seed, buffer, 0, buffer.Length)
End Function
Public Shared Function Compute(ByVal polynomial As UInt32, ByVal seed As UInt32, ByVal buffer As Byte()) As UInt32
Return Not CalculateHash(InitializeTable(polynomial), seed, buffer, 0, buffer.Length)
End Function
Private Shared Function InitializeTable(ByVal polynomial As UInt32) As UInt32()
If polynomial = DefaultPolynomial AndAlso defaultTable IsNot Nothing Then
Return defaultTable
End If
Dim createTable As UInt32() = New UInt32(255) {}
For i As UInt32 = 0 To 255
Dim entry As UInt32 = DirectCast(i, UInt32)
For j As Integer = 0 To 7
If (entry And 1) = 1 Then
entry = (entry >> 1) Xor polynomial
Else
entry = entry >> 1
End If
Next
createTable(i) = entry
Next
If polynomial = DefaultPolynomial Then
defaultTable = createTable
End If
Return createTable
End Function
Private Shared Function CalculateHash(ByVal table As UInt32(), ByVal seed As UInt32, ByVal buffer As Byte(), ByVal start As Integer, ByVal size As Integer) As UInt32
Dim crc As UInt32 = seed
For i As Integer = start To size - 1
crc = (crc >> 8) Xor table(buffer(i) Xor crc And &HFF)
Next
Return crc
End Function
Private Function UInt32ToBigEndianBytes(ByVal x As UInt32) As Byte()
Return New Byte() {CByte(((x >> 24) And &HFF)), CByte(((x >> 16) And &HFF)), CByte(((x >> 8) And &HFF)), CByte((x And &HFF))}
End Function
End Class