| server2009 | Дата: Суббота, 21.08.2010, 11:30 | Сообщение # 1 |
 Admin
Группа: Администраторы
Сообщений: 18
Статус: Offline
| Код Option Explicit
Public hInternet As Long
Public hConnect As Long
Public hCallback As Long
Public FtpErrorMessage As String
Public bFtpShowMessages As Boolean
Public Const sFtpUserName As String = "anonymous"
Public Const sFtpPassword As String = "youremail@whatever.com"
Public Const sLocalDownloadPath As String = "d:\ftptest\"
Public Const sRootDots As String = ".."
Public Const sSlash As String = "/"
Public dwCurrentFileSize As Double 'file size of download
Public pub_BytesSent As Double 'tracks bytes send
Public pub_BytesRecieved As Double 'tracks bytes received
Private Const MAX_PATH As Long = 260
Private Const MAXDWORD As Double = (2 ^ 32) - 1
Private Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
Private Const WM_SETREDRAW As Long = &HB
Private Const GENERIC_READ As Long = &H80000000
Private Const INTERNET_SUCCESS As Long = 1
Public Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
Public Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
Public Const INTERNET_OPEN_TYPE_PROXY As Long = 3
Public Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY As Long = 4
Public Const INTERNET_FLAG_PASSIVE As Long = &H8000000
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000
Public Const INTERNET_FLAG_NO_CACHE_WRITE As Long = &H4000000
Public Const INTERNET_FLAG_DONT_CACHE As Long = INTERNET_FLAG_NO_CACHE_WRITE
Public Const INTERNET_FLAG_MAKE_PERSISTENT As Long = &H2000000
Public Const INTERNET_FLAG_FROM_CACHE As Long = &H1000000
Public Const INTERNET_FLAG_OFFLINE As Long = INTERNET_FLAG_FROM_CACHE
Public Const INTERNET_FLAG_SECURE As Long = &H800000
Public Const INTERNET_FLAG_KEEP_CONNECTION As Long = &H400000
Public Const INTERNET_FLAG_NO_AUTO_REDIRECT As Long = &H200000
Public Const INTERNET_FLAG_READ_PREFETCH As Long = &H100000
Public Const INTERNET_FLAG_NO_COOKIES As Long = &H80000
Public Const INTERNET_FLAG_NO_AUTH As Long = &H40000
Public Const INTERNET_FLAG_CACHE_IF_NET_FAIL As Long = &H10000
Public Const INTERNET_DEFAULT_FTP_PORT As Long = 21
Public Const INTERNET_DEFAULT_GOPHER_PORT As Long = 70
Public Const INTERNET_DEFAULT_HTTP_PORT As Long = 80
Public Const INTERNET_DEFAULT_HTTPS_PORT As Long = 443
Public Const INTERNET_DEFAULT_SOCKS_PORT As Long = 1080
Public Const INTERNET_FLAG_EXISTING_CONNECT As Long = &H20000000
Public Const INTERNET_SERVICE_FTP As Long = 1
Public Const INTERNET_SERVICE_GOPHER As Long = 2
Public Const INTERNET_SERVICE_HTTP As Long = 3
Public Const INTERNET_STATE_CONNECTED As Long = &H1
Public Const INTERNET_STATE_DISCONNECTED As Long = &H2
Public Const INTERNET_STATE_DISCONNECTED_BY_USER As Long = &H10
Public Const INTERNET_STATE_IDLE As Long = &H100
Public Const INTERNET_STATE_BUSY As Long = &H200
Private Const FTP_TRANSFER_TYPE_UNKNOWN As Long = &H0
Private Const FTP_TRANSFER_TYPE_ASCII As Long = &H1
Private Const FTP_TRANSFER_TYPE_BINARY As Long = &H2
Private Const INTERNET_FLAG_TRANSFER_ASCII As Long = FTP_TRANSFER_TYPE_ASCII
Private Const INTERNET_FLAG_TRANSFER_BINARY As Long = FTP_TRANSFER_TYPE_BINARY
Private Const FTP_TRANSFER_TYPE_MASK As Long = (FTP_TRANSFER_TYPE_ASCII Or _
FTP_TRANSFER_TYPE_BINARY)
Public Const INTERNET_INVALID_STATUS_CALLBACK As Long = -1
Private Const INTERNET_STATUS_RESOLVING_NAME As Long = 10
Private Const INTERNET_STATUS_NAME_RESOLVED As Long = 11
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 = 100
Private Const INTERNET_STATUS_REDIRECT As Long = 110
Private Const INTERNET_STATUS_INTERMEDIATE_RESPONSE As Long = 120
Private Const INTERNET_STATUS_USER_INPUT_REQUIRED As Long = 140
Private Const INTERNET_STATUS_STATE_CHANGE As Long = 200
Private Const INTERNET_ERROR_BASE As Long = 12000
Private Const ERROR_INTERNET_OUT_OF_HANDLES As Long = (INTERNET_ERROR_BASE + 1)
Private Const ERROR_INTERNET_TIMEOUT As Long = (INTERNET_ERROR_BASE + 2)
Private Const ERROR_INTERNET_EXTENDED_ERROR As Long = (INTERNET_ERROR_BASE + 3)
Private Const ERROR_INTERNET_INTERNAL_ERROR As Long = (INTERNET_ERROR_BASE + 4)
Private Const ERROR_INTERNET_INVALID_URL As Long = (INTERNET_ERROR_BASE + 5)
Private Const ERROR_INTERNET_UNRECOGNIZED_SCHEME As Long = (INTERNET_ERROR_BASE + 6)
Private Const ERROR_INTERNET_NAME_NOT_RESOLVED As Long = (INTERNET_ERROR_BASE + 7)
Private Const ERROR_INTERNET_PROTOCOL_NOT_FOUND As Long = (INTERNET_ERROR_BASE + 8)
Private Const ERROR_INTERNET_INVALID_OPTION As Long = (INTERNET_ERROR_BASE + 9)
Private Const ERROR_INTERNET_BAD_OPTION_LENGTH As Long = (INTERNET_ERROR_BASE + 10)
Private Const ERROR_INTERNET_OPTION_NOT_SETTABLE As Long = (INTERNET_ERROR_BASE + 11)
Private Const ERROR_INTERNET_SHUTDOWN As Long = (INTERNET_ERROR_BASE + 12)
Private Const ERROR_INTERNET_INCORRECT_USER_NAME As Long = (INTERNET_ERROR_BASE + 13)
Private Const ERROR_INTERNET_INCORRECT_PASSWORD As Long = (INTERNET_ERROR_BASE + 14)
Private Const ERROR_INTERNET_LOGIN_FAILURE As Long = (INTERNET_ERROR_BASE + 15)
Private Const ERROR_INTERNET_INVALID_OPERATION As Long = (INTERNET_ERROR_BASE + 16)
Private Const ERROR_INTERNET_OPERATION_CANCELLED As Long = (INTERNET_ERROR_BASE + 17)
Private Const ERROR_INTERNET_INCORRECT_HANDLE_TYPE As Long = (INTERNET_ERROR_BASE + 18)
Private Const ERROR_INTERNET_INCORRECT_HANDLE_STATE As Long = (INTERNET_ERROR_BASE + 19)
Private Const ERROR_INTERNET_NOT_PROXY_REQUEST As Long = (INTERNET_ERROR_BASE + 20)
Private Const ERROR_INTERNET_REGISTRY_VALUE_NOT_FOUND As Long = (INTERNET_ERROR_BASE + 21)
Private Const ERROR_INTERNET_BAD_REGISTRY_PARAMETER As Long = (INTERNET_ERROR_BASE + 22)
Private Const ERROR_INTERNET_NO_DIRECT_ACCESS As Long = (INTERNET_ERROR_BASE + 23)
Private Const ERROR_INTERNET_NO_CONTEXT As Long = (INTERNET_ERROR_BASE + 24)
Private Const ERROR_INTERNET_NO_CALLBACK As Long = (INTERNET_ERROR_BASE + 25)
Private Const ERROR_INTERNET_REQUEST_PENDING As Long = (INTERNET_ERROR_BASE + 26)
Private Const ERROR_INTERNET_INCORRECT_FORMAT As Long = (INTERNET_ERROR_BASE + 27)
Private Const ERROR_INTERNET_ITEM_NOT_FOUND As Long = (INTERNET_ERROR_BASE + 28)
Private Const ERROR_INTERNET_CANNOT_CONNECT As Long = (INTERNET_ERROR_BASE + 29)
Private Const ERROR_INTERNET_CONNECTION_ABORTED As Long = (INTERNET_ERROR_BASE + 30)
Private Const ERROR_INTERNET_CONNECTION_RESET As Long = (INTERNET_ERROR_BASE + 31)
Private Const ERROR_INTERNET_FORCE_RETRY As Long = (INTERNET_ERROR_BASE + 32)
Private Const ERROR_INTERNET_INVALID_PROXY_REQUEST As Long = (INTERNET_ERROR_BASE + 33)
Private Const ERROR_INTERNET_NEED_UI As Long = (INTERNET_ERROR_BASE + 34)
Private Const ERROR_INTERNET_HANDLE_EXISTS As Long = (INTERNET_ERROR_BASE + 36)
Private Const ERROR_INTERNET_SEC_CERT_DATE_INVALID As Long = (INTERNET_ERROR_BASE + 37)
Private Const ERROR_INTERNET_SEC_CERT_CN_INVALID As Long = (INTERNET_ERROR_BASE + 38)
Private Const ERROR_INTERNET_HTTP_TO_HTTPS_ON_REDIR As Long = (INTERNET_ERROR_BASE + 39)
Private Const ERROR_INTERNET_HTTPS_TO_HTTP_ON_REDIR As Long = (INTERNET_ERROR_BASE + 40)
Private Const ERROR_INTERNET_MIXED_SECURITY As Long = (INTERNET_ERROR_BASE + 41)
Private Const ERROR_INTERNET_CHG_POST_IS_NON_SECURE As Long = (INTERNET_ERROR_BASE + 42)
Private Const ERROR_INTERNET_POST_IS_NON_SECURE As Long = (INTERNET_ERROR_BASE + 43)
Private Const ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED As Long = (INTERNET_ERROR_BASE + 44)
Private Const ERROR_INTERNET_INVALID_CA As Long = (INTERNET_ERROR_BASE + 45)
Private Const ERROR_INTERNET_CLIENT_AUTH_NOT_SETUP As Long = (INTERNET_ERROR_BASE + 46)
Private Const ERROR_INTERNET_ASYNC_THREAD_FAILED As Long = (INTERNET_ERROR_BASE + 47)
Private Const ERROR_INTERNET_REDIRECT_SCHEME_CHANGE As Long = (INTERNET_ERROR_BASE + 48)
Private Const ERROR_INTERNET_DIALOG_PENDING As Long = (INTERNET_ERROR_BASE + 49)
Private Const ERROR_INTERNET_RETRY_DIALOG As Long = (INTERNET_ERROR_BASE + 50)
Private Const ERROR_INTERNET_HTTPS_HTTP_SUBMIT_REDIR As Long = (INTERNET_ERROR_BASE + 52)
Private Const ERROR_INTERNET_INSERT_CD-ROM As Long = (INTERNET_ERROR_BASE + 53)
Private Const ERROR_INTERNET_FORTEZZA_LOGIN_NEEDED As Long = (INTERNET_ERROR_BASE + 54)
Private Const ERROR_INTERNET_SEC_CERT_ERRORS As Long = (INTERNET_ERROR_BASE + 55)
Private Const ERROR_INTERNET_SEC_CERT_NO_REV As Long = (INTERNET_ERROR_BASE + 56)
Private Const ERROR_INTERNET_SEC_CERT_REV_FAILED As Long = (INTERNET_ERROR_BASE + 57)
Private Const ERROR_FTP_TRANSFER_IN_PROGRESS As Long = (INTERNET_ERROR_BASE + 110)
Private Const ERROR_FTP_DROPPED As Long = (INTERNET_ERROR_BASE + 111)
Private Const ERROR_FTP_NO_PASSIVE_MODE As Long = (INTERNET_ERROR_BASE + 112)
Private Const ERROR_GOPHER_PROTOCOL_ERROR As Long = (INTERNET_ERROR_BASE + 130)
Private Const ERROR_GOPHER_NOT_FILE As Long = (INTERNET_ERROR_BASE + 131)
Private Const ERROR_GOPHER_DATA_ERROR As Long = (INTERNET_ERROR_BASE + 132)
Private Const ERROR_GOPHER_END_OF_DATA As Long = (INTERNET_ERROR_BASE + 133)
Private Const ERROR_GOPHER_INVALID_LOCATOR As Long = (INTERNET_ERROR_BASE + 134)
Private Const ERROR_GOPHER_INCORRECT_LOCATOR_TYPE As Long = (INTERNET_ERROR_BASE + 135)
Private Const ERROR_GOPHER_NOT_GOPHER_PLUS As Long = (INTERNET_ERROR_BASE + 136)
Private Const ERROR_GOPHER_ATTRIBUTE_NOT_FOUND As Long = (INTERNET_ERROR_BASE + 137)
Private Const ERROR_GOPHER_UNKNOWN_LOCATOR As Long = (INTERNET_ERROR_BASE + 138)
Private Const ERROR_HTTP_HEADER_NOT_FOUND As Long = (INTERNET_ERROR_BASE + 150)
Private Const ERROR_HTTP_DOWNLEVEL_SERVER As Long = (INTERNET_ERROR_BASE + 151)
Private Const ERROR_HTTP_INVALID_SERVER_RESPONSE As Long = (INTERNET_ERROR_BASE + 152)
Private Const ERROR_HTTP_INVALID_HEADER As Long = (INTERNET_ERROR_BASE + 153)
Private Const ERROR_HTTP_INVALID_QUERY_REQUEST As Long = (INTERNET_ERROR_BASE + 154)
Private Const ERROR_HTTP_HEADER_ALREADY_EXISTS As Long = (INTERNET_ERROR_BASE + 155)
Private Const ERROR_HTTP_REDIRECT_FAILED As Long = (INTERNET_ERROR_BASE + 156)
Private Const ERROR_HTTP_NOT_REDIRECTED As Long = (INTERNET_ERROR_BASE + 160)
Private Const ERROR_HTTP_COOKIE_NEEDS_CONFIRMATION As Long = (INTERNET_ERROR_BASE + 161)
Private Const ERROR_HTTP_COOKIE_DECLINED As Long = (INTERNET_ERROR_BASE + 162)
Private Const ERROR_HTTP_REDIRECT_NEEDS_CONFIRMATION As Long = (INTERNET_ERROR_BASE + 168)
Private Const ERROR_INTERNET_SECURITY_CHANNEL_ERROR As Long = (INTERNET_ERROR_BASE + 157)
Private Const ERROR_INTERNET_UNABLE_TO_CACHE_FILE As Long = (INTERNET_ERROR_BASE + 158)
Private Const ERROR_INTERNET_TCPIP_NOT_INSTALLED As Long = (INTERNET_ERROR_BASE + 159)
Private Const ERROR_INTERNET_DISCONNECTED As Long = (INTERNET_ERROR_BASE + 163)
Private Const ERROR_INTERNET_SERVER_UNREACHABLE As Long = (INTERNET_ERROR_BASE + 164)
Private Const ERROR_INTERNET_PROXY_SERVER_UNREACHABLE As Long = (INTERNET_ERROR_BASE + 165)
Private Const ERROR_INTERNET_BAD_AUTO_PROXY_SCRIPT As Long = (INTERNET_ERROR_BASE + 166)
Private Const ERROR_INTERNET_UNABLE_TO_DOWNLOAD_SCRIPT As Long = (INTERNET_ERROR_BASE + 167)
Private Const ERROR_INTERNET_SEC_INVALID_CERT As Long = (INTERNET_ERROR_BASE + 169)
Private Const ERROR_INTERNET_SEC_CERT_REVOKED As Long = (INTERNET_ERROR_BASE + 170)
Private Const ERROR_INTERNET_FAILED_DUETOSECURITYCHECK As Long = (INTERNET_ERROR_BASE + 171)
Private Const ERROR_INTERNET_NOT_INITIALIZED As Long = (INTERNET_ERROR_BASE + 172)
Private Const ERROR_INTERNET_NEED_MSN_SSPI_PKG As Long = (INTERNET_ERROR_BASE + 173)
Private Const ERROR_INTERNET_LOGIN_FAILURE_DISPLAY_ENTITY_BODY As Long = (INTERNET_ERROR_BASE + 174)
Private Const INTERNET_ERROR_LAST = ERROR_INTERNET_FAILED_DUETOSECURITYCHECK
Public Const LB_SETTABSTOPS As Long = &H192
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Type INTERNET_ASYNC_RESULT
dwResult As Long
dwError As Long
End Type
Private Enum FTP_STATES
FTP_WAIT
FTP_ENUM
FTP_DOWNLOAD
FTP_DOWNLOADING
FTP_UPLOAD
FTP_UPLOADING
FTP_CREATINGDIR
FTP_CREATEDIR
FTP_REMOVINGDIR
FTP_REMOVEDIR
FTP_DELETINGFILE
FTP_DELETEFILE
FTP_RENAMINGFILE
FTP_RENAMEFILE
FTP_ENUMFILES
End Enum
Private CurrentState As FTP_STATES
Public Declare Function InternetOpen Lib "wininet" _
Alias "InternetOpenA" _
(ByVal lpszAgent As String, _
ByVal dwAccessType As Long, _
ByVal lpszProxyName As String, _
ByVal lpszProxyBypass As String, _
ByVal dwFlags As Long) As Long
Public Declare Function InternetCloseHandle Lib "wininet" _
(ByVal hEnumHandle As Long) As Long
Public Declare Function InternetConnect Lib "wininet" _
Alias "InternetConnectA" _
(ByVal hInternet As Long, _
ByVal lpszServerName As String, _
ByVal nServerPort As Long, _
ByVal lpszUserName As String, _
ByVal lpszPassword As String, _
ByVal dwService As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare Function FtpFindFirstFile Lib "wininet" _
Alias "FtpFindFirstFileA" _
(ByVal hConnect As Long, _
ByVal lpszSearchFile As String, _
lpFindFileData As Any, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet" _
Alias "InternetFindNextFileA" _
(ByVal hFind As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function InternetSetStatusCallback Lib "wininet" _
(ByVal hInternet As Long, _
ByVal lpfnInternetCallback As Long) As Long
Private Declare Function InternetGetLastResponseInfo Lib "wininet" _
Alias "InternetGetLastResponseInfoA" _
(lpdwError As Long, _
ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Long
Private Declare Function FtpGetCurrentDirectory Lib "wininet" _
Alias "FtpGetCurrentDirectoryA" _
(ByVal hConnect As Long, _
ByVal lpszCurrentDirectory As String, _
lpdwCurrentDirectory As Long) As Long
Public Declare Function FtpSetCurrentDirectory Lib "wininet" _
Alias "FtpSetCurrentDirectoryA" _
(ByVal hConnect As Long, _
ByVal lpszDirectory As String) As Long
Private Declare Function FtpGetFileSize Lib "wininet" _
(ByVal hConnect As Long, _
lpdwFileSizeHigh As Long) As Long
Private Declare Function FtpOpenFile Lib "wininet" _
Alias "FtpOpenFileA" _
(ByVal hConnect As Long, _
ByVal lpszFileName As String, _
ByVal dwAccess As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function FtpGetFile Lib "wininet" _
Alias "FtpGetFileA" _
(ByVal hConnect As Long, _
ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, _
ByVal fFailIfExists As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Sub MoveMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pTo As Any, _
pFrom As Any, _
ByVal lSize As Long)
Public Declare Function StrFormatByteSizeW Lib "shlwapi.dll " _
(ByVal qdwLow As Long, _
ByVal qdwHigh As Long, _
pwszBuf As Any, _
ByVal cchBuf As Long) As Long
Public Function FtpFileGetFileSize(WFD As WIN32_FIND_DATA) As Double
FtpFileGetFileSize = (WFD.nFileSizeHigh * (MAXDWORD + 1)) + WFD.nFileSizeLow
End Function
Public Function FtpFileGetFileSizeStr(WFD As WIN32_FIND_DATA) As String
Dim sSize As String
sSize = Space$(64)
Call StrFormatByteSizeW(WFD.nFileSizeLow, _
WFD.nFileSizeHigh * (MAXDWORD + 1), _
ByVal StrPtr(sSize), 64)
FtpFileGetFileSizeStr = sSize
End Function
Public Function GetInternetConnectHandle() As Long
Dim sServerName As String
'GetInternetConnectHandle obtains a new
'handle expressly for use with the
'FtpFindFirstFile and APIs.
'
'Care must be taken to close only the handle
'returned by this function once the listing
'of the directory has been obtained.
'
'A temporary variable is used here
'to reduce line length
If hInternet Then
'Pass the same server as with other
'calls, along with the requisite username
'and password. The Microsoft FTP site
'allows anonymous login, so the username
'is 'anonymous' and the password is the
'user's email address.
sServerName = frmFtp.Combo1.Text
'return the connection handle
GetInternetConnectHandle = InternetConnect(hInternet, _
sServerName, _
0, _
sFtpUserName, _
sFtpPassword, _
INTERNET_SERVICE_FTP, _
INTERNET_FLAG_EXISTING_CONNECT Or _
INTERNET_FLAG_PASSIVE, _
&H0)
End If
End Function
Public Function GetFtpDirectory(hConnect As Long) As String
Dim nCurrDir As Long
Dim sCurrDir As String
'FtpGetCurrentDirectory retrieves the current
'directory for the connection. Using this API
'means it is not necessary to track the directory
'hierarchy for navigation.
'pad the requisite buffers
sCurrDir = Space$(MAX_PATH)
nCurrDir = Len(sCurrDir)
'FtpGetCurrentDirectory returns 1 if successful
If FtpGetCurrentDirectory(hConnect, sCurrDir, nCurrDir) = 1 Then
'return a properly qualified path
GetFtpDirectory = QualifyUrl(StripNull(sCurrDir))
End If
End Function
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
Dim sMsg As String
Dim cBuffer As String
Dim dwRead As Long
Dim uStatus As INTERNET_ASYNC_RESULT
cBuffer = Space$(dwStatusInfoLength)
Select Case dwInternetStatus
Case INTERNET_STATUS_RESOLVING_NAME
MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
sMsg = "Looking up the IP address for " & StripNull(cBuffer)
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATUS_NAME_RESOLVED
MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
sMsg = "Name resolved " & StripNull(cBuffer)
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATUS_CONNECTING_TO_SERVER
MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
sMsg = "Connecting to server..." & StripNull(cBuffer)
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATUS_CONNECTED_TO_SERVER
sMsg = "Connected to server."
MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
sMsg = "Connected to " & StripNull(cBuffer)
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATUS_SENDING_REQUEST
MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
pub_BytesSent = pub_BytesSent + dwRead
Select Case CurrentState
Case FTP_UPLOADING
'show the percent complete
frmFtp.FloodUpdateTextPC dwCurrentFileSize, _
pub_BytesSent
'the IIf statement assures the
'code will not attempt to set a
'prog bar value greater than Max
frmFtp.ProgressBar1.Value = IIf(pub_BytesSent < dwCurrentFileSize, _
pub_BytesSent, _
dwCurrentFileSize)
'if selected, update the list
'with the upload messages
If bFtpShowMessages Then
sMsg = "Uploading " & _
CStr(pub_BytesSent) & _
" of " & dwCurrentFileSize
Call UpdateList(sMsg)
End If
Case Else
sMsg = "Sending request: " & dwRead & " bytes"
Call UpdateList(sMsg)
End Select
Case INTERNET_STATUS_REQUEST_SENT
MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
sMsg = "Request sent: " & dwRead & " bytes"
pub_BytesSent = pub_BytesSent + dwRead
Case INTERNET_STATUS_RESPONSE_RECEIVED
MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
pub_BytesRecieved = pub_BytesRecieved + CSng(dwRead)
Select Case CurrentState
Case FTP_DOWNLOADING
'show the percent complete
frmFtp.FloodUpdateTextPC dwCurrentFileSize, _
pub_BytesRecieved
'the IIf statement assures the
'code will not attempt to set a
'prog bar value greater than Max
frmFtp.ProgressBar1.Value = IIf(pub_BytesRecieved < dwCurrentFileSize, _
pub_BytesRecieved, _
dwCurrentFileSize)
'if selected, update the list
'with the upload messages
If bFtpShowMessages Then
sMsg = "Downloading " & _
CStr(pub_BytesRecieved) & _
" of " & dwCurrentFileSize
Call UpdateList(sMsg)
End If
Case Else
sMsg = sMsg = "Response received: " & dwRead & " bytes"
Call UpdateList(sMsg)
End Select
Case INTERNET_STATUS_RECEIVING_RESPONSE
Case INTERNET_STATUS_CTL_RESPONSE_RECEIVED
Case INTERNET_STATUS_PREFETCH
Case INTERNET_STATUS_CLOSING_CONNECTION
sMsg = "Closing connection"
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATUS_CONNECTION_CLOSED
sMsg = "Connection closed"
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATUS_HANDLE_CREATED
MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
sMsg = "Handle created: " & CStr(dwRead)
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATUS_HANDLE_CLOSING
sMsg = "Handle closed"
If CurrentState = FTP_DOWNLOADING Then
sMsg = "Download complete. " & sMsg
CurrentState = FTP_WAIT
End If
If CurrentState = FTP_UPLOADING Then
sMsg = "Upload complete. " & sMsg
CurrentState = FTP_WAIT
End If
Call UpdateList(sMsg)
Case INTERNET_STATUS_DETECTING_PROXY
sMsg = "Detecting proxy"
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATUS_REQUEST_COMPLETE
sMsg = "Request completed"
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATUS_REDIRECT
MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
sMsg = "HTTP request redirected to " & StripNull(cBuffer)
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATUS_INTERMEDIATE_RESPONSE
sMsg = "Received intermediate status message from the server."
Call UpdateList(sMsg)
Case INTERNET_STATUS_STATE_CHANGE
'Moved between a secure and a non-secure site.
MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
Select Case dwRead
Case INTERNET_STATE_CONNECTED
sMsg = "Connected state moved between secure and nonsecure site"
Case INTERNET_STATE_DISCONNECTED
sMsg = "Disconnected from network."
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATE_DISCONNECTED_BY_USER
sMsg = "Disconnected by user request."
frmFtp.FloodShowConnectAction sMsg
Case INTERNET_STATE_IDLE
sMsg = "No network requests are being made (by Wininet)."
Case INTERNET_STATE_BUSY
sMsg = "Network requests are being made (by Wininet)."
Case INTERNET_STATUS_USER_INPUT_REQUIRED
sMsg = "The request requires user input to complete."
End Select
Call UpdateList(sMsg)
End Select
End Function
Public Function FtpFileDownload(sRemoteFile As String, _
sNewLocalFile As String, _
WFD As WIN32_FIND_DATA, _
bFailIfExists As Long) As Boolean
'Show the wait cursor
Screen.MousePointer = vbHourglass
'Only if a valid connection...
If hConnect Then
'dwCurrentFileSize is used in the
'callback and progress routine
dwCurrentFileSize = FtpFileGetFileSize(WFD)
'create the progress window passing the
'upload file size, and a message to display
frmFtp.FloodDisplay dwCurrentFileSize, _
"Downloading " & sRemoteFile & _
" to " & sNewLocalFile
'this is the key ... set the current
'FTP state to downloading
CurrentState = FTP_DOWNLOADING
'download the file
If FtpGetFile(hConnect, _
sRemoteFile, _
sNewLocalFile, _
bFailIfExists, _
FILE_ATTRIBUTE_ARCHIVE, _
FTP_TRANSFER_TYPE_UNKNOWN, _
1) Then
'show the success message
FtpFileDownload = True
Else
'set the error message and return
FtpErrorMessage = GetECode(Err.LastDllError)
FtpFileDownload = False
End If 'If FtpGetFile
End If 'If hConnect
CurrentState = 0
Screen.MousePointer = vbDefault
End Function
|
| |
| |
| server2009 | Дата: Суббота, 21.08.2010, 11:44 | Сообщение # 2 |
|
Admin
Группа: Администраторы
Сообщений: 18
Статус: Offline
| Код Public Sub GetFtpDirectoryContents()
Dim hFind As Long
Dim hFindConnect As Long
Dim sPath As String
Dim sPathOnly As String
Dim WFD As WIN32_FIND_DATA
'Show the wait cursor
Screen.MousePointer = vbHourglass
frmFtp.List1.Clear
'Obtain the current FTP path
sPathOnly = GetFtpDirectory(hConnect)
'If the path is not the FTP base directory,
'add ".." to provide a means of navigating
'back up the directory structure.
If sPathOnly <> sSlash Then
frmFtp.List1.AddItem sRootDots
End If
'The search parameters .. here we'll list
'all file types. Since GetFTPDirectory takes
'care of qualifying the path, no terminating
'slash is required.
sPath = sPathOnly & "*.*"
'Connection handles used by the FtpFindFirstFile
'API go out of scope once the all files are
'listed, therefore it can not be reused.
'This restriction is handled by obtaining
'a fresh connection handle each time a call
'to FtpFindFirstFile is required, and releasing
'it once finished.
hFindConnect = GetInternetConnectHandle()
'If a good connection handle ...
If hFindConnect Then
'..obtain the handle to the files with
'the FtpFindFirstFile API. Obtaining the
'directory contents is essentially similar
'to using the Win32 file system APIs
'FindFirstFile and FindNextFile, with the
'sole exception that there is no FtpFindNextFile
'API. Instead, successive calls are made
'to InternetFindNextFile. The data returned
'is in the familiar WIN32_FIND_DATA structure.
hFind = FtpFindFirstFile(hFindConnect, _
sPath, WFD, _
INTERNET_FLAG_RELOAD Or _
INTERNET_FLAG_NO_CACHE_WRITE, _
0&)
'If a valid find handle returned,
'loop through the directory listing
'the contents. If the attributes of
'the returned string indicate a folder,
'append a slash to make it both visually
'stand out in the list, and identifiable
'in the list double-click routine for
'navigation.
'
'hFile will be 0 if the navigated-to
'folder is empty.
If hFind Then
'suspend redraw on the file list
Call SendMessage(frmFtp.List1.hwnd, _
WM_SETREDRAW, _
0&, ByVal 0&)
Do
'if a folder
If WFD.dwFileAttributes And vbDirectory Then
'append a slash and add to list
frmFtp.List1.AddItem QualifyUrl(StripNull(WFD.cFileName))
Else
'add the item and its file size
frmFtp.List1.AddItem StripNull(WFD.cFileName) & _
vbTab & _
FtpFileGetFileSizeStr(WFD)
End If 'If WFD.dwFileAttributes
frmFtp.List1.Refresh
'continue while valid
Loop While InternetFindNextFile(hFind, WFD)
Call SendMessage(frmFtp.List1.hwnd, _
WM_SETREDRAW, _
True, ByVal 0&)
End If 'If hFind
End If 'If hFindConnect
'clean up by closing the handles used in this routine
Call InternetCloseHandle(hFind)
Call InternetCloseHandle(hFindConnect)
Screen.MousePointer = vbDefault
End Sub
Public Function GetECode(ByVal lErrorCode As Long) As String
Dim sBuffer As String
Dim nBuffer As Long
Select Case lErrorCode
Case 12001: GetECode = "No more handles could be generated at this time"
Case 12002: GetECode = "The request has timed out."
Case 12003:
'extended error. Retrieve the details using
'the InternetGetLastResponseInfo API.
sBuffer = Space$(256)
nBuffer = Len(sBuffer)
If InternetGetLastResponseInfo(lErrorCode, sBuffer, nBuffer) Then
GetECode = StripNull(sBuffer)
Else
GetECode = "Extended error returned from server."
End If
Case 12004: GetECode = "An internal error has occurred."
Case 12005: GetECode = "URL is invalid."
Case 12006: GetECode = "URL scheme could not be recognized, " & _
"or is not supported."
Case 12007: GetECode = "Server name could not be resolved."
Case 12008: GetECode = "Requested protocol could not be located."
Case 12009: GetECode = "A request to InternetQueryOption or " & _
"InternetSetOption specified an invalid option value."
Case 12010: GetECode = "Length of an option supplied to InternetQueryOption " & _
"or InternetSetOption is incorrect for the type " & _
"of option specified."
Case 12011: GetECode = "The request option can not be set, only queried. "
Case 12012: GetECode = "The Win32 Internet support is being shutdown or unloaded."
Case 12013: GetECode = "Request to connect and login to an FTP server could not" & _
"be completed because the supplied user name is incorrect."
Case 12014: GetECode = "Request to connect and login to an FTP server could not " & _
"be completed because the supplied password is incorrect. "
Case 12015: GetECode = "Request to connect to and login to an FTP server failed."
Case 12016: GetECode = "Requested operation is invalid. "
Case 12017: GetECode = "Operation was cancelled, usually because the handle on " & _
"which the request was operating was closed before the " & _
"operation completed."
Case 12018: GetECode = "Type of handle supplied is incorrect for this operation."
Case 12019: GetECode = "Requested operation can not be carried out because the " & _
"handle supplied is not in the correct state."
Case 12020: GetECode = "Request can not be made via a proxy."
Case 12021: GetECode = "A required registry value could not be located. "
Case 12022: GetECode = "A required registry value was located but is an " & _
"incorrect type or has an invalid value."
Case 12023: GetECode = "Direct network access cannot be made at this time. "
Case 12024: GetECode = "An asynchronous request could not be made because " & _
"a zero context value was supplied."
Case 12025: GetECode = "An asynchronous request could not be made because " & _
"a callback function has not been set."
Case 12026: GetECode = "The required operation could not be completed " & _
"because one or more requests are pending."
Case 12027: GetECode = "The format of the request is invalid."
Case 12028: GetECode = "The requested item could not be located."
Case 12029: GetECode = "The attempt to connect to the server failed."
Case 12030: GetECode = "The connection with the server has been terminated."
Case 12031: GetECode = "The connection with the server has been reset."
Case 12036: GetECode = "The request failed because the handle already exists."
Case Else: GetECode = "Error details not available."
End Select
End Function
Public Function StripNull(item As String)
'return a string without the chr$(0) terminator
Dim pos As Long
pos = InStr(item, Chr$(0))
If pos Then
StripNull = Left$(item, pos - 1)
Else
StripNull = item
End If
End Function
Public Function QualifyPath(sPath As String) As String
'assures that a passed path ends in a slash
If Right$(sPath, 1) <> "\" Then
QualifyPath = sPath & "\"
Else
QualifyPath = sPath
End If
End Function
Public Function QualifyUrl(sPath As String) As String
'assures that a passed URL ends in a slash
If Right$(sPath, 1) <> "/" Then
QualifyUrl = sPath & "/"
Else
QualifyUrl = sPath
End If
End Function
Private Sub UpdateList(sMsg As String)
'if showing messages, add the new
'item and scroll the list to keep
'in view.
If bFtpShowMessages Then
frmFtp.List2.AddItem sMsg
frmFtp.List2.TopIndex = frmFtp.List2.NewIndex
End If
End Sub
Form Code
As shown in the illustrations above, to a new form add:
Four command buttons (Command1 - Command4)
Two lists (List1, List2)
Three Labels (lblStatus, Label2, Label3)
A VB picture box (tbFlood) to act as the Photoshop flood bar.
A VB progress bar (ProgressBar1)
Two Check boxes (Check1, Check2)
A combo box (Combo1)
.... add the following code:
Option Explicit
Private sProgressMessage As String
Dim f As PictureBox
Private Sub Form_Load()
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2.6
Label2.Caption = "Closed"
Label3.Caption = "No connection"
Text1.Text = ""
lblStatus.Caption = ""
Command2.Enabled = False
Command3.Enabled = False
Command4.Enabled = False
tbFlood.AutoRedraw = True 'else we won't see the progress!
Check2.Value = 1
'tabs for the file/folder and size display
ReDim TabArray(0 To 0) As Long
TabArray(0) = 142
'Clear existing tabs and set the tabs
Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 0&, ByVal 0&)
Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 1&, TabArray(0))
List1.Refresh
With Combo1
.AddItem "127.0.0.1" 'localhost
.AddItem "ftp.microsoft.com"
.AddItem "ftp.netscape.com"
.AddItem "ftp.sun.com"
.AddItem "www.technolog.fr"
.AddItem "www.winfiles.com"
.AddItem "olivo.mentor.mec.es"
.AddItem "main.amu.edu.pl"
.AddItem "tucows.com" 'demonstrates error
.ListIndex = 0
End With
Command1.Caption = "Open Connction"
Command2.Caption = "Close Connction"
Command3.Caption = "Download"
Command4.Caption = "FtpFindFirstFile"
End Sub
Private Sub Form_Unload(Cancel As Integer)
'if the handles are still valid,
'clean up before exiting
If (hCallback <> INTERNET_INVALID_STATUS_CALLBACK) And _
(hCallback <> 0) And _
hInternet Then
'remove the current callback
Call InternetSetStatusCallback(hCallback, 0&)
End If
If hConnect Then InternetCloseHandle (hConnect)
If hInternet Then InternetCloseHandle (hInternet)
End Sub
Private Sub Command1_Click()
Dim sServerName As String
'Show the wait cursor
Screen.MousePointer = vbHourglass
'Begin the FTP process by obtaining a
'handle to an internet session. This
'handle will be used in subsequent calls,
'so its declared as a form-wide variable.
hInternet = InternetOpen("VBnet FTP Transfer", _
INTERNET_OPEN_TYPE_DIRECT, _
vbNullString, _
vbNullString, _
INTERNET_FLAG_NO_CACHE_WRITE)
'If a handle was obtained, the next step is
'to obtain a connection handle that will be
'used for all operations except the FTP
'directory navigation. The MSDN states that
'the handle used by FtpFindFirstFile and subsequent
'file calls can not be reused for additional
'navigation or other operations.
If hInternet Then
'create the callback to handle user
'actions and reflect status codes
hCallback = InternetSetStatusCallback(hInternet, _
AddressOf FtpCallbackStatus)
'if successful, hCallback will be either zero
'if this is the first call, or the handle of
'the previously started callback. It will
'be -1 if invalid.
If hCallback <> INTERNET_INVALID_STATUS_CALLBACK Then
sServerName = Combo1.Text
'get a connection handle
hConnect = InternetConnect(hInternet, _
sServerName, _
INTERNET_DEFAULT_FTP_PORT, _
sFtpUserName, _
sFtpPassword, _
INTERNET_SERVICE_FTP, _
INTERNET_FLAG_EXISTING_CONNECT Or _
INTERNET_FLAG_PASSIVE, _
1&)
'if the connection handle is valid, get
'the current FTP directory
If hConnect <> 0 Then
'reflect the current path in the
'text box (it should be '\' ) and
'get the directory contents
Text1.Text = GetFtpDirectory(hConnect)
Call GetFtpDirectoryContents
Else
'show the error
lblStatus.Caption = GetECode(Err.LastDllError)
End If 'If hConnect
End If 'If InternetSetStatusCallback
End If 'If hInternet
'display the session handles
Label3.Caption = hInternet
Label2.Caption = hConnect
'If both handles are valid, disable the Open button
'and enable the FTP button. If *either* handle is
'valid, enable the close button. The download
'button is false.
Command1.Enabled = (hInternet = 0) And (hConnect = 0)
Command2.Enabled = (hInternet <> 0) And (hConnect <> 0)
Command3.Enabled = (hInternet <> 0) Or (hConnect <> 0)
Command4.Enabled = False
Combo1.Enabled = (hInternet = 0) And (hConnect = 0)
Screen.MousePointer = vbDefault
End Sub
Private Sub Command2_Click()
'clean up
Call InternetCloseHandle(hConnect)
Call InternetCloseHandle(hInternet)
hInternet = 0
hConnect = 0
Label2.Caption = "Closed"
Label3.Caption = "No connection"
'If both handles are valid, enable the Open button
'and disable the FTP button. If *either* handle is
'valid, disable the close button. The download
'button is disabled.
Command1.Enabled = (hInternet = 0) And (hConnect = 0)
Command2.Enabled = (hInternet <> 0) And (hConnect <> 0)
Command3.Enabled = (hInternet <> 0) Or (hConnect <> 0)
Command4.Enabled = False
Combo1.Enabled = True
lblStatus.Caption = ""
List1.Clear
Combo1.SetFocus
End Sub
Private Sub Command3_Click()
Dim sFile As String
Dim sCurrDir As String
Dim sRemoteFile As String
Dim sNewLocalFile As String
Dim hFind As Long
Dim hFindConnect As Long
Dim WFD As WIN32_FIND_DATA
Dim success As Boolean
'this just resets the list, labels and error message
ResetStuff
If hConnect Then
'get the current directory and
'selected list item
sCurrDir = GetFtpDirectory(hConnect)
sFile = ParseFileFromList(List1.List(List1.ListIndex))
'build the necessary strings. The
'directory is qualified, so contains
'the terminating slash.
sRemoteFile = sCurrDir & sFile
sNewLocalFile = QualifyPath(sLocalDownloadPath) & sFile
'assure the file is on the server and retrieving
'its info into a WIN32_FIND_DATA structure
hFindConnect = GetInternetConnectHandle()
hFind = FtpFindFirstFile(hFindConnect, _
sRemoteFile & vbNullString, _
WFD, 0&, 0&)
lblStatus.Caption = Err.LastDllError
'if the FtpFindFirstFile call located
'the file then download
If hFind <> 0 Then
success = FtpFileDownload(sRemoteFile, _
sNewLocalFile, _
WFD, _
(Check1.Value = 1)) 'if 1 then will not overwrite
FloodShowTransferResult success, sNewLocalFile
End If
'clean up
Call InternetCloseHandle(hFind)
Call InternetCloseHandle(hFindConnect)
End If
End Sub
Private Sub Command4_Click()
Call GetFtpDirectoryContents
End Sub
Private Sub Check2_Click()
bFtpShowMessages = Check2.Value = 1
End Sub
Private Sub Combo1_Click()
Combo1 = Combo1.Text
End Sub
Private Sub List1_Click()
Dim sNewPath As String
'get the desired directory from the list
sNewPath = List1.List(List1.ListIndex)
'if a root item or directory is selected,
'disable the download button
Command4.Enabled = (Right$(sNewPath, 1) <> sSlash) And _
(sNewPath <> sRootDots)
End Sub
Private Sub List1_DblClick()
Dim sNewPath As String
Dim sPath As String
'get the desired directory from the list
sNewPath = List1.List(List1.ListIndex)
'If a root item selected, exit; the routine
'will navigate a level higher. If it is
'a file, we don't want to navigate.
If sNewPath <> sRootDots And Right$(sNewPath, 1) <> sSlash Then
'root or file selected
Exit Sub
Else
'Show the wait cursor
Screen.MousePointer = vbHourglass
'clear the list in preparation for
'retrieving the directory contents
List1.Clear
'retrieve the current FTP path
'using GetFTPDirectory
sPath = GetFtpDirectory(hConnect)
'qualify it if necessary, and append
'the new path to it
If Right$(sPath, 1) <> sSlash Then
sPath = sPath & sSlash & sNewPath
Else
sPath = sPath & sNewPath
End If
'set the new path using the
'FtpSetCurrentDirectory API
Call FtpSetCurrentDirectory(hConnect, sPath)
'reflect the new path in the text box
Text1.Text = GetFtpDirectory(hConnect)
'reload the list with the current directory
GetFtpDirectoryContents
'Show the wait cursor
Screen.MousePointer = vbDefault
End If
End Sub
Public Sub FloodDisplay(upperLimit, floodMessage As String)
'set the module-level variable f
'equal to the parent form flood panel
Set f = tbFlood
'initialize the control by setting:
'white (the text colour)
'black (the flood panel colour)
'not Xor pen
'solid fill
f.Cls
f.BackColor = &HFFFFFF
f.ForeColor = &H800000
f.DrawMode = 10
f.FillStyle = 0
'set the scalewidth equal to the
'upper limit of the items to count
f.ScaleWidth = upperLimit
f.Cls
f.Visible = True
'set a form-level variable for the flood message
'to avoid the need for continually passing a string
sProgressMessage = floodMessage
frmFtp.ProgressBar1.Max = upperLimit
frmFtp.ProgressBar1.Min = 0
frmFtp.ProgressBar1.Value = 0
End Sub
Public Sub FloodHide()
f.Visible = False
f.Cls
'free the memory used by f
Set f = Nothing
End Sub
Public Sub FloodUpdateTextPC(upperLimit As Double, progress As Double)
Dim pc As String
If progress <= upperLimit Then
If progress > tbFlood.ScaleWidth Then progress = tbFlood.ScaleWidth
tbFlood.Cls
tbFlood.ScaleWidth = upperLimit
'format the progress into a percentage string to display
pc = Format$(CLng((progress / tbFlood.ScaleWidth) * 100)) + "%"
'calculate the string's X & Y coordinates
'in the PictureBox ... here, left justified and offset slightly
tbFlood.CurrentX = 2
tbFlood.CurrentY = (tbFlood.ScaleHeight - tbFlood.TextHeight(sProgressMessage)) \ 2
'print the percentage string in the text colour
tbFlood.Print sProgressMessage & " " & pc
'print the flood bar to the new progress length in the line colour
tbFlood.Line (0, 0)-(progress, tbFlood.ScaleHeight), tbFlood.ForeColor, BF
'without this DoEvents or Refresh, the flood won't update
tbFlood.Refresh
End If
End Sub
Public Sub FloodShowTransferResult(success As Boolean, sFile As String)
Dim sMsg As String
Select Case success
Case True:
tbFlood.BackColor = &HFFFFFF
tbFlood.ForeColor = &H3A633D
sMsg = "Transfer of " & sFile & " completed successfully."
Case False:
tbFlood.BackColor = &HFFFFFF
tbFlood.ForeColor = &H3D2785
sMsg = "Transfer of " & sFile & " failed."
End Select
tbFlood.Cls
'calculate the string's X & Y coordinates
'in the Picture Box ... here, left justified and offset slightly
tbFlood.CurrentX = 2
tbFlood.CurrentY = (tbFlood.ScaleHeight - tbFlood.TextHeight(sMsg )) \ 2
'print the percentage string in the text colour
tbFlood.Print sMsg
'print the flood bar to the new progress length in the line colour
tbFlood.Line (0, 0)-(tbFlood.ScaleWidth, tbFlood.ScaleHeight), tbFlood.ForeColor, BF
End Sub
Public Sub FloodShowConnectAction(sConnectMsg As String)
tbFlood.Cls
'calculate the string's X & Y coordinates
'in the PictureBox ... here, left justified and offset slightly
tbFlood.CurrentX = 2
tbFlood.CurrentY = (tbFlood.ScaleHeight - tbFlood.TextHeight(sConnectMsg)) \ 2
tbFlood.BackColor = &HFFFFFF
tbFlood.ForeColor = &H800000
'print the percentage string in the text colour
tbFlood.Print sConnectMsg
End Sub
Private Sub ResetStuff()
List2.Clear
lblStatus.Caption = ""
FtpErrorMessage = ""
pub_BytesSent = 0
pub_BytesRecieved = 0
End Sub
Private Function ParseFileFromList(ByVal sSelection As String) As String
Dim pos As Long
pos = InStr(sSelection, vbTab)
If pos Then
ParseFileFromList = Left$(sSelection, pos - 1)
Else
ParseFileFromList = sSelection
End If
End Function
|
| |
| |
