Archive for June, 2008

Rich Text Cell in a DataGridView

I needed to have more dynamic content in a datagridview cell with a custom cell provided to us in VS 2005 and up

. Here is a class I came up with to accomplish this. Hope it helps somebody!

Sample Usage:

Sample usage:
  Private Sub ConfigureGrid()
    Me.gridQuestion.AutoGenerateColumns = False
    Me.gridQuestion.Columns.Clear()
    Dim column As New DataGridViewRichTextColumn()
    column.ReadOnly = True
    column.Width = Me.gridQuestion.ClientSize.Width
    Me.gridQuestion.Columns.Add(column)
  End Sub

—————————-

Imports System.Runtime.InteropServices
Imports System.Drawing.Printing
Imports VB6 = Microsoft.VisualBasic.Compatibility.VB6
Public Class DataGridViewRichTextCell
  Inherits DataGridViewTextBoxCell
  Private m_rtfTemplate As New RichTextBox
  Protected Overrides Sub Paint(ByVal graphics As Graphics, _
  ByVal clipBounds As Rectangle, ByVal cellBounds As Rectangle, _
  ByVal rowIndex As Integer, ByVal cellState As DataGridViewElementStates, _
  ByVal value As Object, ByVal formattedValue As Object, _
  ByVal errorText As String, ByVal cellStyle As DataGridViewCellStyle, _
  ByVal advancedBorderStyle As DataGridViewAdvancedBorderStyle, _
  ByVal paintParts As DataGridViewPaintParts)
    Dim brush As New SolidBrush(cellStyle.BackColor)
    graphics.FillRectangle(brush, cellBounds)
    brush.Dispose()
    ‘ Convert the text to Rtf, and then transfer to the Graphics object.
    Me.PaintRtf(formattedValue, graphics, cellBounds, cellStyle.Font, cellStyle.BackColor)
    ‘ Paint the cell border after everything is done, or it will get
    ‘ overridden.
    MyBase.PaintBorder(graphics, clipBounds, cellBounds, cellStyle, advancedBorderStyle)
  End Sub
  Private Function GetSelectionLink(ByVal charIndex As Integer) As Boolean
    Const SCF_SELECTION As Int32 = &H1
    Const CFE_LINK As Int32 = &H20
    Dim cf As CHARFORMAT2_STRUCT = New CHARFORMAT2_STRUCT
    cf.cbSize = CType(Marshal.SizeOf(cf), UInt32)
    cf.szFaceName = New Char(32) {}
    Dim wParam As IntPtr = New IntPtr(SCF_SELECTION)
    Dim lParam As IntPtr = Marshal.AllocCoTaskMem(Marshal.SizeOf(cf))
    Marshal.StructureToPtr(cf, lParam, False)
    Dim res As IntPtr = SendMessage(m_rtfTemplate.Handle, EM_GETCHARFORMAT, wParam, lParam)
    cf = CType(Marshal.PtrToStructure(lParam, GetType(CHARFORMAT2_STRUCT)), CHARFORMAT2_STRUCT)
    Marshal.FreeCoTaskMem(lParam)
    Return (cf.dwEffects And CFE_LINK)
  End Function
  Public Overrides ReadOnly Property DefaultNewRowValue() As Object
    Get
      ‘ Use the current date and time as the default value.
      Return String.Empty
    End Get
  End Property
#Region "PaintRtf"
  <StructLayout(LayoutKind.Sequential)> _
  Private Structure CHARFORMAT2_STRUCT
    Public cbSize As UInt32
    Public dwMask As UInt32
    Public dwEffects As UInt32
    Public yHeight As Int32
    Public yOffset As Int32
    Public crTextColor As Int32
    Public bCharSet As Byte
    Public bPitchAndFamily As Byte
    <MarshalAs(UnmanagedType.ByValArray, SizeConst:=32)> _
    Public szFaceName As Char()
    Public wWeight As UInt16
    Public sSpacing As UInt16
    Public crBackColor As Integer
    Public lcid As Integer
    Public dwReserved As Integer
    Public sStyle As Int16
    Public wKerning As Int16
    Public bUnderlineType As Byte
    Public bAnimation As Byte
    Public bRevAuthor As Byte
    Public bReserved1 As Byte
  End Structure
  <StructLayout(LayoutKind.Sequential)> _
  Private Structure RECT
    Public Left As Integer
    Public Top As Integer
    Public Right As Integer
    Public Bottom As Integer
  End Structure
  <StructLayout(LayoutKind.Sequential)> _
  Private Structure CHARRANGE
    Public cpMin As Integer           ‘ First character of range (0 for start of doc)
    Public cpMax As Integer           ‘ Last character of range (-1 for end of doc)
  End Structure
  <StructLayout(LayoutKind.Sequential)> _
  Private Structure FORMATRANGE
    Public hdc As IntPtr             ‘ Actual DC to draw on
    Public hdcTarget As IntPtr       ‘ Target DC for determining text formatting
    Public rc As RECT                 ‘ Region of the DC to draw to (in twips)
    Public rcPage As RECT             ‘ Region of the whole DC (page size) (in twips)
    Public chrg As CHARRANGE         ‘ Range of text to draw (see above declaration)
  End Structure
  Private Const WM_USER As Int32 = &H400
  Private Const EM_FORMATRANGE As Int32 = WM_USER + 57
  Private Const EM_GETCHARFORMAT As Int32 = (WM_USER + 58)
  Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _
   (ByVal hWnd As IntPtr, ByVal msg As Int32, ByVal wparam As IntPtr, _
   ByVal lparam As IntPtr) As IntPtr
  ‘ Render the contents of the RichTextBox for printing
  ‘  Return the last character printed + 1 (printing start from this point for next page)
  Private Sub PaintRtf(ByVal value As String, ByVal gr As Graphics, ByVal bounds As Rectangle, ByVal font As Font, ByVal backColor As Color)
    If value Is Nothing Then
      Exit Sub
    End If
    ‘ Use an internal RichTextBox to format the text according to the
    ‘ business rules.
    m_rtfTemplate.Font = font
    m_rtfTemplate.WordWrap = False
    m_rtfTemplate.Text = value
    m_rtfTemplate.BackColor = backColor
    m_rtfTemplate.DetectUrls = True
    ‘ Mark starting and ending character.
    Dim cRange As CHARRANGE
    cRange.cpMin = 0
    cRange.cpMax = value.Length
    ‘ Calculate the area to render and print.  The bounds need to
    ‘ be converted from pixels to twips (1/1440 of an inch).
    Dim rectCell As New RECT
    rectCell.Left = VB6.PixelsToTwipsX(bounds.Left) + 30
    rectCell.Top = VB6.PixelsToTwipsY(bounds.Top) + 30
    rectCell.Right = VB6.PixelsToTwipsX(bounds.Right)
    rectCell.Bottom = VB6.PixelsToTwipsY(bounds.Bottom)
    Dim rectPrint As RECT = rectCell
    ‘ Get the DC for the graphics object.
    Dim hdc As IntPtr = gr.GetHdc()
    ‘ Initialize the FORMATRANGE structure for the EM_FORMATRANGE message.
    Dim fmtRange As FORMATRANGE
    fmtRange.chrg = cRange                  ‘ Indicate character from to character to
    fmtRange.hdc = hdc                      ‘ Use the same DC for measuring and rendering
    fmtRange.hdcTarget = hdc                ‘ Point at printer hDC
    fmtRange.rc = rectPrint                  ‘ Indicate the area on page to print
    fmtRange.rcPage = rectCell              ‘ Indicate whole size of page
    Dim wParam As IntPtr = New IntPtr(1)
    ‘ Pass the FORMATRANGE structure to the lParam handle for the
    ‘ EM_FORMATRANGE message sent to the internal RichTextBox.
    Dim lParam As IntPtr = Marshal.AllocCoTaskMem(Marshal.SizeOf(fmtRange))
    Marshal.StructureToPtr(fmtRange, lParam, False)
    ‘ Tell the RichTextBox to paint on the DC.
    Dim res As IntPtr = SendMessage(m_rtfTemplate.Handle, EM_FORMATRANGE, wParam, lParam)
    ‘ Free the block of memory allocated.
    Marshal.FreeCoTaskMem(lParam)
    ‘ Release the device context handle obtained by a previous call.
    gr.ReleaseHdc(hdc)
  End Sub
#End Region
End Class

Public Class DataGridViewRichTextColumn
  Inherits DataGridViewColumn
  Public Sub New()
    MyBase.New(New DataGridViewRichTextCell)
  End Sub
  Public Overrides Property CellTemplate() As DataGridViewCell
    Get
      Return MyBase.CellTemplate
    End Get
    Set(ByVal value As DataGridViewCell)
      ‘ Ensure that the cell used for the template is a CalendarCell.
      If Not (value Is Nothing) AndAlso _
       Not value.GetType().IsAssignableFrom(GetType(DataGridViewRichTextCell)) _
       Then
        Throw New InvalidCastException("Must be a DataGridViewRichTextCell")
      End If
      MyBase.CellTemplate = value
    End Set
  End Property
End Class

 

Leave a comment

Connection To Database Fails in Emulator but not in Visual Studio 2008

Well I have got a problem here. As I said yesterday I had begun to design applications in the compact .NET Framework 3.5 for a smart device. I have the Mobile 6 SDK installed. I created a data connection to a table called Employees in the GUI. When I preview the data in the GUI it works fine as shown below:

But when I go to debug the code and ask it just simply open and close the connection and here is what happens. It asks me what I want to deploy in and I request the Windows Mobile 6 Standard Landscape QVGA Emulator as I am using a Q Moto widescreen. Here is the error I have gotten. I have no idea what is causing this and have asked several friends to no avail. If anyone has any ideas I could be most grateful! The help when asked to assist in this situation is not at all helpful.

 

Technorati Tags: Windows Mobil 6,Visual Studio,Emulator,Q Moto,vb.net

 Update:

After further investigation it appears I had to launch the Device Emulator Manager under Tools, highlight the emulator I was using and select "Connect" (make sure it is not cradled). Then while working do not close the emulator. And now it connects fine. Thanks to those who tried to help.

Leave a comment

Windows Mobile 6 ,Windows Mobile 6 SDK, and Outlook

I am going to take a break today from my normal code workings to write about a topic that has got me a little steamed.

I just bought a Q Moto this past weekend. After a few days of just learning it I decided it was time to sync my email, contacts and calendar with my Outlook on my laptop. So far, I have been extremely happy with this product and even downloaded the Mobil 6 SDK to develop applications against it in Visual Studio 2008. First though my experience with Outlook on Windows Mobil 6.

I am assuming since it is an internet enabled device that there would be a way to make Outlook go out to my gmail account and get my mail. Then when I plug it in to the USB port at home, it would sync the emails in my phone with my Inbox.

I assumed incorrectly.

Oh it will let you create an email message on the mobile version of outlook, but you cant send it till you plugged in to your laptop again. You can create an additional email account that will download your messages but they won’t go into Outlook when you sync up to your laptop again. I could choose to leave the messages on the server but then when I go to the web interface on a normal machine everything is there.

This just plain stinks. I bought this thing to stay on top of my email and not have to worry about emails that are not in the right place. MS needs to find a way to have it go up on the server my laptop Outlook is configured with and get the emails just like it does on my laptop. And then sync it back to my laptop when I plug it in.

This is just silly.

Okay now on the SDK……….

As I am typing this of course it works fine. But yesterday it kept bombing Visual Studio 2008 (yes folks before you ask I had rebooted several times yesterday) and wanting to send error reports. But as of now it appears to be working ok. I am looking forward to writing for this device and see what I can do.

Technorati Tags: ,,,

Leave a comment

XML File as Data Source and Bind To DataSet in vb.net

What we would want to do is define a data layer class, keep an instance of the DataSet, and provide methods and properties to access the DataSet. I haven’t been able to use these concept at GE Healthcare yet but will be soon hopefully. Hope this helps somebody.

Sample usage would be:

Private m_dataLayer As New DataLayer(Application.StartupPath & "\Data.xml")

Me.DataGridView1.DataSource = m_dataLayer.Tables("Employee")

Imports System.Data
 
Public Class DataLayer
 
   Private m_data As DataSet
   Private m_fileName As String
 
   Public Sub New(ByVal fileName As String)
      m_data = new DataSet()
      m_data.ReadXml(fileName)
      m_fileName = fileName
   End Sub
 
   Public ReadOnly Property Table(ByVal tableName As String)
     Get
       Return m_data.Tables(tableName)
     End Get
   End Property
 
   Public Sub Write()
      m_data.WriteXml(m_fileName)
   End Sub
 
End Class

Leave a comment

Map Or Disconnect a Network Drive in vb.net

There are times when working with network drives it becomes necessary in an application to create or remove a network share. We don’t want an unhanded exception if the path is not mapped correctly or if it does not exist. (often users will screw this up after it has been correctly imaged on their machine). I actually ran into this at one point at GE Healthcare. Here is a very watered down sample of this (basically for security reasons).  One caveat: The windows script host must be enabled for this to work.

' Add a COM reference to Windows Script Host Object Model.
 
Imports IWshRuntimeLibrary
Imports System.Runtime.InteropServices
 
Public Class NetworkDriveMapper
 
  Public Shared Sub MapDrive(ByVal driveLetter As String, _
   ByVal networkPath As String, ByVal isPersistent As Boolean)
 
    ' Create a new shell object.
    Dim networkShell As New WshNetwork()
 
    Try
 
      ' Disconnect the drive first, forcing a permanent change.
      DisconnectDrive(driveLetter, True, True)
 
      ' Map the drive to the path.
      networkShell.MapNetworkDrive(driveLetter, networkPath, Convert.ToBoolean(isPersistent))
 
    Finally
 
      If Not networkShell Is Nothing Then
        Marshal.ReleaseComObject(networkShell)
 
        networkShell = Nothing
 
      End If
 
    End Try
 
  End Sub
 
  Public Shared Sub DisconnectDrive(ByVal driveLetter As String, _
    ByVal willForce As Boolean, ByVal isPersistent As Boolean)
 
    ' Create a new shell object.
    Dim networkShell As New WshNetwork()
 
    If IO.Directory.Exists(driveLetter) Then
 
      Try
 
        networkShell.RemoveNetworkDrive(driveLetter, Convert.ToBoolean(willForce), _
            Convert.ToBoolean(isPersistent))
 
      Finally
 
        If Not networkShell Is Nothing Then
          Marshal.ReleaseComObject(networkShell)
 
          networkShell = Nothing
 
        End If
 
      End Try
 
    End If
 
  End Sub
 
End Class
 


Join me on Facebook

Consulting Requests

Feedback

Blog Front Page

1 Comment

Get Window Handles Associated With Process in vb.net

For an application, it became necessary to find all handles (hWND) associated with that process and not just the main window. Here is what I came up with. I won’t be able to use these concepts at work yet but will once we upgrade our framework version. Hope it helps someone.

Imports System.Collections.Generic
Imports System.Runtime.InteropServices
Imports System.Text
 
Public Class ApiWindow
  Public MainWindowTitle As String = ""
  Public ClassName As String = ""
  Public hWnd As Int32
End Class
 
''' <summary> 
''' Enumerate top-level and child windows 
''' </summary> 
''' <example> 
''' Dim enumerator As New WindowsEnumerator()
''' For Each top As ApiWindow in enumerator.GetTopLevelWindows()
'''    Console.WriteLine(top.MainWindowTitle)
'''    For Each child As ApiWindow child in enumerator.GetChildWindows(top.hWnd) 
'''        Console.WriteLine(" " + child.MainWindowTitle)
'''    Next child
''' Next top
''' </example> 
Public Class WindowsEnumerator
 
  Private Delegate Function EnumCallBackDelegate(ByVal hwnd As Integer, ByVal lParam As Integer) As Integer
 
  ' Top-level windows.
  Private Declare Function EnumWindows Lib "user32" _
   (ByVal lpEnumFunc As EnumCallBackDelegate, ByVal lParam As Integer) As Integer
 
  ' Child windows.
  Private Declare Function EnumChildWindows Lib "user32" _
   (ByVal hWndParent As Integer, ByVal lpEnumFunc As EnumCallBackDelegate, ByVal lParam As Integer) As Integer
 
  ' Get the window class.
  Private Declare Function GetClassName _
   Lib "user32" Alias "GetClassNameA" _
   (ByVal hwnd As Integer, ByVal lpClassName As StringBuilder, ByVal nMaxCount As Integer) As Integer
 
  ' Test if the window is visible--only get visible ones.
  Private Declare Function IsWindowVisible Lib "user32" _
   (ByVal hwnd As Integer) As Integer
 
  ' Test if the window's parent--only get the one's without parents.
  Private Declare Function GetParent Lib "user32" _
   (ByVal hwnd As Integer) As Integer
 
  ' Get window text length signature.
  Private Declare Function SendMessage _
   Lib "user32" Alias "SendMessageA" _
   (ByVal hwnd As Int32, ByVal wMsg As Int32, ByVal wParam As Int32, ByVal lParam As Int32) As Int32
 
  ' Get window text signature.
  Private Declare Function SendMessage _
   Lib "user32" Alias "SendMessageA" _
   (ByVal hwnd As Int32, ByVal wMsg As Int32, ByVal wParam As Int32, ByVal lParam As StringBuilder) As Int32
 
  Private _listChildren As New List(Of ApiWindow)
  Private _listTopLevel As New List(Of ApiWindow)
 
  Private _topLevelClass As String = ""
  Private _childClass As String = ""
 
  ''' <summary>
  ''' Get all top-level window information
  ''' </summary>
  ''' <returns>List of window information objects</returns>
  Public Overloads Function GetTopLevelWindows() As List(Of ApiWindow)
 
    EnumWindows(AddressOf EnumWindowProc, &H0)
 
    Return _listTopLevel
 
  End Function
 
  Public Overloads Function GetTopLevelWindows(ByVal className As String) As List(Of ApiWindow)
 
    _topLevelClass = className
 
    Return Me.GetTopLevelWindows()
 
  End Function
 
  ''' <summary>
  ''' Get all child windows for the specific windows handle (hwnd).
  ''' </summary>
  ''' <returns>List of child windows for parent window</returns>
  Public Overloads Function GetChildWindows(ByVal hwnd As Int32) As List(Of ApiWindow)
 
    ' Clear the window list.
    _listChildren = New List(Of ApiWindow)
 
    ' Start the enumeration process.
    EnumChildWindows(hwnd, AddressOf EnumChildWindowProc, &H0)
 
    ' Return the children list when the process is completed.
    Return _listChildren
 
  End Function
 
  Public Overloads Function GetChildWindows(ByVal hwnd As Int32, ByVal childClass As String) As List(Of ApiWindow)
 
    ' Set the search
    _childClass = childClass
 
    Return Me.GetChildWindows(hwnd)
 
  End Function
 
  ''' <summary>
  ''' Callback function that does the work of enumerating top-level windows.
  ''' </summary>
  ''' <param name="hwnd">Discovered Window handle</param>
  ''' <returns>1=keep going, 0=stop</returns>
  Private Function EnumWindowProc(ByVal hwnd As Int32, ByVal lParam As Int32) As Int32
 
    ' Eliminate windows that are not top-level.
    If GetParent(hwnd) = 0 AndAlso CBool(IsWindowVisible(hwnd)) Then
 
      ' Get the window title / class name.
      Dim window As ApiWindow = GetWindowIdentification(hwnd)
 
      ' Match the class name if searching for a specific window class.
      If _topLevelClass.Length = 0 OrElse window.ClassName.ToLower() = _topLevelClass.ToLower() Then
        _listTopLevel.Add(window)
      End If
 
    End If
 
    ' To continue enumeration, return True (1), and to stop enumeration 
    ' return False (0).
    ' When 1 is returned, enumeration continues until there are no 
    ' more windows left.
 
    Return 1
 
  End Function
 
  ''' <summary>
  ''' Callback function that does the work of enumerating child windows.
  ''' </summary>
  ''' <param name="hwnd">Discovered Window handle</param>
  ''' <returns>1=keep going, 0=stop</returns>
  Private Function EnumChildWindowProc(ByVal hwnd As Int32, ByVal lParam As Int32) As Int32
 
    Dim window As ApiWindow = GetWindowIdentification(hwnd)
 
    ' Attempt to match the child class, if one was specified, otherwise
    ' enumerate all the child windows.
    If _childClass.Length = 0 OrElse window.ClassName.ToLower() = _childClass.ToLower() Then
      _listChildren.Add(window)
    End If
 
    Return 1
 
  End Function
 
  ''' <summary>
  ''' Build the ApiWindow object to hold information about the Window object.
  ''' </summary>
  Private Function GetWindowIdentification(ByVal hwnd As Integer) As ApiWindow
 
    Const WM_GETTEXT As Int32 = &HD
    Const WM_GETTEXTLENGTH As Int32 = &HE
 
    Dim window As New ApiWindow()
 
    Dim title As New StringBuilder()
 
    ' Get the size of the string required to hold the window title.
    Dim size As Int32 = SendMessage(hwnd, WM_GETTEXTLENGTH, 0, 0)
 
    ' If the return is 0, there is no title.
    If size > 0 Then
      title = New StringBuilder(size + 1)
 
      SendMessage(hwnd, WM_GETTEXT, title.Capacity, title)
    End If
 
    ' Get the class name for the window.
    Dim classBuilder As New StringBuilder(64)
    GetClassName(hwnd, classBuilder, 64)
 
    ' Set the properties for the ApiWindow object.
    window.ClassName = classBuilder.ToString()
    window.MainWindowTitle = title.ToString()
    window.hWnd = hwnd
 
    Return window
 
  End Function
 
End Class

Consulting Requests

Feedback

Blog Front Page

 


Join me on Facebook

Technorati Tags: ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,

Windows Live Tags: vb.net,.NET Framework,csharp,Handles,Window,Process,System,Generic,Runtime,InteropServices,Text,ApiWindow,MainWindowTitle,WindowsEnumerator,GetTopLevelWindows,GetChildWindows,Delegate,EnumCallBackDelegate,EnumWindows,EnumChildWindows,GetClassName,Alias,IsWindowVisible,parent,GetParent,signature,SendMessage,SendMessageA,EnumWindowProc,enumeration,EnumChildWindowProc,Callback,WM_GETTEXT,WM_GETTEXTLENGTH,collection,hWND,enumerator

4 Comments

Fun with FTP in vb.net

Since GE Healthcare has us working in 1.1 of the framework these days, I don’

t have the advantage of using the packaged FTP control. But I have gotten one written using 2.0 technology now that will be far superior to the class I have been using. We will at some point be upgrading our applications to the new version of the framework and hopefully soon cause I am excited to begin working with the new tools.


Join me on Facebook

' Add a reference to Microsoft.mshtml to the project. 
 
Imports System
Imports System.IO
Imports System.Net
Imports System.Text.RegularExpressions
Imports System.Web
 
Public Class FtpProcessor
 
  Private Const BLOCK_SIZE As Integer = 4096
 
  Public Shared Function ListDirectory(ByVal host As String, ByVal remoteDirectory As String) As List(Of FtpDirectoryEntry)
    Return ListDirectory(host, remoteDirectory, "", "")
  End Function
 
  ''' <summary>
  ''' Get a directory listing from the FTP server.  Parse the HTML response
  ''' to build a list of FtpDirectoryEntry objects describing each entry.
  ''' </summary>
  ''' <returns>A list of FTP server directory entries.</returns>
  Public Shared Function ListDirectory(ByVal host As String, ByVal remoteDirectory As String, ByVal userName As String, ByVal password As String) As List(Of FtpDirectoryEntry)
 
    ' Build the URL to point to the remote file to download
    Dim uri As String = FormatHost(host) & remoteDirectory
 
    ' Build an FTP request to download the file
    Dim request As FtpWebRequest = CType(FtpWebRequest.Create(uri), FtpWebRequest)
 
    ' Setup the request.
    request.Method = WebRequestMethods.Ftp.ListDirectory
    request.KeepAlive = False
 
    InitializeRequest(request, uri, userName, password)
 
    ' Get the response from the FTP server
    Using response As FtpWebResponse = CType(request.GetResponse(), FtpWebResponse)
 
      ' Get the file stream from the response.
      Using stream As Stream = response.GetResponseStream()
        Using reader As New StreamReader(stream)
          Dim commandResult As String = reader.ReadToEnd()
          Return ParseAnchors(commandResult)
        End Using
      End Using
 
    End Using
 
    Return Nothing
 
  End Function
 
  Public Shared Sub DownloadFile(ByVal host As String, ByVal remoteFile As String, ByVal localFile As String)
    DownloadFile(host, remoteFile, localFile, "", "")
  End Sub
 
  ''' <summary>
  ''' Download the remote file to the local file name.
  ''' </summary>
  Public Shared Sub DownloadFile(ByVal host As String, ByVal remoteFile As String, ByVal localFile As String, ByVal userName As String, ByVal password As String)
 
    ' Build the URL to point to the remote file to download
    Dim uri As String = FormatHost(host) & " " & remoteFile
 
    ' Build an FTP request to download the file
    Dim request As FtpWebRequest = CType(FtpWebRequest.Create(uri), FtpWebRequest)
 
    ' Setup the request.
    request.Method = WebRequestMethods.Ftp.DownloadFile
 
    InitializeRequest(request, uri, userName, password)
 
    ' Get the response from the FTP server
    Using response As FtpWebResponse = CType(request.GetResponse(), FtpWebResponse)
 
      ' Get the file stream from the response.
      Using input As Stream = response.GetResponseStream()
 
        ' Save the file stream to a local file
        Using output As New FileStream(localFile, FileMode.CreateNew)
 
          ' Read the input file stream from the response.
          Using reader As New BinaryReader(input)
 
            ' Write the input file stream to the output file, one block at a time.
            Using writer As New BinaryWriter(output)
              While reader.PeekChar() <> -1
                writer.Write(reader.ReadBytes(BLOCK_SIZE))
              End While
            End Using
          End Using
        End Using
      End Using
    End Using
  End Sub
 
  Public Shared Function UploadFile(ByVal host As String, ByVal remoteFile As String, ByVal localFile As String) As String
    Return UploadFile(host, remoteFile, localFile, "", "")
  End Function
 
  ''' <summary>
  ''' Upload the local file to the host as the remote file.
  ''' </summary>
  ''' <returns>Status description from the server response.</returns>
  Public Shared Function UploadFile(ByVal host As String, ByVal remoteFile As String, ByVal localFile As String, _
    ByVal userName As String, ByVal password As String) As String
 
    Dim uri As String = FormatHost(host) & " " & remoteFile
    Dim contentLength As Long = New FileInfo(localFile).Length
 
    Dim request As FtpWebRequest = CType(WebRequest.Create(uri), FtpWebRequest)
 
    InitializeRequest(request, uri, userName, password)
 
    request.ContentLength = contentLength
 
    request.Method = WebRequestMethods.Ftp.UploadFile
 
    Using localStream As New FileStream(localFile, FileMode.Open, FileAccess.Read, FileShare.None)
      Using reader As New BinaryReader(localStream)
 
        Using uploadStream As Stream = request.GetRequestStream()
          Using writer As New BinaryWriter(uploadStream)
            For count As Long = 0 To contentLength Step BLOCK_SIZE
              writer.Write(reader.ReadBytes(BLOCK_SIZE))
            Next count
          End Using
        End Using
      End Using
    End Using
 
    Using response As FtpWebResponse = CType(request.GetResponse(), FtpWebResponse)
      Return response.StatusDescription
    End Using
 
  End Function
 
  ''' <summary>
  ''' Make sure that the host is in the format ftp://host/
  ''' </summary>
  Private Shared Function FormatHost(ByVal host As String) As String
    host = host.Trim().ToLower().TrimStart("//").TrimStart("\\").TrimEnd("\")
    If Not host.StartsWith("ftp://") Then
      host = "ftp://" & host
    End If
 
    If Not host.EndsWith("/") Then
      host &= "/"
    End If
 
    Return host
  End Function
 
  ''' <summary>
  ''' Set up the FtpWebRequest for SSL, UseBinary, credentials, and proxy.
  ''' </summary>
  Private Shared Sub InitializeRequest(ByVal request As FtpWebRequest, ByVal uri As String, ByVal userName As String, ByVal password As String)
    request.UseBinary = True
    request.KeepAlive = False
    request.EnableSsl = uri.StartsWith("https")
 
    If userName.Trim().Length > 0 AndAlso password.Trim().Length > 0 Then
      request.Credentials = New NetworkCredential(userName, password)
    End If
 
    If WebProxy.GetDefaultProxy().Address IsNot Nothing Then
      Dim proxy As New WebProxy()
      proxy.UseDefaultCredentials = True
      proxy.Address = WebProxy.GetDefaultProxy().Address
      request.Proxy = proxy
    End If
  End Sub
 
  ''' <summary>
  ''' Find all the directories and files in the HTML response from the server.
  ''' </summary>
  Private Shared Function ParseAnchors(ByVal html As String) As List(Of FtpDirectoryEntry)
    Dim document As New mshtml.HTMLDocumentClass()
    TryCast(document, mshtml.IHTMLDocument2).write(html)
 
    Dim list As New List(Of FtpDirectoryEntry)()
    For Each element As mshtml.HTMLBRElement In document.getElementsByTagName("br")
 
      Dim sibling As Object = element.nextSibling
 
      Dim entry As FtpDirectoryEntry = Nothing
 
      While sibling IsNot Nothing
 
        If TypeOf sibling Is mshtml.IHTMLDOMTextNode Then
          Dim textNode As mshtml.IHTMLDOMNode = CType(sibling, mshtml.IHTMLDOMNode)
 
          entry = New FtpDirectoryEntry()
 
          ParseDirectoryEntry(entry, textNode.nodeValue)
          sibling = textNode.nextSibling
        ElseIf TypeOf sibling Is mshtml.HTMLAnchorElement Then
          Dim anchor As mshtml.HTMLAnchorElement = CType(sibling, mshtml.HTMLAnchorElement)
          entry.Name = anchor.innerText
          sibling = anchor.nextSibling
 
          list.Add(entry)
        End If
 
      End While
 
    Next element
    Return list
  End Function
 
  ''' <summary>
  ''' Parse the date/time and directory #text node text
  ''' </summary>
  ''' <example>
  ''' <![CDATA[02/08/05 12:00AM          <DIR>]]>
  ''' </example>
  Private Shared Sub ParseDirectoryEntry(ByVal entry As FtpDirectoryEntry, ByVal input As String)
    Dim pattern As String = "(?<timestamp>\d{1,2}/\d{1,2}/\d{2,4}\s+\d{1,2}:\d{1,2}\s?(AM|PM))\s+(?<dir>\<DIR\>)?"
    Dim match As Match = Regex.Match(input, pattern, RegexOptions.IgnoreCase)
    If match.Success Then
      Dim result As Date
      If Date.TryParse(match.Groups("timestamp").Value, result) Then
        entry.Timestamp = result
      End If
 
      If match.Groups("dir").Length > 0 Then
        entry.IsDirectory = True
      End If
    End If
  End Sub
 
End Class
 
Public Class FtpDirectoryEntry
  Public IsDirectory As Boolean
  Public Name As String
  Public Timestamp As DateTime
End Class
 

1 Comment