Re: FTP-Service throgh WinInet-API

On Tue, 13 Dec 2005 13:03:12 +0100, "Wolfgang Marx" <hms@xxxxxxxxxxxxxxxxxx> wrote:
in <dnmdcs$qqm$00$1@xxxxxxxxxxxxxxxxx>

>Hi Stefan,
>
>I dropped the following lines, cause i can't get it working in my VBA Code
>and think it shouldn't make the difference?
>But if so, would you post me the full declaration?
>
>> hCallBack = InternetSetStatusCallback(hInternet, AddressOf
>> FTPCallbackStatus)
>> If (hCallBack <> INTERNET_INVALID_STATUS_CALLBACK) Then
>
>however, It is working fine - As long that i use RAS-Connection ... ;-)
>It seem's that the InternetOpenURL() attempt a Connect by itself, while
>InternetConnect() won't..
>
>Regards Wolfgang
>

Hi Wolfgang-

The callback routine is primarily for updating the up/down load progress
but stick the following code in a module. I've also included the flood file
progress bar form which can be used thusly:


If (IsInternetConnected(mstrIP_Aux)) Then
dlgFTP.Init True
Dim sTmpPath As String: sTmpPath = AppPath(GetTempDir())
If (GetVersion("version_S.txt") > AppVersion) Then
Dim sDownload As String: sDownload = sTmpPath & "SQLShowTimeUpdate_S.exe"
KillFile sDownload
If (dlgFTP.Download(frmMain.IP_Aux, "/html/downloads/", sDownload, SWBU, SWBP)) Then
KillFile sTmpPath & "SQLShowTime.exe"
frmMenu.Visible = False: RunAndWait sDownload
Dim bUpdate As Boolean: bUpdate = True
End If
Else
Dim sMsg As String: sMsg = "It's ShowTime! software is up to date."
End If
End If

' The IsInternetConnected routine above just pings my web server to make sure it's alive.

' FTP module
Option Explicit
Option Private Module

Private hInternet As Long
Private hConnect As Long
Private hCallBack As Long

'Private Const sRootDots As String = ".."
'Private Const sSlash As String = "/"

Private dwCurrentFileSize As Double 'file size of download
Private pub_BytesSent As Double 'tracks bytes send
Private pub_BytesReceived 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
''use registry configuration
Public Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
''direct to net
Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
''via named proxy
'Private Const INTERNET_OPEN_TYPE_PROXY As Long = 3
''prevent using java/script/INS
'Private Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY As Long = 4
''used for FTP connections
Private Const INTERNET_FLAG_PASSIVE As Long = &H8000000
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000
''Additional cache flags
''don't write this item to the cache
Private Const INTERNET_FLAG_NO_CACHE_WRITE As Long = &H4000000
'Private Const INTERNET_FLAG_DONT_CACHE As Long = INTERNET_FLAG_NO_CACHE_WRITE
''make this item persistent in cache
'Private Const INTERNET_FLAG_MAKE_PERSISTENT As Long = &H2000000
'Private Const INTERNET_FLAG_FROM_CACHE As Long = &H1000000
''use offline semantics
'Private Const INTERNET_FLAG_OFFLINE As Long = INTERNET_FLAG_FROM_CACHE
''Additional flags
''use PCT/SSL if applicable (HTTP)
'Private Const INTERNET_FLAG_SECURE As Long = &H800000
''use keep-alive semantics
'Private Const INTERNET_FLAG_KEEP_CONNECTION As Long = &H400000
''don't handle redirections automatically
'Private Const INTERNET_FLAG_NO_AUTO_REDIRECT As Long = &H200000
''do background read prefetch
'Private Const INTERNET_FLAG_READ_PREFETCH As Long = &H100000
''no automatic cookie handling
'Private Const INTERNET_FLAG_NO_COOKIES As Long = &H80000
''no automatic authentication handling
'Private Const INTERNET_FLAG_NO_AUTH As Long = &H40000
''return cache file if net request fails
'Private Const INTERNET_FLAG_CACHE_IF_NET_FAIL As Long = &H10000
''default for FTP servers
Private Const INTERNET_DEFAULT_FTP_PORT As Long = 21
'' " " gopher "
'Private Const INTERNET_DEFAULT_GOPHER_PORT As Long = 70
'' " " HTTP "
'Private Const INTERNET_DEFAULT_HTTP_PORT As Long = 80
'' " " HTTPS "
'Private Const INTERNET_DEFAULT_HTTPS_PORT As Long = 443
''default for SOCKS firewall servers.
'Private Const INTERNET_DEFAULT_SOCKS_PORT As Long = 1080
''FTP: use existing InternetConnect handle for server if possible
Private Const INTERNET_FLAG_EXISTING_CONNECT As Long = &H20000000
Private Const INTERNET_SERVICE_FTP As Long = 1
'Private Const INTERNET_SERVICE_GOPHER As Long = 2
'Private Const INTERNET_SERVICE_HTTP As Long = 3
''connected state (mutually exclusive with disconnected)
'Private Const INTERNET_STATE_CONNECTED As Long = &H1
''disconnected from network
Private Const INTERNET_STATE_DISCONNECTED As Long = &H2
''disconnected by user request
Private Const INTERNET_STATE_DISCONNECTED_BY_USER As Long = &H10
''no network requests being made (by Wininet)
'Private Const INTERNET_STATE_IDLE As Long = &H100
''network requests being made (by Wininet)
'Private Const INTERNET_STATE_BUSY As Long = &H200
''transfer flags
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)
'imternet callback messages
Private Const INTERNET_INVALID_STATUS_CALLBACK As Long = -1
Private Const INTERNET_STATUS_RESOLVING_NAME As Long = 0
Private Const INTERNET_STATUS_NAME_RESOLVED As Long = 1
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
'internet error flags
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_CDROM 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)
'FTP API errors
'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)
'gopher API errors
'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)
'HTTP API errors
'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)
'additional Internet API error codes
'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)
'InternetAutodial specific errors
'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_LOGIN_FAILURE_DISPLAY_ENTITY_BODY

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 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

Public 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 FtpPutFile _
Lib "wininet.dll" _
Alias "FtpPutFileA" ( _
ByVal hConnect As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszNewRemoteFile As String, _
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

Private Function FTPFileGetFileSize(WFD As WIN32_FIND_DATA) As Double

FTPFileGetFileSize = (WFD.nFileSizeHigh * (MAXDWORD + 1)) + WFD.nFileSizeLow

End Function

Public Function FileDownload(ByVal sServer As String, ByVal sDir As String, ByVal sFile As String, ByVal sFTPUserName As String, ByVal sFTPPassword As String) As Boolean

hInternet = InternetOpen("It's ShowTime!", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, INTERNET_FLAG_NO_CACHE_WRITE)
If hInternet Then
hCallBack = InternetSetStatusCallback(hInternet, AddressOf FTPCallbackStatus)
If (hCallBack <> INTERNET_INVALID_STATUS_CALLBACK) Then
hConnect = InternetConnect(hInternet, sServer, INTERNET_DEFAULT_FTP_PORT, sFTPUserName, sFTPPassword, INTERNET_SERVICE_FTP, INTERNET_FLAG_EXISTING_CONNECT Or INTERNET_FLAG_PASSIVE, &H0)
If hConnect <> 0 Then
FtpSetCurrentDirectory hConnect, sDir
Dim sRemoteFile As String: sRemoteFile = sDir & Mid$(sFile, InStrRev(sFile, "\") + 1)
Dim hFindConnect As Long: hFindConnect = InternetConnect(hInternet, sServer, 0, sFTPUserName, sFTPPassword, INTERNET_SERVICE_FTP, INTERNET_FLAG_EXISTING_CONNECT Or INTERNET_FLAG_PASSIVE, &H0)
Dim WFD As WIN32_FIND_DATA
Dim hFind As Long: hFind = FtpFindFirstFile(hFindConnect, sRemoteFile & vbNullString, WFD, 0&, 0&)
If (hFind <> 0) Then
FileDownload = FTPFileDownload(sRemoteFile, sFile, WFD, 0&)
InternetCloseHandle hFind
End If
InternetCloseHandle hFindConnect
End If
If (hConnect) Then InternetCloseHandle hConnect
End If
If ((hCallBack <> INTERNET_INVALID_STATUS_CALLBACK) And (hCallBack <> 0)) Then InternetSetStatusCallback hCallBack, 0&
End If
If (hInternet) Then InternetCloseHandle hInternet
Screen.MousePointer = vbDefault

End Function

Public Function FileUpload(ByVal sServer As String, ByVal sDir As String, ByVal sFile As String, ByVal sFTPUserName As String, ByVal sFTPPassword As String) As Boolean

hInternet = InternetOpen("It's ShowTime!", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, INTERNET_FLAG_NO_CACHE_WRITE)
If hInternet Then
hCallBack = InternetSetStatusCallback(hInternet, AddressOf FTPCallbackStatus)
If (hCallBack <> INTERNET_INVALID_STATUS_CALLBACK) Then
hConnect = InternetConnect(hInternet, sServer, INTERNET_DEFAULT_FTP_PORT, sFTPUserName, sFTPPassword, INTERNET_SERVICE_FTP, INTERNET_FLAG_EXISTING_CONNECT Or INTERNET_FLAG_PASSIVE, &H0)
If hConnect <> 0 Then
FtpSetCurrentDirectory hConnect, sDir
Dim sNewRemoteFile As String
sNewRemoteFile = sDir & Mid$(sFile, InStrRev(sFile, "\") + 1)
FileUpload = FTPFileUpload(sFile, sNewRemoteFile)
End If
If (hConnect) Then InternetCloseHandle hConnect
End If
If ((hCallBack <> INTERNET_INVALID_STATUS_CALLBACK) And (hCallBack <> 0)) Then InternetSetStatusCallback hCallBack, 0&
End If
If (hInternet) Then InternetCloseHandle hInternet
Screen.MousePointer = vbDefault

End Function

Private 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 cBuffer As String: cBuffer = Space$(dwStatusInfoLength)
Select Case dwInternetStatus
Case INTERNET_STATUS_RESOLVING_NAME
MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
dlgFTP.FloodShowStatus "Looking up the IP address for " & StripNull(cBuffer)

Case INTERNET_STATUS_NAME_RESOLVED
MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
dlgFTP.FloodShowStatus "Name resolved " & StripNull(cBuffer)

Case INTERNET_STATUS_CONNECTING_TO_SERVER
MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
dlgFTP.FloodShowStatus "Connecting to server..." & StripNull(cBuffer)

Case INTERNET_STATUS_CONNECTED_TO_SERVER
MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
dlgFTP.FloodShowStatus "Connected to " & StripNull(cBuffer)

Case INTERNET_STATUS_SENDING_REQUEST
Dim dwRead As Long
MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
pub_BytesSent = pub_BytesSent + dwRead
If (CurrentState = FTP_UPLOADING) Then dlgFTP.FloodFillUpdate pub_BytesSent

Case INTERNET_STATUS_REQUEST_SENT
MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
pub_BytesSent = pub_BytesSent + dwRead

Case INTERNET_STATUS_RESPONSE_RECEIVED
MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
pub_BytesReceived = pub_BytesReceived + CSng(dwRead)
If (CurrentState = FTP_DOWNLOADING) Then dlgFTP.FloodFillUpdate pub_BytesReceived

Case INTERNET_STATUS_CLOSING_CONNECTION
dlgFTP.FloodShowStatus "Closing connection"

Case INTERNET_STATUS_CONNECTION_CLOSED
dlgFTP.FloodShowStatus "Connection closed"

Case INTERNET_STATUS_HANDLE_CREATED
MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
dlgFTP.FloodShowStatus "Handle created: " & CStr(dwRead)

Case INTERNET_STATUS_HANDLE_CLOSING
If CurrentState = FTP_DOWNLOADING Then CurrentState = FTP_WAIT
If CurrentState = FTP_UPLOADING Then CurrentState = FTP_WAIT

Case INTERNET_STATUS_DETECTING_PROXY
dlgFTP.FloodShowStatus "Detecting proxy"

Case INTERNET_STATUS_REQUEST_COMPLETE
dlgFTP.FloodShowStatus "Request completed"

Case INTERNET_STATUS_REDIRECT
MoveMemory ByVal cBuffer, ByVal lpvStatusInfo, dwStatusInfoLength
dlgFTP.FloodShowStatus "HTTP request redirected to " & StripNull(cBuffer)

Case INTERNET_STATUS_STATE_CHANGE
MoveMemory dwRead, ByVal lpvStatusInfo, dwStatusInfoLength
Select Case dwRead
Case INTERNET_STATE_DISCONNECTED
dlgFTP.FloodShowStatus "Disconnected from network."

Case INTERNET_STATE_DISCONNECTED_BY_USER
dlgFTP.FloodShowStatus "Disconnected by user request."
End Select
End Select

End Function

Private Function FTPFileDownload(sRemoteFile As String, sNewLocalFile As String, WFD As WIN32_FIND_DATA, bFailIfExists As Long) As Boolean

Screen.MousePointer = vbHourglass
If hConnect Then
pub_BytesReceived = 0
dwCurrentFileSize = FTPFileGetFileSize(WFD)
dlgFTP.FloodFillInit dwCurrentFileSize, "Downloading " & Replace$(Mid$(sRemoteFile, InStrRev(sRemoteFile, "\") + 1), "_", " ")
CurrentState = FTP_DOWNLOADING
If (FtpGetFile(hConnect, sRemoteFile, sNewLocalFile, bFailIfExists, FILE_ATTRIBUTE_ARCHIVE, FTP_TRANSFER_TYPE_UNKNOWN, 1)) Then
dlgFTP.FloodFillUpdate dwCurrentFileSize
FTPFileDownload = True
Else
dlgFTP.FloodShowStatus GetErr(Err.LastDllError)
FTPFileDownload = False
End If
End If
CurrentState = 0
Screen.MousePointer = vbDefault

End Function

Private Function FTPFileUpload(sLocalFile As String, sNewRemoteFile As String) As Boolean

Screen.MousePointer = vbHourglass
If hConnect Then
pub_BytesSent = 0
dwCurrentFileSize = FileLen(sLocalFile)
dlgFTP.FloodFillInit dwCurrentFileSize, "Uploading " & Replace$(Mid$(sLocalFile, InStrRev(sLocalFile, "\") + 1), "_", " ")
CurrentState = FTP_UPLOADING
If (FtpPutFile(hConnect, sLocalFile, sNewRemoteFile, FTP_TRANSFER_TYPE_UNKNOWN, 1)) Then
dlgFTP.FloodFillUpdate dwCurrentFileSize
FTPFileUpload = True
Else
dlgFTP.FloodShowStatus GetErr(Err.LastDllError)
FTPFileUpload = False
End If
End If
CurrentState = 0
Screen.MousePointer = vbDefault

End Function

Private Function GetErr(ByVal lErrorCode As Long) As String

Select Case lErrorCode
Case 12001: GetErr = "No more handles could be generated at this time"
Case 12002: GetErr = "The request has timed out."
Case 12003:
Dim sBuffer As String: sBuffer = Space$(256)
Dim nBuffer As Long: nBuffer = Len(sBuffer)
If InternetGetLastResponseInfo(lErrorCode, sBuffer, nBuffer) Then
GetErr = StripNull(sBuffer)
Else
GetErr = "Extended error returned from server."
End If

Case 12004: GetErr = "An internal error has occurred."
Case 12005: GetErr = "URL is invalid."
Case 12006: GetErr = "URL scheme could not be recognized, or is not supported."
Case 12007: GetErr = "Server name could not be resolved."
Case 12008: GetErr = "Requested protocol could not be located."
Case 12009: GetErr = "Request to InternetQueryOption or InternetSetOption specified an invalid option value."
Case 12010: GetErr = "Length of an option supplied to InternetQueryOption or InternetSetOption is incorrect for the type of option specified."
Case 12011: GetErr = "Request option can not be set, only queried. "
Case 12012: GetErr = "Win32 Internet support is being shutdown or unloaded."
Case 12013: GetErr = "Request to connect and login to an FTP server could not be completed because the supplied user name is incorrect."
Case 12014: GetErr = "Request to connect and login to an FTP server could not be completed because the supplied password is incorrect. "
Case 12015: GetErr = "Request to connect to and login to an FTP server failed."
Case 12016: GetErr = "Requested operation is invalid. "
Case 12017: GetErr = "Operation was canceled, usually because the handle on which the request was operating was closed before the operation completed."
Case 12018: GetErr = "Type of handle supplied is incorrect for this operation."
Case 12019: GetErr = "Requested operation can not be carried out because the handle supplied is not in the correct state."
Case 12020: GetErr = "Request can not be made via a proxy."
Case 12021: GetErr = "Required registry value could not be located. "
Case 12022: GetErr = "Required registry value was located but is an incorrect type or has an invalid value."
Case 12023: GetErr = "Direct network access cannot be made at this time. "
Case 12024: GetErr = "Asynchronous request could not be made because a zero context value was supplied."
Case 12025: GetErr = "Asynchronous request could not be made because a callback function has not been set."
Case 12026: GetErr = "Required operation could not be completed because one or more requests are pending."
Case 12027: GetErr = "Format of the request is invalid."
Case 12028: GetErr = "Requested item could not be located."
Case 12029: GetErr = "Attempt to connect to the server failed."
Case 12030: GetErr = "Connection with the server has been terminated."
Case 12031: GetErr = "Connection with the server has been reset."
Case 12036: GetErr = "Request failed because the handle already exists."
Case Else
GetErr = "Error details not available."
End Select
MsgBox GetErr

End Function

Private Function StripNull(ByVal strItem As String)

StripNull = Mid$(strItem, 1, InStr(1, strItem, Chr$(0)))

End Function


And the flood fill progress bar (dlgFTP.frm):
VERSION 5.00
Begin VB.Form dlgFTP
BorderStyle = 1 'Fixed Single
ClientHeight = 1125
ClientLeft = 45
ClientTop = 330
ClientWidth = 9510
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 1125
ScaleWidth = 9510
StartUpPosition = 1 'CenterOwner
Begin VB.PictureBox picFlood
AutoRedraw = -1 'True
Height = 315
Left = 60
ScaleHeight = 255
ScaleWidth = 9315
TabIndex = 0
Top = 360
Width = 9375
End
End
Attribute VB_Name = "dlgFTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private mbVisible As Boolean
Private mdblProgress As Double
Private msProgressMessage As String
Private mintFloodFillHeight As Integer

Public Function Download(ByVal sServer As String, ByVal sDir As String, ByVal sFile As String, ByVal sFTPUserName As String, ByVal sFTPPassword As String) As Boolean

Me.Caption = "Downloading " & Mid$(sFile, InStrRev(sFile, "\") + 1)
Me.Refresh
Download = FileDownload(sServer, sDir, sFile, sFTPUserName, sFTPPassword)

End Function

Public Sub FloodFillInit(ByVal dblMaxValue As Double, ByVal sMsg As String)

With picFlood
.BackColor = &HFFFFFF 'white (the text color, believe it or not)
.DrawMode = 10 'not Xor pen
.FillStyle = 0 'solid fill
.ForeColor = vbBlue 'fill color
.ScaleWidth = dblMaxValue
mintFloodFillHeight = .TextHeight("x")
End With
msProgressMessage = sMsg

End Sub

Public Sub FloodFillUpdate(ByVal dblProgress As Double)

With picFlood
If (dblProgress > .ScaleWidth) Then dblProgress = .ScaleWidth
mdblProgress = dblProgress
.Cls
.CurrentX = 2
.CurrentX = (.ScaleWidth - .TextWidth(msProgressMessage)) \ 2
.CurrentY = (.ScaleHeight - mintFloodFillHeight) \ 2
Dim sProgress As String: sProgress = Format$(CLng((dblProgress / .ScaleWidth) * 100)) + "%"
picFlood.Print msProgressMessage & " " & sProgress
picFlood.Line (0, 0)-(dblProgress, .ScaleHeight), .ForeColor, BF
.Refresh
End With

End Sub

Public Sub FloodShowStatus(ByVal sConnectMsg As String)

Dim sMsg As String: sMsg = msProgressMessage
msProgressMessage = sConnectMsg
FloodFillUpdate mdblProgress
msProgressMessage = sMsg

End Sub

Public Function Init(Optional ByVal bDisplay As Boolean = False) As Boolean

mbVisible = bDisplay
Me.Visible = mbVisible
If (mbVisible) Then
Me.Icon = LoadResPicture("AA", vbResIcon)
Me.Refresh
End If

End Function

Public Function Upload(ByVal sServer As String, ByVal sDir As String, ByVal sFile As String, ByVal sFTPUserName As String, ByVal sFTPPassword As String) As Boolean

Me.Caption = "Uploading " & Mid$(sFile, InStrRev(sFile, "\") + 1)
Me.Refresh
Upload = FileUpload(sServer, sDir, sFile, sFTPUserName, sFTPPassword)

End Function

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

If (KeyCode = vbKeyEscape) Then Unload Me

End Sub


---
Stefan Berglund
.