by Teera (1 Submission)
Category: OLE/COM/DCOM/Active-X
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 19th May 2000
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
FTP ocx
API Declarations
'Winsock name : tcpService
'Timer : ControlTimer
'Default Property Values:
Const m_def_Password = ""
Const m_def_Username = ""
Const m_def_Url = ""
Const m_def_Port = 21
Const m_def_TimeOut = 12000
'Property Variables:
Dim m_Password As String
Dim m_Username As String
Dim m_Url As String
Dim m_Port As Integer
Dim m_TimeOut As Long
'Event Declarations:
Event State(ByVal Reply As String)
Event Progress(ByVal bytes As Long)
'Variables:
Private Data As String
Private strReply As String
Private Reply As String
Private strCommand As String
Private iFileNum As Integer
Private TimeIsOut As Boolean
Private FileDest As String
Private FileSource As String
VBcoders
tcpServer.Close ' ปิด Control port
TimeIsOut = True ' หมดเวลาในการเชื่อมต่อกับ Server แล้ว
ControlTimer.Enabled = False
MsgBox "Time is out", vbCritical
End Sub
Private Sub TCPserver_Connect() ' Open Control port
RaiseEvent State("Socket connected. Waiting for welcome message..." & vbCrLf)
End Sub
'Port control
Private Sub TCPserver_DataArrival(ByVal bytesTotal As Long)
ControlTimer.Enabled = False
tcpServer.GetData strReply, vbString, tcpServer.BytesReceived ' รับ Reply Code จาก Server
Debug.Print strReply
RaiseEvent State(strReply) ' ส่ง Reply Code ให้กับ Event State
Reply = Left(strReply, 4) ' ตรวจสอบ Reply Code
If InStr(strReply, "220 ") <> 0 Then ' Welcome msg
Reply = "220 "
ElseIf InStr(strReply, "230 ") <> 0 Then ' User logged in, proceed.
Reply = "230 "
ElseIf InStr(strReply, "221 ") <> 0 Then ' Bye
Reply = "221 "
End If
End Sub
Private Sub TCPserver_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
tcpServer.Close ' ปิด Control port
ControlTimer.Enabled = False ' ยกเลิกการจับเวลา
MsgBox Number & vbCrLf & Description, vbCritical
End Sub
Private Sub TCPservice_DataArrival(ByVal bytesTotal As Long)
Dim strBuff As String ' เก็บข้อมูลที่ได้จาก Data port
Dim bytes As Long
bytes = tcpService.BytesReceived
tcpService.GetData strBuff, vbString, tcpService.BytesReceived ' รับข้อมูลจาก Data port มาเก็บไว้ที่ strBuff
If strCommand = "get" Then
RaiseEvent Progress(bytes)
Debug.Print bytes
iFileNum = FreeFile
Open FileDest For Binary As #iFileNum
Put #iFileNum, LOF(iFileNum) + 1, strBuff
Close #iFileNum
Else
Data = Data & strBuff
End If
End Sub
Private Sub TCPservice_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
tcpService.Close ' ปิด Data port
MsgBox Number & vbCrLf & Description, vbCritical
End Sub
Private Sub TCPservice_SendComplete()
tcpService.Close ' ปิด Data port
End Sub
Private Sub tcpService_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
RaiseEvent Progress(bytesSent)
End Sub
'Initialize for User Control
Private Sub UserControl_Initialize()
ControlTimer.Enabled = False
strCommand = ""
strReply = ""
Reply = ""
Me.Username = ""
Me.Password = ""
Me.Url = ""
Me.Port = 21
Me.TimeOut = 12000
End Sub
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
m_Port = m_def_Port
m_Password = m_def_Password
m_Username = m_def_Username
m_Url = m_def_Url
m_TimeOut = m_def_TimeOut
End Sub
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_Port = PropBag.ReadProperty("Port", m_def_Port)
m_Password = PropBag.ReadProperty("Password", m_def_Password)
m_Username = PropBag.ReadProperty("Username", m_def_Username)
m_Url = PropBag.ReadProperty("Url", m_def_Url)
m_TimeOut = PropBag.ReadProperty("TimeOut", m_def_TimeOut)
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("Port", m_Port, m_def_Port)
Call PropBag.WriteProperty("Password", m_Password, m_def_Password)
Call PropBag.WriteProperty("Username", m_Username, m_def_Username)
Call PropBag.WriteProperty("Url", m_Url, m_def_Url)
Call PropBag.WriteProperty("TimeOut", m_TimeOut, m_def_TimeOut)
End Sub
Public Property Let TimeOut(ByVal New_TimeOut As Integer)
m_TimeOut = New_TimeOut
End Property
Public Property Get TimeOut() As Integer
TimeOut = m_TimeOut
End Property
Public Property Let Port(ByVal New_Port As Integer)
m_Port = New_Port
tcpServer.RemotePort = New_Port
End Property
Public Property Get Port() As Integer
Port = m_Port
End Property
Public Property Let Username(ByVal New_Username As String)
m_Username = New_Username
End Property
Public Property Get Username() As String
Username = m_Username
End Property
Public Property Let Password(ByVal New_password As String)
m_Password = New_password
End Property
Public Property Get Password() As String
Password = m_Password
End Property
Public Property Let Url(ByVal New_Url As String)
m_Url = New_Url
tcpServer.RemoteHost = New_Url
End Property
Public Property Get Url() As String
Url = m_Url
End Property
Public Function Cancel()
If tcpServer.State = sckClosed Then Exit Function
RaiseEvent State("ABOR" & vbCrLf)
Reply = ""
tcpServer.SendData "ABOR" & vbCrLf
While Reply <> "225 "
DoEvents
Wend
End Function
Public Function Connect() As Boolean
If tcpServer.State <> sckClosed Then tcpServer.Close
ControlTimer.Enabled = False
On Error GoTo HandlerError
tcpServer.Connect Me.Url, Me.Port
ControlTimer.Interval = Me.TimeOut
ControlTimer.Enabled = True
While Not (Reply = "220 " Or TimeIsOut)
DoEvents
Wend
If TimeIsOut Then Exit Function
ControlTimer.Enabled = False
RaiseEvent State("Connected. Authenicating..." & vbCrLf)
RaiseEvent State("USER " & Me.Username & vbCrLf)
Reply = ""
tcpServer.SendData "USER " & Me.Username & vbCrLf
While Not (Reply = "230 " Or Reply = "331 " Or Reply = "530 ")
DoEvents
Wend
If Reply = "530 " Then
MsgBox "User " & Me.Username & " cannot log in."
tcpServer.Close
Exit Function
End If
RaiseEvent State("PASS *********" & vbCrLf)
Reply = ""
tcpServer.SendData "PASS " & Me.Password & vbCrLf
While Not (Reply = "230 " Or Reply = "530 ")
DoEvents
Wend
If Reply = "530 " Then
MsgBox "User " & Me.Username & " cannot log in."
tcpServer.Close
Exit Function
End If
Connect = True
Exit Function
HandlerError:
tcpServer.Close
ControlTimer.Enabled = False
MsgBox Error(Err.Number)
Connect = False
End Function
Public Sub Disconnect()
If tcpServer.State = sckClosed Then Exit Sub
Reply = ""
RaiseEvent State("QUIT" & vbCrLf)
Reply = ""
tcpServer.SendData "QUIT" & vbCrLf
While Reply <> "221 "
DoEvents
Wend
tcpServer.Close
End Sub
Public Sub Noop()
If tcpServer.State = sckClosed Then Exit Sub
RaiseEvent State("NOOP" & vbCrLf)
Reply = ""
tcpServer.SendData "NOOP" & vbCrLf
While Reply <> "200 "
DoEvents
Wend
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13
Public Function Execute(Optional ByVal Operation As String) As String
If tcpServer.State = sckClosed Then Exit Function
Dim NameFolder As String
Dim iFileNum As Integer
Dim pos As Integer
Dim Temp As String
Dim BlockSize As Long
pos = InStr(Operation, " ")
If pos > 0 Then
strCommand = Left(Operation, pos - 1)
Else
strCommand = Operation
End If
Select Case strCommand
Case "ls"
RaiseEvent State("TYPE A" & vbCrLf)
Reply = ""
tcpServer.SendData "TYPE A" & vbCrLf
While Not (Reply = "200 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "504 " Or Reply = "530 ")
DoEvents
Wend
If Reply <> "200 " Then Exit Function
RaiseEvent State("PASV" & vbCrLf)
Reply = ""
tcpServer.SendData "PASV" & vbCrLf
While Not (Reply = "227 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "530 ")
DoEvents
Wend
If Reply <> "227 " Then Exit Function
ChkPortService strReply
RaiseEvent State("LIST" & vbCrLf)
Reply = ""
tcpServer.SendData "LIST" & vbCrLf
While Reply <> "226 "
DoEvents
Wend
While ChkPort
DoEvents
Wend
Execute = Data
Case "pwd"
RaiseEvent State("PWD" & vbCrLf)
Reply = ""
tcpServer.SendData "PWD" & vbCrLf
While Not (Reply = "257 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "550 ")
DoEvents
Wend
If Reply <> "257 " Then Exit Function
pos = InStr(strReply, Chr(34))
Execute = Mid(strReply, pos + 1, (InStr(pos + 1, strReply, Chr(34)) - 1) - pos)
Case "cd"
NameFolder = Right(Operation, Len(Operation) - pos)
RaiseEvent State("CWD " & NameFolder & vbCrLf)
Reply = ""
tcpServer.SendData "CWD " & NameFolder & vbCrLf
While Not (Reply = "250 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "530 " Or Reply = "550 ")
DoEvents
Wend
Case "cdup"
RaiseEvent State("CDUP" & vbCrLf)
Reply = ""
tcpServer.SendData "CDUP" & vbCrLf
While Not (Reply = "250 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "530 " Or Reply = "550 ")
DoEvents
Wend
Case "delete"
FileDest = Right(Operation, Len(Operation) - pos)
RaiseEvent State("DELE " & FileDest & vbCrLf)
Reply = ""
tcpServer.SendData "DELE " & FileDest & vbCrLf
While Not (Reply = "250 " Or Reply = "421 " Or Reply = "450 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "530 " Or Reply = "550 " Or Reply = "553 ")
DoEvents
Wend
Case "rename"
FileSource = Mid(Operation, pos + 1, InStr(pos + 1, Operation, " to ") - (pos + 1))
FileDest = Right(Operation, Len(Operation) - (InStr(pos + 1, Operation, " to ") + 3))
RaiseEvent State("RNFR " & FileSource & vbCrLf)
Reply = ""
tcpServer.SendData "RNFR " & FileSource & vbCrLf
While Not (Reply = "350 " Or Reply = "421 " Or Reply = "450 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "530 " Or Reply = "550 " Or Reply = "553 ")
DoEvents
Wend
If Reply <> "350 " Then Exit Function
RaiseEvent State("RNTO " & FileDest & vbCrLf)
Reply = ""
tcpServer.SendData "RNTO " & FileDest & vbCrLf
While Not (Reply = "250 " Or Reply = "421 " Or Reply = "450 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "503 " Or Reply = "532 " Or Reply = "553")
DoEvents
Wend
Case "mkdir"
FileDest = Right(Operation, Len(Operation) - pos)
RaiseEvent State("MKD " & FileDest & vbCrLf)
Reply = ""
tcpServer.SendData "MKD " & FileDest & vbCrLf
While Not (Reply = "257 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "530 " Or Reply = "550 ")
DoEvents
Wend
Case "rmdir"
FileDest = Right(Operation, Len(Operation) - pos)
RaiseEvent State("RMD " & FileDest & vbCrLf)
Reply = ""
tcpServer.SendData "RMD " & FileDest & vbCrLf
While Not (Reply = "250 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "530 " Or Reply = "550 " Or Reply = "553 ")
DoEvents
Wend
Case "get"
FileSource = Mid(Operation, pos + 1, InStr(pos + 1, Operation, " to ") - (pos + 1))
FileDest = Right(Operation, Len(Operation) - (InStr(pos + 1, Operation, " to ") + 3))
RaiseEvent State("TYPE I" & vbCrLf)
Reply = ""
tcpServer.SendData "TYPE I" & vbCrLf
While Not (Reply = "200 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "504 " Or Reply = "530 ")
DoEvents
Wend
If Reply <> "200 " Then Exit Function
RaiseEvent State("PASV" & vbCrLf)
Reply = ""
tcpServer.SendData "PASV" & vbCrLf
While Not (Reply = "227 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "530 ")
DoEvents
Wend
If Reply <> "227 " Then Exit Function
ChkPortService strReply
RaiseEvent State("RETR " & FileSource & vbCrLf)
Reply = ""
tcpServer.SendData "RETR " & FileSource & vbCrLf
While Not (Reply = "226 " Or Reply = "550 ")
DoEvents
Wend
While ChkPort
DoEvents
Wend
Case "put"
FileSource = Mid(Operation, pos + 1, InStr(pos + 1, Operation, " to ") - (pos + 1))
FileDest = Right(Operation, Len(Operation) - (InStr(pos + 1, Operation, " to ") + 3))
RaiseEvent State("TYPE I" & vbCrLf)
Reply = ""
tcpServer.SendData "TYPE I" & vbCrLf
While Not (Reply = "200 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "504 " Or Reply = "530 ")
DoEvents
Wend
If Reply <> "200 " Then Exit Function
RaiseEvent State("PASV" & vbCrLf)
Reply = ""
tcpServer.SendData "PASV" & vbCrLf
While Not (Reply = "227 " Or Reply = "421 " Or Reply = "500 " Or Reply = "501 " Or Reply = "502 " Or Reply = "530 ")
DoEvents
Wend
If Reply <> "227 " Then Exit Function
ChkPortService strReply
RaiseEvent State("STOR " & FileDest & vbCrLf)
Reply = ""
tcpServer.SendData "STOR " & FileDest & vbCrLf
While Not (Reply = "125 " Or Reply = "150 " Or Reply = "421 " Or Reply = "425 " Or Reply = "426 " Or Reply = "450 " Or Reply = "451 " Or Reply = "452 " Or Reply = "500 " Or Reply = "501 " Or Reply = "504 " Or Reply = "530 " Or Reply = "532 " Or Reply = "550 " Or Reply = "551 " Or Reply = "552 " Or Reply = "553 ")
DoEvents
Wend
If (Reply <> "125 " And Reply <> "150 ") Then Exit Function
iFileNum = FreeFile
Open FileSource For Binary As #iFileNum
BlockSize = LOF(iFileNum)
Temp = Space$(BlockSize)
Get #iFileNum, , Temp
Close #iFileNum
tcpService.SendData Temp
Reply = ""
While Not (Reply = "226 " Or Reply = "425 " Or Reply = "426 " Or Reply = "450 " Or Reply = "451 ")
DoEvents
Wend
End Select
End Function
Private Sub ChkPortService(DataPort As String)
Dim b(5) As Integer
Dim pStop As Integer, Index As Integer
Dim PortInfo As String
Dim AddressOfData As String
Dim PortOfData As Long
PortInfo = Mid(strReply, InStr(strReply, "(") + 1, InStr(strReply, ")") - (InStr(strReply, "(") + 1))
Index = 0
While Index <> 6
If Index <> 5 Then
pStop = InStr(PortInfo, ",") - 1
b(Index) = Left(PortInfo, pStop)
PortInfo = Right(PortInfo, Len(PortInfo) - (pStop + 1))
Else
b(Index) = PortInfo
End If
Index = Index + 1
Wend
AddressOfData = b(0) & "." & b(1) & "." & b(2) & "." & b(3)
PortOfData = Val(b(4)) * 256 + Val(b(5))
tcpService.RemoteHost = AddressOfData
tcpService.RemotePort = PortOfData
Data = ""
tcpService.Connect
End Sub
Private Function ChkPort() As Boolean
On Local Error GoTo HandlerError
tcpService.SendData ""
ChkPort = True
Exit Function
HandlerError:
tcpService.Close
ChkPort = False
End Function
