Hello Lou,
wel it was a big search in my code library ,,,, but ..... here it is
Imports System.IO
Imports System.Net.Sockets
Imports System.Text
Imports System.Threading
Imports System.Security
Imports System.Management
Module FTP
Enum TransferMode
Ascii
Binary
End Enum
Public Class FtpClient
Const BUFFSIZE As Integer = 4096
Private strErrorCode As String = ""
Private strErrorMessage As String = ""
Private bConnectionOpen As Boolean = False
Private m_LogFileDirectory As String = "C:\"
Private m_sUsername As String = ""
Private m_sPassword As String = ""
Private m_sHost As String = ""
Private m_iPort As Integer = 21
Private m_tcpClient As TcpClient
Private m_commandStream As NetworkStream
Dim intFTPLog As Integer = FreeFile()
Private Sub SendFTPCommand(ByVal command As String)
If command.Length > 4 AndAlso command.Substring(0, 4) = "PASS"
Then
WriteToFTPLog("PASS")
Else
WriteToFTPLog(command)
End If
Try
m_commandStream.Write(System.Text.Encoding.ASCII.GetBytes(command
& vbCrLf), 0, command.Length + 2)
Catch EX As Exception
Throw New FtpClientException(0, "SendFTPCommand" & vbCrLf &
EX.Message)
End Try
End Sub
Friend Sub FtpClient(ByVal sHost As String, ByVal sUser As String,
ByVal sPassword As String)
m_sHost = sHost
m_sUsername = sUser
m_sPassword = sPassword
End Sub
#If False Then
Friend Sub FtpClient(ByVal sHost As String)
m_sHost = sHost
End Sub
Public Sub FtpClient(ByVal sHost As String, ByVal iPort As Integer)
m_sHost = sHost
m_iPort = iPort
End Sub
#End If
Friend Property Username() As String
Get
Return m_sUsername
End Get
Set(ByVal Value As String)
m_sUsername = Value
End Set
End Property
Friend Property Password() As String
Get
Return m_sPassword
End Get
Set(ByVal Value As String)
m_sPassword = Value
End Set
End Property
Friend Property Host() As String
Get
Return m_sHost
End Get
Set(ByVal Value As String)
m_sHost = Value
End Set
End Property
Friend Property Port() As Integer
Get
Return m_iPort
End Get
Set(ByVal Value As Integer)
m_iPort = Value
End Set
End Property
Friend Property LogFileDirectory() As String
Get
Return m_LogFileDirectory
End Get
Set(ByVal Value As String)
m_LogFileDirectory = Value
If Not m_LogFileDirectory.EndsWith("\") Then
m_LogFileDirectory += "\"
End If
End Set
End Property
Friend Sub Open()
Dim sOut As String = ""
'
' FTP Log File
'
Dim strLogFile As String = m_LogFileDirectory &
Application.ProductName & "_FTP.LOG"
If File.Exists(strLogFile) AndAlso
File.GetLastWriteTime(strLogFile).Date = Now.Date Then
Try
' Open file for logging.
FileOpen(intFTPLog, strLogFile, OpenMode.Append,
OpenAccess.Write, OpenShare.LockWrite)
Catch MyException As System.Exception
Throw New FtpClientException(0, _
String.Concat("Unable to create ", strLogFile, _
vbNewLine, _
MyException.Message))
End Try
Else
Try
' Open file for logging.
FileOpen(intFTPLog, strLogFile, OpenMode.Output,
OpenAccess.Write, OpenShare.LockWrite)
Catch MyException As System.Exception
Throw New FtpClientException(0, _
String.Concat("Unable to create ", strLogFile, _
vbNewLine, _
MyException.Message))
End Try
End If
'
'
'
If (bConnectionOpen) Then
Throw New FtpClientException(0, "Open" & vbCrLf & "FTP
Connection already open")
End If
Try
m_tcpClient = New TcpClient
WriteToFTPLog("FTP " & m_sHost)
m_tcpClient.SendTimeout = 5000
m_tcpClient.ReceiveTimeout = 5000
m_tcpClient.Connect(m_sHost, m_iPort)
m_tcpClient.ReceiveBufferSize = 4096 ' allocate a 4kb buffer
m_tcpClient.SendBufferSize = 4096
m_tcpClient.NoDelay = True
Catch e As SocketException
Throw New FtpClientException(e.ErrorCode, _
"Open" & vbCrLf & _
"TCPClient cannot establish a connection to " & m_sHost
& " on Port " & m_iPort.ToString & vbCrLf & _
e.Message)
End Try
m_commandStream = m_tcpClient.GetStream ' Get the command stream
' We just successfully connected so the server welcomes us with
a 220 response
sOut = ReadReply(True)
If Not ReplyContains("220", sOut, strErrorCode, strErrorMessage)
Then
Throw New FtpClientException(CInt(strErrorCode), "Open" &
vbCrLf & strErrorMessage)
End If
SendFTPCommand("USER " & m_sUsername) ' send our user name
' the server must reply with 331
sOut = ReadReply()
If Not ReplyContains("331", sOut, strErrorCode, strErrorMessage)
Then
Throw New FtpClientException(CInt(strErrorCode), "User" &
vbCrLf & strErrorMessage)
End If
SendFTPCommand("PASS " & m_sPassword) ' send our password
sOut = ReadReply(True)
If Not ReplyContains("230", sOut, strErrorCode, strErrorMessage)
Then
Throw New FtpClientException(CInt(strErrorCode), "Password"
& vbCrLf & strErrorMessage)
End If
bConnectionOpen = True
End Sub
Friend Sub SetCurrentDirectory(ByVal sDirectory As String)
If (Not bConnectionOpen) Then
Throw New FtpClientException(0, "SetCurrentDirectory" &
vbCrLf & "Connection not open")
End If
SendFTPCommand("CWD " & sDirectory) ' send the command to change
directory
Dim sOut As String = ReadReply()
' FTP server must reply with 250, else the directory does not
exist
If Not ReplyContains("250", sOut, strErrorCode, strErrorMessage)
Then
Throw New FtpClientException(CInt(strErrorCode),
strErrorMessage)
End If
End Sub
Friend Sub ReceiveFile( _
ByVal sLocalFilename As String, _
ByVal sRemoteFilename As String, _
ByVal XferMode As TransferMode)
Dim objLocalFileStream As FileStream
Dim mTCPData As New TcpClient
Dim mDataStream As NetworkStream
Dim Port As Integer = 20
Dim strIPAddress As String
Dim sOut As String = ""
If (Not bConnectionOpen) Then
Throw New FtpClientException(0, "ReceiveFile" & vbCrLf &
"Connection not open")
End If
Try
objLocalFileStream = New FileStream(sLocalFilename,
FileMode.Create, FileAccess.ReadWrite, FileShare.Read, BUFFSIZE, False)
Catch ex As FileNotFoundException
Throw New FtpClientException(0, "Open Local File - File Not
Found" & vbCrLf & sLocalFilename & vbCrLf & ex.Message)
Catch ex As DirectoryNotFoundException
Throw New FtpClientException(0, "Open Local File - Directory
Not Found" & vbCrLf & sLocalFilename & vbCrLf & ex.Message)
Catch ex As SecurityException
Throw New FtpClientException(0, "Open Local File" & vbCrLf &
sLocalFilename & vbCrLf & ex.Message)
Catch ex As UnauthorizedAccessException
Throw New FtpClientException(0, "Open Local File" & vbCrLf &
sLocalFilename & vbCrLf & ex.Message)
Catch ex As Exception
Throw New FtpClientException(0, "Open Local File" & vbCrLf &
sLocalFilename & vbCrLf & ex.Message)
End Try
' Set transfer mode
Select Case XferMode
Case TransferMode.Ascii
SendFTPCommand("TYPE A")
sOut = ReadReply()
Case TransferMode.Binary
SendFTPCommand("TYPE I")
sOut = ReadReply()
End Select
Application.DoEvents()
'
'
Call ReadyDataSocketAndSendCommand("RETR " &
Path.GetFileName(sLocalFilename), _
"ReceiveFile", mTCPData, mDataStream)
Dim bData(1024) As Byte
Dim bytesRead As Integer = 0
' Retrieve the file
bytesRead = mDataStream.Read(bData, 0, BUFFSIZE)
Do While (bytesRead > 0)
objLocalFileStream.Write(bData, 0, bytesRead)
bytesRead = mDataStream.Read(bData, 0, BUFFSIZE)
Application.DoEvents()
Loop
objLocalFileStream.Close()
objLocalFileStream = Nothing
mDataStream.Close()
mDataStream = Nothing
mTCPData.Close()
mTCPData = Nothing
Thread.Sleep(200)
sOut = ReadReply()
End Sub
Friend Sub SendFile( _
ByVal sLocalFilename As String, _
ByVal sRemoteFilename As String, _
ByVal XferMode As TransferMode)
Dim objLocalFileStream As FileStream
Dim mTCPData As New TcpClient
Dim mDataStream As NetworkStream
Dim Port As Integer = 20
Dim strIPAddress As String
Dim sOut As String = ""
If (Not bConnectionOpen) Then
Throw New FtpClientException(0, "SendFile" & vbCrLf &
"Connection not open")
End If
Try
objLocalFileStream = New FileStream(sLocalFilename,
FileMode.Open, FileAccess.Read, FileShare.Read, BUFFSIZE, False)
Catch ex As FileNotFoundException
Throw New FtpClientException(0, "Open Local File" & vbCrLf &
sLocalFilename & vbCrLf & ex.Message)
Catch ex As DirectoryNotFoundException
Throw New FtpClientException(0, "Open Local File" & vbCrLf &
sLocalFilename & vbCrLf & ex.Message)
Catch ex As SecurityException
Throw New FtpClientException(0, "Open Local File" & vbCrLf &
sLocalFilename & vbCrLf & ex.Message)
Catch ex As UnauthorizedAccessException
Throw New FtpClientException(0, "Open Local File" & vbCrLf &
sLocalFilename & vbCrLf & ex.Message)
Catch ex As Exception
Throw New FtpClientException(0, "Open Local File" & vbCrLf &
sLocalFilename & vbCrLf & ex.Message)
End Try
' Set transfer mode
Select Case XferMode
Case TransferMode.Ascii
SendFTPCommand("TYPE A")
sOut = ReadReply()
Case TransferMode.Binary
SendFTPCommand("TYPE I")
sOut = ReadReply()
End Select
Application.DoEvents()
Call ReadyDataSocketAndSendCommand("STOR " &
Path.GetFileName(sLocalFilename), _
"SendFile", mTCPData, mDataStream)
Dim bData(BUFFSIZE) As Byte
Dim bytesRead As Integer = 0
' Upload the file
bytesRead = objLocalFileStream.Read(bData, 0, BUFFSIZE)
Do While (bytesRead > 0)
mDataStream.Write(bData, 0, bytesRead)
bytesRead = objLocalFileStream.Read(bData, 0, BUFFSIZE)
Application.DoEvents()
Loop
objLocalFileStream.Close()
objLocalFileStream = Nothing
mDataStream.Close()
mDataStream = Nothing
mTCPData.Close()
mTCPData = Nothing
Thread.Sleep(200)
sOut = ReadReply()
End Sub
Friend Sub CloseConnection()
Dim sOut As String = ""
If bConnectionOpen Then
bConnectionOpen = False
SendFTPCommand("QUIT")
sOut = ReadReply()
If Not ReplyContains("221", sOut, strErrorCode,
strErrorMessage) Then
FileClose(intFTPLog)
Throw New FtpClientException(CInt(strErrorCode),
strErrorMessage)
End If
End If
FileClose(intFTPLog)
End Sub
Friend Function GetFileList(ByVal mask As String) As Collection
Dim mTCPData As New TcpClient
Dim mDataStream As NetworkStream
Dim Port As Integer = 20
Dim strIPAddress As String
Dim sOut As String = ""
Dim ASCII As Encoding = Encoding.ASCII
'
Call ReadyDataSocketAndSendCommand("NLST " & mask, _
"GetFileList", mTCPData, mDataStream)
Dim bData(BUFFSIZE) As Byte
Dim bytesRead As Integer = 0
Dim strFileNames As String = ""
' Retrieve the directory listing
bytesRead = mDataStream.Read(bData, 0, BUFFSIZE)
Do While (bytesRead > 0)
strFileNames += ASCII.GetString(bData, 0, bytesRead)
bytesRead = mDataStream.Read(bData, 0, BUFFSIZE)
Application.DoEvents()
Loop
mDataStream.Close()
mDataStream = Nothing
mTCPData.Close()
mTCPData = Nothing
Thread.Sleep(200)
sOut = ReadReply()
'
' Move from String to Collection
'
Dim x As Integer = 0
Dim y As Integer = 0
GetFileList = New Collection
While x < strFileNames.Length
y = strFileNames.IndexOf(CChar(vbCr), x)
GetFileList.Add(strFileNames.Substring(x, y - x))
Debug.WriteLine( _
GetFileList.Count.ToString & " " & _
strFileNames.Substring(x, y - x) & _
" Length=" & strFileNames.Substring(x, y -
x).Length.ToString)
x = y + 2
End While
End Function
Private Function ReadReply(Optional ByVal bMultiLine As Boolean =
False) As String
Dim strCompleteMessage As String = ""
Dim strLastRecordRead As String = ""
Dim tmStart As Date = Now
Do
Application.DoEvents()
If m_commandStream.CanRead Then
Dim myReadBuffer(1024) As Byte
Dim numberOfBytesRead As Integer = 0
Do
Application.DoEvents()
Try
numberOfBytesRead = 0
If m_commandStream.DataAvailable Then
numberOfBytesRead =
m_commandStream.Read(myReadBuffer, 0, myReadBuffer.Length)
End If
Catch ex As Exception
Debug.WriteLine("m_commandStream.Read: " &
ex.Message)
Throw New FtpClientException(0, "ReadReply" &
vbCrLf & ex.Message)
End Try
If numberOfBytesRead > 0 Then
strLastRecordRead =
Encoding.ASCII.GetString(myReadBuffer, 0, numberOfBytesRead)
Debug.Write(Format(Now, "HH:mm:ss.ffff") & " FTP
Response: " & strLastRecordRead)
WriteToFTPLog(strLastRecordRead)
strCompleteMessage =
String.Concat(strCompleteMessage, strLastRecordRead)
End If
Loop While m_commandStream.DataAvailable
End If
Loop Until DateDiff(DateInterval.Second, tmStart, Now) > 5 Or _
(Not bMultiLine AndAlso _
strLastRecordRead.Length > 2 AndAlso
IsNumeric(strLastRecordRead.Substring(0, 3)))
If strCompleteMessage.Length = 0 Then
strCompleteMessage = "No response received"
End If
ReadReply = strCompleteMessage
End Function
Private Function ReplyContains(ByVal strCode As String, ByVal sOut
As String, _
ByRef strErrorCode As String, ByRef strErrorMessage As String)
As Boolean
ReplyContains = sOut.IndexOf(strCode) > -1
strErrorMessage = ""
strErrorCode = "0"
If sOut.Length > 3 AndAlso IsNumeric(sOut.Substring(0, 3)) Then
strErrorCode = sOut.Substring(0, 3)
strErrorMessage = sOut.Substring(3).Trim
End If
End Function
Private Sub ParsePASVResult(ByVal sOut As String, ByRef strIPAddress
As String, ByRef intPortNumber As Integer)
Dim arTokens() As String
Dim x As Integer
Dim y As Integer
Try
x = sOut.IndexOf("(")
y = sOut.IndexOf(")", x)
arTokens = sOut.Substring(x + 1, y - x -
1).Split(CChar(","))
strIPAddress = String.Concat(arTokens(0), ".", arTokens(1),
".", arTokens(2), ".", arTokens(3))
intPortNumber = (CInt(arTokens(4)) * 256) +
CInt(arTokens(5))
Catch ex As Exception
Throw New FtpClientException(0, "Malformed PASV result." &
vbCrLf & ex.Message)
End Try
End Sub
Private Sub WriteToFTPLog(ByVal strMessage As String)
Print(intFTPLog, Format(Now, "MM/dd/yyyy HH:mm:ss.ffff") & " " &
_
strMessage & DirectCast(IIf(strMessage.EndsWith(vbCrLf), "",
vbCrLf), String))
End Sub
Sub ReadyDataSocketAndSendCommand(ByVal strCommand As String, _
ByVal strMethodName As String, _
ByRef mTCPData As TcpClient, _
ByRef mDataStream As NetworkStream)
Dim sOut As String
Dim strIPAddress As String
If (Not bConnectionOpen) Then
Throw New FtpClientException(0, strMethodName & vbCrLf &
"Connection not open")
End If
'
' Set Passive Mode
'
' Passive mode opens the connection on the remote computer and
returns
' a port number to use. Later, this causes message 125. No
worries!
' That's what is supposed to happen.
'
SendFTPCommand("PASV")
sOut = ReadReply()
If Not ReplyContains("227", sOut, strErrorCode, strErrorMessage)
Then
Throw New FtpClientException(CInt(strErrorCode), "PASV" &
vbCrLf & strErrorMessage)
End If
ParsePASVResult(sOut, strIPAddress, Port)
Application.DoEvents()
'
' Open a socket
'
Try
mTCPData = New TcpClient(strIPAddress, Port)
Catch ex As Exception
Throw New FtpClientException(0, "Open Socket" & vbCrLf & _
strIPAddress & " " & Port.ToString & vbCrLf &
ex.Message)
End Try
mTCPData.ReceiveBufferSize = BUFFSIZE
mTCPData.SendBufferSize = BUFFSIZE
Try
mDataStream = mTCPData.GetStream()
Catch ex As Exception
Throw New FtpClientException(0, "GetStream" & vbCrLf & _
strIPAddress & " " & Port.ToString & vbCrLf &
ex.Message)
End Try
' Send the FTP Command to the FTP Server
SendFTPCommand(strCommand)
sOut = ReadReply()
' We will get either a confirmation of the download or an error
message
If Not ReplyContains("150", sOut, strErrorCode, strErrorMessage)
AndAlso _
Not ReplyContains("125", sOut, strErrorCode,
strErrorMessage) Then
Throw New FtpClientException(CInt(strErrorCode), strCommand
& vbCrLf & strErrorMessage)
End If
End Sub
Protected Overrides Sub Finalize()
If bConnectionOpen Then
Call CloseConnection()
End If
End Sub
End Class
Friend Class FtpClientException
Inherits Exception
Dim m_iErrorCode As Integer = 0
Dim m_ErrorMessage As String = ""
Friend Sub New(ByVal code As Integer, ByVal message As String)
m_iErrorCode = code
m_ErrorMessage = message
Throw Me
End Sub
Friend ReadOnly Property ErrorCode() As Integer
Get
Return m_iErrorCode
End Get
End Property
Friend ReadOnly Property ErrorMessage() As String
Get
Return m_ErrorMessage
End Get
End Property
End Class
#If False Then
Function CheckDiskDrive(ByVal strFileTitle As String) As String
Try
Dim d As String = strFileTitle.Substring(0, 2).ToUpper
CheckDiskDrive = ""
If d.Substring(1, 1) = ":" Then
Dim searcher As New ManagementObjectSearcher( _
"SELECT * FROM Win32_LogicalDisk Where Name=" & Chr(34)
& d & Chr(34))
If searcher.Get.Count > 0 Then
Dim share As ManagementObject
For Each share In searcher.Get
Dim decFreespace As Decimal =
System.Convert.ToDecimal(DirectCast(share("FreeSpace"), UInt64)) / (1024 *
1024)
Dim s As String = "=" &
share("Name").ToString.ToUpper
If s.Substring(1) = d Then
s = ""
End If
CheckDiskDrive = d & s & vbNewLine & _
Format(decFreespace,
"###,###,###,###,###,###,###") & "MB Free Disk Space" & vbNewLine & _
DirectCast(IIf(decFreespace < 5, "WARNING:
Severe shortage of disk space", ""), String)
Next share
End If
End If
Catch ex As Exception
CheckDiskDrive = ""
End Try
End Function
#End If
End Module
Regards
Michel Posseth
Lou said:
When I log on to my FTP server I cannot have it go to a know directory.
It always returns a 550. I must have viewd 1000 Google pages and found no
solution.
WHY ISN"T THERE A "CD" WEBREQUEST METHOD!!!!!!!!!!!!!!!!
When I log in and do a PWD I get back
Dir1\dir2\dir3\dir4\dir5
I need to log in and have it go back up four dirs
Dim ftpReq As FtpWebRequest = WebRequest.Create(ftp://MyServer/Dir1//)
I have tried all these variations as well
Dim ftpReq As FtpWebRequest = WebRequest.Create(ftp://MyServer/%2fDir1//)
Dim ftpReq As FtpWebRequest = WebRequest.Create(ftp://MyServer//Dir1//)
-Lou
But, it did work.