• Home
 · 
• OLE/COM/DCOM/Active-X
 · 
• FTP ocx

FTP ocx

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




Rate FTP ocx

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

    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                                                     ' &#3611;&#3636;&#3604; Control port
    ControlTimer.Enabled = False                          ' &#3618;&#3585;&#3648;&#3621;&#3636;&#3585;&#3585;&#3634;&#3619;&#3592;&#3633;&#3610;&#3648;&#3623;&#3621;&#3634;
    MsgBox Number & vbCrLf & Description, vbCritical
End Sub

Private Sub TCPservice_DataArrival(ByVal bytesTotal As Long)
    Dim strBuff As String              ' &#3648;&#3585;&#3655;&#3610;&#3586;&#3657;&#3629;&#3617;&#3641;&#3621;&#3607;&#3637;&#3656;&#3652;&#3604;&#3657;&#3592;&#3634;&#3585; Data port
    Dim bytes As Long
    bytes = tcpService.BytesReceived
    tcpService.GetData strBuff, vbString, tcpService.BytesReceived          ' &#3619;&#3633;&#3610;&#3586;&#3657;&#3629;&#3617;&#3641;&#3621;&#3592;&#3634;&#3585; Data port &#3617;&#3634;&#3648;&#3585;&#3655;&#3610;&#3652;&#3623;&#3657;&#3607;&#3637;&#3656; 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                 ' &#3611;&#3636;&#3604; Data port
    MsgBox Number & vbCrLf & Description, vbCritical
End Sub

Private Sub TCPservice_SendComplete()
   tcpService.Close          ' &#3611;&#3636;&#3604; 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