ftpconnect.bas

利用RS232做通訊 可以執行自動功能 謝謝大家使用

Private Const INTERNET_STATUS_CONNECTING_TO_SERVER  As Long = 20
Private Const INTERNET_STATUS_CONNECTED_TO_SERVER   As Long = 21
Private Const INTERNET_STATUS_SENDING_REQUEST       As Long = 30
Private Const INTERNET_STATUS_REQUEST_SENT          As Long = 31
Private Const INTERNET_STATUS_RECEIVING_RESPONSE    As Long = 40
Private Const INTERNET_STATUS_RESPONSE_RECEIVED     As Long = 41
Private Const INTERNET_STATUS_CTL_RESPONSE_RECEIVED As Long = 42
Private Const INTERNET_STATUS_PREFETCH              As Long = 43
Private Const INTERNET_STATUS_CLOSING_CONNECTION    As Long = 50
Private Const INTERNET_STATUS_CONNECTION_CLOSED     As Long = 51
Private Const INTERNET_STATUS_HANDLE_CREATED        As Long = 60
Private Const INTERNET_STATUS_HANDLE_CLOSING        As Long = 70
Private Const INTERNET_STATUS_DETECTING_PROXY       As Long = 80
Private Const INTERNET_STATUS_REQUEST_COMPLETE      As Long = 0
Private Const INTERNET_STATUS_REDIRECT              As Long = 10
Private Const INTERNET_STATUS_INTERMEDIATE_RESPONSE As Long = 20
Private Const INTERNET_STATUS_USER_INPUT_REQUIRED   As Long = 40
Private Const INTERNET_STATUS_STATE_CHANGE          As Long = 200

'connected state (mutually exclusive with disconnected)
Public Const INTERNET_STATE_CONNECTED  As Long = &H1
'disconnected from network
Public Const INTERNET_STATE_DISCONNECTED  As Long = &H2
'disconnected by user request
Public Const INTERNET_STATE_DISCONNECTED_BY_USER  As Long = &H10
'no network requests being made (by Wininet)
Public Const INTERNET_STATE_IDLE As Long = &H100
'network requests being made (by Wininet)
Public Const INTERNET_STATE_BUSY As Long = &H200

Private Type INTERNET_ASYNC_RESULT
   dwResult As Long
   dwError As Long
End Type

'variables for callback
Public dwCurrentFileSize As Long  'file size of download
Public pub_BytesSent As Long      'tracks bytes send
Public pub_BytesRecieved As Long  'tracks bytes received
Public sMsg As String
Public dwRead As Long
Public sMsg1 As String


'******************************
'   Vars                      *
'******************************
Public pData As WIN32_FIND_DATA
Public hFind As Long
Public hINetSession As Long
Public hSession As Long
Public hConnectSession As Long
Public hSession1 As Long
Public hRequest As Long
Public hCallBack As Long
Public MyServer As String
Public i As Long
Public FileName As String
Public bRet As Boolean
Public List As ListItem
Public Attrib As Byte
Public nLastError As Long
Public dError As Long
Public RDirectory As String
Public RDirectory1 As String
Public RRDirectory As String
Public RRDirectory1 As String
'For Form2****************
'Public frm(50) As New Form2
Public IndexForm
'*************************
'For Form3****************
'Public frm1(3) As New Form3
Public IndexForm1
'*************************
Public aq
Public msg As String
Public SetDir As Boolean
Public op
Public Test As Integer
Public dwType As Long
Public dwsize As Long
Public nSize As Long
''Public buff As String
Public r As Long
Public rSize As Long
Public sCurrDir As String
Public nCurrDir As Long
Public CurrentState As Long

'*********************
'* Vars              *
'*********************
Public Function FtpCallbackStatus(ByVal hInternet As Long, ByVal dwContext As Long, ByVal dwInternetStatus As Long, ByVal lpvStatusInfo As Long, ByVal dwStatusInfoLength As Long) As Long
        'the link between this function and the rest of
        'this prog.. is dwContext (0 inhibited and 1 exhibited)
        Dim cBuffer As String
        Dim dwRead As Long
        Dim pub_BytesRecieved As Long
        cBuffer = Space(dwStatusInfoLength)
        'The instructions go by two Client/Server
        Select Case dwInternetStatus
            'Connection to the Server
            Case INTERNET_STATUS_RESOLVING_NAME
                MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
                sMsg = "Looking up the IP address for " & cBuffer
            Case INTERNET_STATUS_NAME_RESOLVED
                MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
                sMsg = "Name resolved " & cBuffer
            'Research of I.P
            Case INTERNET_STATUS_CONNECTING_TO_SERVER
                MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
                sMsg = "Connecting to server..." & cBuffer
            Case INTERNET_STATUS_CONNECTED_TO_SERVER
                MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
                sMsg = "Connected to " & cBuffer
            'A number of Byte sent to the Server from the Client
            Case INTERNET_STATUS_SENDING_REQUEST
            Case INTERNET_STATUS_REQUEST_SENT
                MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
                pub_BytesSent = pub_BytesSent + dwRead
                'Here is the progressBar for Uploading
                If CurrentState = 2 Then     'FTP_UPLOADING
     '               frm(IndexForm).ProgressBar1.Value = IIf(pub_BytesSent < dwCurrentFileSize, pub_BytesSent, dwCurrentFileSize)
                End If
            'A number of Bytes received by the Client from the Server
            Case INTERNET_STATUS_RESPONSE_RECEIVED
                MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
                pub_BytesRecieved = pub_BytesRecieved + dwRead
                'Here is the progressBar for Downloading
                If CurrentState = 1 Then  'FTP_DOWNLOADING
    '                frm(IndexForm).ProgressBar1.Value = frm(IndexForm).ProgressBar1.Value + IIf(pub_BytesRecieved < dwCurrentFileSize, pub_BytesRecieved, dwCurrentFileSize)
                End If
            Case INTERNET_STATUS_RECEIVING_RESPONSE
            'Here arrives two values not yet implemented
            'perhaps one day...(make think to Hooks...)
            Case INTERNET_STATUS_CTL_RESPONSE_RECEIVED
            Case INTERNET_STATUS_PREFETCH
            'Close the connection
            Case INTERNET_STATUS_CLOSING_CONNECTION
            Case INTERNET_STATUS_CONNECTION_CLOSED
            'Open a connection
            Case INTERNET_STATUS_HANDLE_CREATED
                'MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
            'close a connection
            Case INTERNET_STATUS_HANDLE_CLOSING
                If CurrentState = 1 Then
                    sMsg1 = "Download complete. "
                End If
                
                If CurrentState = 2 Then
                    sMsg1 = "Upload complete. "
                End If
            'Notifies Client for a Proxy
            Case INTERNET_STATUS_DETECTING_PROXY
            '
            Case INTERNET_STATUS_REQUEST_COMPLETE
            '
            Case INTERNET_STATUS_REDIRECT
            '
            Case INTERNET_STATUS_INTERMEDIATE_RESPONSE
            '
            Case INTERNET_STATUS_STATE_CHANGE
                'MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
                 Select Case dwRead
                    Case INTERNET_STATE_CONNECTED
                    Case INTERNET_STATE_DISCONNECTED
                    Case INTERNET_STATE_DISCONNECTED_BY_USER
                    Case INTERNET_STATE_IDLE
                    Case INTERNET_STATE_BUSY
                    Case INTERNET_STATUS_USER_INPUT_REQUIRED
                 End Select
        End Select
End Function



Public Function DELETESTRING(Ctrl As Object, Message As Long) As Boolean
    Dim i, j
    With Ctrl
        For i = 0 To .ListCount - 2
        For j = i + 1 To .ListCount - 1
            If .List(i) = .List(j) Then
                SendMessage Ctrl.hwnd, Message, j, 0
                j = j - 1
            End If
        Next j
    Next i
    End With
End Function


Public Function ftpEnumDirectory(PathServer As String, frm As Form) As Boolean
    dError = NO_ERROR
    pData.cFileName = String(MAX_PATH, 0)
    hFind = FtpFindFirstFile(hSession, "*.*", pData, INTERNET_FLAG_RELOAD Or INTERNET_FLAG_NO_CACHE_WRITE, 0)
    nLastError = err.LastDllError
    If hFind = 0 Then
        If (nLastError = ERROR_NO_MORE_FILES) Then
            MsgBox "This directory is empty!", vbOKOnly, "Up/Download FTP"
        Else
            MsgBox "In FtpFindFirstFile API is the error ", vbOKOnly, "Up/Download FTP"
        End If
        ftpEnumDirectory = False
        InternetCloseHandle hFind
        InternetCloseHandle hConnectSession
        Exit Function
    End If
    Attrib = pData.dwFileAttributes
    FileName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
        If Attrib = 16 Then
        '    Set List = Frm_Series.ListView1.ListItems.Add(, , FileName, , 1): List.SubItems(1) = Format(pData.nFileSizeLow, "#,#"): List.SubItems(2) = TType(FileName, Attrib): List.SubItems(3) = TTime(pData.ftLastWriteTime)
        ElseIf Attrib = 0 Then
            Set List = Frm_Series.ListView1.ListItems.Add(, , FileName, , 4): List.SubItems(1) = Format(pData.nFileSizeLow, "#,#"): List.SubItems(2) = TType(FileName, Attrib): List.SubItems(3) = TTime(pData.ftLastWriteTime)
        Else
            Set List = Frm_Series.ListView1.ListItems.Add(, , FileName, , 0): List.SubItems(1) = Format(pData.nFileSizeLow, "#,#"): List.SubItems(2) = TType(FileName, Attrib)
        End If
    Do
        pData.cFileName = String(MAX_PATH, 0)
        bRet = InternetFindNextFile(hFind, pData)
        If Not bRet Then
            dError = err.LastDllError
            If dError = ERROR_NO_MORE_FILES Then
                Exit Do
            Else
                MsgBox "In InternetFindNextFile API is the error.", vbOKOnly, "Up/Download FTP"
                InternetCloseHandle (hFind)
                hFind = 0
                ftpEnumDirectory = False
               Exit Function
            End If
        Else
        Attrib = pData.dwFileAttributes
        FileName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
        If Attrib = 16 Then
        '    Set List = Frm_Series.ListView1.ListItems.Add(, , FileName, , 1): List.SubItems(1) = Format(pData.nFileSizeLow, "#,#"): List.SubItems(2) = TType(FileName, Attrib): List.SubItems(3) = TTime(pData.ftLastWriteTime)
        ElseIf Attrib = 0 Then
            Set List = Frm_Series.ListView1.ListItems.Add(, , FileName, , 4): List.SubItems(1) = Format(pData.nFileSizeLow, "#,#"): List.SubItems(2) = TType(FileName, Attrib): List.SubItems(3) = TTime(pData.ftLastWriteTime)
        Else
            Set List = Frm_Series.ListView1.ListItems.Add(, , FileName, , 0): List.SubItems(1) = Format(pData.nFileSizeLow, "#,#"): List.SubItems(2) = TType(FileName, Attrib): List.SubItems(3) = TTime(pData.ftLastWriteTime)
        End If
        End If
        
        
    
    Loop
    InternetCloseHandle hFind
    InternetCloseHandle hConnectSession
    hFind = 0
    frm.ListView1.Sorted = True
    ftpEnumDirectory = True
    ''MsgBox "Folder Server is:    " & RDirectory, vbOKOnly, "Up/Download FTP"
End Function
Public Function TTime(tt As FILETIME) As String
    Dim tt1 As FILETIME
    Dim yy As SYSTEMTIME
    FileTimeToLocalFileTime tt, tt1
    FileTimeToSystemTime tt1, yy
    TTime = Format(Str$(yy.wMonth), "00") + "/" + Format(Str$(yy.wDay), "00") + "/" + Str$(yy.wYear)
End Function
Public Function TType(ff As String, aa As Byte) As String
    Dim op
    If aa = 16 Then
    TType = "FOLDER"
    Exit Function
    End If
    op = InStr(1, ff, ".")
    If op = 0 Or op = 1 Then
    TType = ""
    Exit Function
    End If
    TType = UCase(Right(ff, Len(ff) - op)) + "   File"
End Function
Public Sub CenterForm(fmrx As Form)
    fmrx.Move (Screen.Width - fmrx.Width) / 2, (Screen.Height - fmrx.Height) / 2
End Sub
Public Function FileSize(file As String) As Long
    Dim fHandle As Long
    For i = 1 To Len(file)
    If Mid(file, i, 1) < Chr$(32) Then file = Left(file, i - 1): Exit For
    Next
    fHandle = CreateFile(file, GENERIC_READ, 0, 0, 3, &H80, 0)
    rSize = GetFileSize(fHandle, nSize)
    CloseHandle fHandle
    FileSize = rSize
End Function