VB FTP
I would like to have example that I can use wininet.dll to transfer file (ftp).
The problem I have now is how to set the time out on InternetConnect function. For example, if I am attempting to connect to a machine that is completely off the network (for instance, if I enter a bogus IP number), the Internetconnect function will block my task for over 1 min. I know how to do it in C++ but I want to do it in VB.
I have tried to use msinet.ocx but there is bug inside and it will give me an Access Violation when my program runs for over an hour (it is really unpredicable). (This is bug that has already confirmed by MS).
Please help?!
?-<
The problem I have now is how to set the time out on InternetConnect function. For example, if I am attempting to connect to a machine that is completely off the network (for instance, if I enter a bogus IP number), the Internetconnect function will block my task for over 1 min. I know how to do it in C++ but I want to do it in VB.
I have tried to use msinet.ocx but there is bug inside and it will give me an Access Violation when my program runs for over an hour (it is really unpredicable). (This is bug that has already confirmed by MS).
Please help?!
?-<
My first sample was not so good :(
here is a best
' #VBIDEUtils#**************
' * Programmer Name : Chris Eastwood
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : waty.thierry@usa.net
' * Date : 02/09/1999
' * Time : 14:37
' **************************
' * Comments : FTP Access through a Class Module for VB5/6
' *
' *
' **************************
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "cFTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'
' CodeGuru FTP Class
'
' Chris Eastwood July 1999
'
' This class wraps the functionality of the Win32 WinInet.DLL
'
' It could easily be expanded to provide HTTP/Gopher and other internet
' standard file protocols.
'
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private 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 Const ERROR_NO_MORE_FILES = 18
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
(ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" _
(ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _
lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" _
(ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
' Initializes an application's use of the Win32 Internet functions
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
' Use registry access settings.
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_INVALID_PORT_NUMB
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H1
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _
ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Const ERROR_INTERNET_EXTENDED_ER
Private Declare Function InternetGetLastResponseInf
lpdwError As Long, _
ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Boolean
' Type of service to access.
Private Const INTERNET_SERVICE_FTP = 1
'private Const INTERNET_SERVICE_GOPHER = 2
'private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECT
Private Const INTERNET_FLAG_MULTIPART = &H200000
Private Declare Function FtpOpenFile Lib "wininet.dll" Alias _
"FtpOpenFileA" (ByVal hFtpSession As Long, _
ByVal sFileName As String, ByVal lAccess As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function FtpDeleteFile Lib "wininet.dll" _
Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
ByVal lpszFileName As String) As Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias _
"FtpRenameFileA" (ByVal hFtpSession As Long, _
ByVal sExistingName As String, _
ByVal sNewName As String) As Boolean
' Closes a single Internet handle or a subtree of Internet handles.
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
'
' Our Defined Errors
'
Public Enum errFtpErrors
errCannotConnect = vbObjectError + 2001
errNoDirChange = vbObjectError + 2002
errCannotRename = vbObjectError + 2003
errCannotDelete = vbObjectError + 2004
errNotConnectedToSite = vbObjectError + 2005
errGetFileError = vbObjectError + 2006
errInvalidProperty = vbObjectError + 2007
errFatal = vbObjectError + 2008
End Enum
'
' File Transfer types
'
Public Enum FileTransferType
ftAscii = FTP_TRANSFER_TYPE_ASCII
ftBinary = FTP_TRANSFER_TYPE_BINARY
End Enum
'
' Error messages
'
Private Const ERRCHANGEDIRSTR As String = "Cannot Change Directory to %s. It either doesn't exist, or is protected"
Private Const ERRCONNECTERROR As String = "Cannot Connect to %s using User and Password Parameters"
Private Const ERRNOCONNECTION As String = "Not Connected to FTP Site"
Private Const ERRNODOWNLOAD As String = "Couldn't Get File %s from Server"
Private Const ERRNORENAME As String = "Couldn't Rename File %s"
Private Const ERRNODELETE As String = "Couldn't Delete File %s from Server"
Private Const ERRALREADYCONNECTED As String = "You cannot change this property while connected to an FTP server"
Private Const ERRFATALERROR As String = "Cannot get Connection to WinInet.dll !"
'
' Session Identifier to Windows
'
Private Const SESSION As String = "CGFtp Instance"
'
' Our INET handle
'
Private mlINetHandle As Long
'
' Our FTP Connection Handle
'
Private mlConnection As Long
'
' Standard FTP properties for this class
'
Private msHostAddress As String
Private msUser As String
Private msPassword As String
Private msDirectory As String
Private Sub Class_Initialize()
'
' Create Internet session handle
'
mlINetHandle = InternetOpen(SESSION, INTERNET_OPEN_TYPE_DIRECT,
If mlINetHandle = 0 Then
mlConnection = 0
Err.Raise errFatal, "CGFTP::Class_Initialise", ERRFATALERROR
End If
mlConnection = 0
End Sub
Private Sub Class_Terminate()
'
' Kill off any connection
'
If mlConnection <> 0 Then
InternetCloseHandle mlConnection
End If
'
' Kill off API Handle
'
If mlINetHandle <> 0 Then
InternetCloseHandle mlINetHandle
End If
mlConnection = 0
mlINetHandle = 0
End Sub
Public Property Let Host(ByVal sHostName As String)
Attribute Host.VB_Description = "Get/Set the Host Name of the FTP server"
'
' Set the Host Name - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "ACNFTP:Host_Let", ERRALREADYCONNECTED
End If
msHostAddress = sHostName
End Property
Public Property Get Host() As String
'
' Get Host Name
'
Host = msHostAddress
End Property
Public Property Let User(ByVal sUserName As String)
Attribute User.VB_Description = "Get/Set the login user id for the FTP server"
'
' Set the user - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "CGFTP::User_Let", ERRALREADYCONNECTED
End If
msUser = sUserName
End Property
Public Property Get User() As String
'
' Get the user information
'
User = msUser
End Property
Public Property Let Password(ByVal sPassword As String)
Attribute Password.VB_Description = "Get/Set the password for logging into the FTP server"
'
' Set the password - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "CGFTP::Password_Let", ERRALREADYCONNECTED
End If
msPassword = sPassword
End Property
Public Property Get Password() As String
'
' Get the password
'
Password = msPassword
End Property
Public Property Get Directory() As String
Attribute Directory.VB_Description = "Change Remote Directory"
'
' Get the directory
'
Directory = msDirectory
End Property
Public Property Let Directory(ByVal sDirectory As String)
'
' Set the directory - only if connected
'
On Error GoTo vbErrorHandler
Dim sError As String
If Not (mlConnection = 0) Then
RemoteChDir sDirectory
msDirectory = sDirectory
Else
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::Directory_Let", ERRNOCONNECTION
End If
Exit Property
vbErrorHandler:
Err.Raise errNoDirChange, "CGFTP::Directory[Let]", Err.Description
End Property
Public Property Get Connected() As Boolean
Attribute Connected.VB_Description = "Are we connected to an FTP server ? (True/False)"
'
' Are we connected to an FTP Server ? T/F
'
Connected = (mlConnection <> 0)
End Property
Public Function Connect(Optional Host As String, _
Optional User As String, _
Optional Password As String) As Boolean
Attribute Connect.VB_Description = "Connect to the FTP Server using the passed parameters (if any)"
'
' Connect to the FTP server
'
On Error GoTo vbErrorHandler
Dim sError As String
'
' If we already have a connection then raise an error
'
If mlConnection <> 0 Then
On Error GoTo 0
Err.Raise errInvalidProperty, "CGFTP::Connect", "You are already connected to FTP Server " & msHostAddress
Exit Function
End If
'
' Overwrite any existing properties if they were supplied in the
' arguments to this method
'
If Len(Host) > 0 Then
msHostAddress = Host
End If
If Len(User) > 0 Then
msUser = User
End If
If Len(Password) > 0 Then
msPassword = Password
End If
'
' Connect !
'
If Len(msHostAddress) = 0 Then
Err.Raise errInvalidProperty, "CGFTP::Connect", "No Host Address Specified!"
End If
mlConnection = InternetConnect(mlINetHand
msUser, msPassword, INTERNET_SERVICE_FTP, 0, 0)
'
' Check for connection errors
'
If mlConnection = 0 Then
sError = Replace(ERRCONNECTERROR, "%s", msHostAddress)
On Error GoTo 0
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotConnect, "CGFTP::Connect", sError
End If
Connect = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::Connect", Err.Description
End Function
Public Function Disconnect() As Boolean
Attribute Disconnect.VB_Description = "Disconnect from the remote FTP server"
'
' Disconnect, only if connected !
'
If mlConnection <> 0 Then
InternetCloseHandle mlConnection
mlConnection = 0
Else
Err.Raise errNotConnectedToSite, "CGFTP::Disconnect", ERRNOCONNECTION
End If
msHostAddress = ""
msUser = ""
msPassword = ""
msDirectory = ""
End Function
Public Function GetDirectoryList(Optional Directory As String, Optional FilterString As String) As ADOR.Recordset
Attribute GetDirectoryList.VB_Descri
'
' Returns a Disconnected record set for the
' directory and filterstring
'
' eg. "/NTFFiles", "*.ntf"
'
On Error GoTo vbErrorHandler
Dim oFileColl As Collection
Dim lFind As Long
Dim lLastError As Long
Dim lPtr As Long
Dim pData As WIN32_FIND_DATA
Dim sFilter As String
Dim lError As Long
Dim bRet As Boolean
Dim sItemName As String
Dim oRS As ADOR.Recordset
'
' Check if already connected, else raise an error
'
If mlConnection = 0 Then
Err.Raise errNotConnectedToSite, "CGFTP::GetDirectoryList", ERRNOCONNECTION
End If
'
' Build the disconnected recordset structure.
'
Set oRS = New ADOR.Recordset
oRS.CursorLocation = adUseClient
oRS.Fields.Append "Name", adBSTR
oRS.Open
'
' Change directory if required
'
If Len(Directory) > 0 Then
RemoteChDir Directory
End If
pData.cFileName = String$(MAX_PATH, vbNullChar)
If Len(FilterString) > 0 Then
sFilter = FilterString
Else
sFilter = "*.*"
End If
'
' Get the first file in the directory
'
lFind = FtpFindFirstFile(mlConnect
lLastError = Err.LastDllError
'
' If no files, then return an empty recordset.
'
If lFind = 0 Then
If lLastError = ERROR_NO_MORE_FILES Then
' Empty directory
Set GetDirectoryList = oRS
Exit Function
Else
On Error GoTo 0
Err.Raise lLastError, "cFTP::GetDirectoryList", "Error looking at directory " & Directory & "\" & FilterString
End If
Exit Function
End If
'
' Add the first found file into the recordset
'
sItemName = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar, vbBinaryCompare) - 1)
oRS.AddNew "Name", sItemName
'
' Get the rest of the files in the list
'
Do
pData.cFileName = String(MAX_PATH, vbNullChar)
bRet = InternetFindNextFile(lFind
If Not (bRet) Then
lLastError = Err.LastDllError
If lLastError = ERROR_NO_MORE_FILES Then
Exit Do
Else
InternetCloseHandle lFind
On Error GoTo 0
Err.Raise lLastError, "cFTP::GetDirectoryList", "Error looking at directory " & Directory & "\" & FilterString
Exit Function
End If
Else
sItemName = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar, vbBinaryCompare) - 1)
oRS.AddNew "Name", sItemName
End If
Loop
'
' Close the 'find' handle
'
InternetCloseHandle lFind
On Error Resume Next
oRS.MoveFirst
Err.Clear
On Error GoTo 0
Set GetDirectoryList = oRS
Exit Function
vbErrorHandler:
'
' Tidy up & raise an error
'
If lFind <> 0 Then
InternetCloseHandle lFind
End If
Set GetDirectoryList = oRS
Err.Raise Err.Number, "cFTP::GetDirectoryList", Err.Description
End Function
Public Function GetFile(ByVal ServerFileAndPath As String, ByVal DestinationFileAndPath As String, Optional TransferType As FileTransferType = ftAscii) As Boolean
Attribute GetFile.VB_Description = "Download a file from the FTP Server"
'
' Get the specified file to the desired location using the specified
' file transfer type
'
Dim bRet As Boolean
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String
Dim sTemp As String
Dim lPos As Long
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::GetFile", ERRNOCONNECTION
End If
'
' Get the file
'
bRet = FtpGetFile(mlConnection, ServerFileAndPath, DestinationFileAndPath, False, INTERNET_FLAG_RELOAD, TransferType, 0)
If bRet = False Then
sError = ERRNODOWNLOAD
sError = Replace(sError, "%s", ServerFileAndPath)
On Error GoTo 0
GetFile = False
Err.Raise errGetFileError, "CGFTP::GetFile", sError
End If
GetFile = True
Exit Function
vbErrorHandler:
GetFile = False
Err.Raise errGetFileError, "cFTP::GetFile", Err.Description
End Function
Public Function PutFile(ByVal LocalFileAndPath As String, ByVal ServerFileAndPath As String, Optional TransferType As FileTransferType) As Boolean
Attribute PutFile.VB_Description = "Upload a file to the FTP server"
Dim bRet As Boolean
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String
Dim sTemp As String
Dim lPos As Long
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error!
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::PutFile", ERRNOCONNECTION
End If
bRet = FtpPutFile(mlConnection, LocalFileAndPath, ServerFileAndPath, _
TransferType, 0)
If bRet = False Then
sError = ERRNODOWNLOAD
sError = Replace(sError, "%s", ServerFileAndPath)
On Error GoTo 0
PutFile = False
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotRename, "CGFTP::PutFile", sError
End If
PutFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::PutFile", Err.Description
End Function
Public Function RenameFile(ByVal ExistingName As String, ByVal NewName As String) As Boolean
Attribute RenameFile.VB_Description = "Rename a file on the FTP server"
Dim bRet As Boolean
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::RenameFile", ERRNOCONNECTION
End If
bRet = FtpRenameFile(mlConnection
'
' Raise an error if we couldn't rename the file (most likely that
' a file with the new name already exists
'
If bRet = False Then
sError = ERRNORENAME
sError = Replace(sError, "%s", ExistingName)
On Error GoTo 0
RenameFile = False
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotRename, "CGFTP::RenameFile", sError
End If
RenameFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::RenameFile", Err.Description
End Function
Public Function DeleteFile(ByVal ExistingName As String) As Boolean
Attribute DeleteFile.VB_Description = "Delete a file from the FTP server"
Dim bRet As Boolean
Dim sError As String
On Error GoTo vbErrorHandler
'
' Check for a connection
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::DeleteFile", ERRNOCONNECTION
End If
bRet = FtpDeleteFile(mlConnection
'
' Raise an error if the file couldn't be deleted
'
If bRet = False Then
sError = ERRNODELETE
sError = Replace(sError, "%s", ExistingName)
On Error GoTo 0
Err.Raise errCannotDelete, "CGFTP::DeleteFile", sError
End If
DeleteFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::DeleteFile", Err.Description
End Function
Private Sub RemoteChDir(ByVal sDir As String)
On Error GoTo vbErrorHandler
'
' Remote Change Directory Command through WININET
'
Dim sPathFromRoot As String
Dim bRet As Boolean
Dim sError As String
'
' Needs standard Unix Convention
'
sDir = Replace(sDir, "\", "/")
'
' Check for a connection
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::RemoteChDir", ERRNOCONNECTION
Exit Sub
End If
If Len(sDir) = 0 Then
Exit Sub
Else
sPathFromRoot = sDir
If Len(sPathFromRoot) = 0 Then
sPathFromRoot = "/"
End If
bRet = FtpSetCurrentDirectory(mlC
'
' If we couldn't change directory - raise an error
'
If bRet = False Then
sError = ERRCHANGEDIRSTR
sError = Replace(sError, "%s", sDir)
On Error GoTo 0
Err.Raise errNoDirChange, "CGFTP::ChangeDirectory", sError
End If
End If
Exit Sub
vbErrorHandler:
Err.Raise Err.Number, "cFTP::RemoteChDir", Err.Description
End Sub
Private Function GetINETErrorMsg(ByVal ErrNum As Long) As String
Dim lError As Long
Dim lLen As Long
Dim sBuffer As String
'
' Get Extra Info from the WinInet.DLL
'
If ErrNum = ERROR_INTERNET_EXTENDED_ER
'
' Get Message Size and Number
'
InternetGetLastResponseInf
sBuffer = String$(lLen + 1, vbNullChar)
'
' Get Message
'
InternetGetLastResponseInf
GetINETErrorMsg = vbCrLf & sBuffer
End If
End Function
here is a best
' #VBIDEUtils#**************
' * Programmer Name : Chris Eastwood
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : waty.thierry@usa.net
' * Date : 02/09/1999
' * Time : 14:37
' **************************
' * Comments : FTP Access through a Class Module for VB5/6
' *
' *
' **************************
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "cFTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'
' CodeGuru FTP Class
'
' Chris Eastwood July 1999
'
' This class wraps the functionality of the Win32 WinInet.DLL
'
' It could easily be expanded to provide HTTP/Gopher and other internet
' standard file protocols.
'
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private 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 Const ERROR_NO_MORE_FILES = 18
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
(ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" _
(ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _
lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" _
(ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
' Initializes an application's use of the Win32 Internet functions
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
' Use registry access settings.
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_INVALID_PORT_NUMB
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H1
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _
ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Const ERROR_INTERNET_EXTENDED_ER
Private Declare Function InternetGetLastResponseInf
lpdwError As Long, _
ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Boolean
' Type of service to access.
Private Const INTERNET_SERVICE_FTP = 1
'private Const INTERNET_SERVICE_GOPHER = 2
'private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECT
Private Const INTERNET_FLAG_MULTIPART = &H200000
Private Declare Function FtpOpenFile Lib "wininet.dll" Alias _
"FtpOpenFileA" (ByVal hFtpSession As Long, _
ByVal sFileName As String, ByVal lAccess As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function FtpDeleteFile Lib "wininet.dll" _
Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
ByVal lpszFileName As String) As Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias _
"FtpRenameFileA" (ByVal hFtpSession As Long, _
ByVal sExistingName As String, _
ByVal sNewName As String) As Boolean
' Closes a single Internet handle or a subtree of Internet handles.
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
'
' Our Defined Errors
'
Public Enum errFtpErrors
errCannotConnect = vbObjectError + 2001
errNoDirChange = vbObjectError + 2002
errCannotRename = vbObjectError + 2003
errCannotDelete = vbObjectError + 2004
errNotConnectedToSite = vbObjectError + 2005
errGetFileError = vbObjectError + 2006
errInvalidProperty = vbObjectError + 2007
errFatal = vbObjectError + 2008
End Enum
'
' File Transfer types
'
Public Enum FileTransferType
ftAscii = FTP_TRANSFER_TYPE_ASCII
ftBinary = FTP_TRANSFER_TYPE_BINARY
End Enum
'
' Error messages
'
Private Const ERRCHANGEDIRSTR As String = "Cannot Change Directory to %s. It either doesn't exist, or is protected"
Private Const ERRCONNECTERROR As String = "Cannot Connect to %s using User and Password Parameters"
Private Const ERRNOCONNECTION As String = "Not Connected to FTP Site"
Private Const ERRNODOWNLOAD As String = "Couldn't Get File %s from Server"
Private Const ERRNORENAME As String = "Couldn't Rename File %s"
Private Const ERRNODELETE As String = "Couldn't Delete File %s from Server"
Private Const ERRALREADYCONNECTED As String = "You cannot change this property while connected to an FTP server"
Private Const ERRFATALERROR As String = "Cannot get Connection to WinInet.dll !"
'
' Session Identifier to Windows
'
Private Const SESSION As String = "CGFtp Instance"
'
' Our INET handle
'
Private mlINetHandle As Long
'
' Our FTP Connection Handle
'
Private mlConnection As Long
'
' Standard FTP properties for this class
'
Private msHostAddress As String
Private msUser As String
Private msPassword As String
Private msDirectory As String
Private Sub Class_Initialize()
'
' Create Internet session handle
'
mlINetHandle = InternetOpen(SESSION, INTERNET_OPEN_TYPE_DIRECT,
If mlINetHandle = 0 Then
mlConnection = 0
Err.Raise errFatal, "CGFTP::Class_Initialise", ERRFATALERROR
End If
mlConnection = 0
End Sub
Private Sub Class_Terminate()
'
' Kill off any connection
'
If mlConnection <> 0 Then
InternetCloseHandle mlConnection
End If
'
' Kill off API Handle
'
If mlINetHandle <> 0 Then
InternetCloseHandle mlINetHandle
End If
mlConnection = 0
mlINetHandle = 0
End Sub
Public Property Let Host(ByVal sHostName As String)
Attribute Host.VB_Description = "Get/Set the Host Name of the FTP server"
'
' Set the Host Name - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "ACNFTP:Host_Let", ERRALREADYCONNECTED
End If
msHostAddress = sHostName
End Property
Public Property Get Host() As String
'
' Get Host Name
'
Host = msHostAddress
End Property
Public Property Let User(ByVal sUserName As String)
Attribute User.VB_Description = "Get/Set the login user id for the FTP server"
'
' Set the user - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "CGFTP::User_Let", ERRALREADYCONNECTED
End If
msUser = sUserName
End Property
Public Property Get User() As String
'
' Get the user information
'
User = msUser
End Property
Public Property Let Password(ByVal sPassword As String)
Attribute Password.VB_Description = "Get/Set the password for logging into the FTP server"
'
' Set the password - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "CGFTP::Password_Let", ERRALREADYCONNECTED
End If
msPassword = sPassword
End Property
Public Property Get Password() As String
'
' Get the password
'
Password = msPassword
End Property
Public Property Get Directory() As String
Attribute Directory.VB_Description = "Change Remote Directory"
'
' Get the directory
'
Directory = msDirectory
End Property
Public Property Let Directory(ByVal sDirectory As String)
'
' Set the directory - only if connected
'
On Error GoTo vbErrorHandler
Dim sError As String
If Not (mlConnection = 0) Then
RemoteChDir sDirectory
msDirectory = sDirectory
Else
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::Directory_Let", ERRNOCONNECTION
End If
Exit Property
vbErrorHandler:
Err.Raise errNoDirChange, "CGFTP::Directory[Let]", Err.Description
End Property
Public Property Get Connected() As Boolean
Attribute Connected.VB_Description = "Are we connected to an FTP server ? (True/False)"
'
' Are we connected to an FTP Server ? T/F
'
Connected = (mlConnection <> 0)
End Property
Public Function Connect(Optional Host As String, _
Optional User As String, _
Optional Password As String) As Boolean
Attribute Connect.VB_Description = "Connect to the FTP Server using the passed parameters (if any)"
'
' Connect to the FTP server
'
On Error GoTo vbErrorHandler
Dim sError As String
'
' If we already have a connection then raise an error
'
If mlConnection <> 0 Then
On Error GoTo 0
Err.Raise errInvalidProperty, "CGFTP::Connect", "You are already connected to FTP Server " & msHostAddress
Exit Function
End If
'
' Overwrite any existing properties if they were supplied in the
' arguments to this method
'
If Len(Host) > 0 Then
msHostAddress = Host
End If
If Len(User) > 0 Then
msUser = User
End If
If Len(Password) > 0 Then
msPassword = Password
End If
'
' Connect !
'
If Len(msHostAddress) = 0 Then
Err.Raise errInvalidProperty, "CGFTP::Connect", "No Host Address Specified!"
End If
mlConnection = InternetConnect(mlINetHand
msUser, msPassword, INTERNET_SERVICE_FTP, 0, 0)
'
' Check for connection errors
'
If mlConnection = 0 Then
sError = Replace(ERRCONNECTERROR, "%s", msHostAddress)
On Error GoTo 0
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotConnect, "CGFTP::Connect", sError
End If
Connect = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::Connect", Err.Description
End Function
Public Function Disconnect() As Boolean
Attribute Disconnect.VB_Description = "Disconnect from the remote FTP server"
'
' Disconnect, only if connected !
'
If mlConnection <> 0 Then
InternetCloseHandle mlConnection
mlConnection = 0
Else
Err.Raise errNotConnectedToSite, "CGFTP::Disconnect", ERRNOCONNECTION
End If
msHostAddress = ""
msUser = ""
msPassword = ""
msDirectory = ""
End Function
Public Function GetDirectoryList(Optional Directory As String, Optional FilterString As String) As ADOR.Recordset
Attribute GetDirectoryList.VB_Descri
'
' Returns a Disconnected record set for the
' directory and filterstring
'
' eg. "/NTFFiles", "*.ntf"
'
On Error GoTo vbErrorHandler
Dim oFileColl As Collection
Dim lFind As Long
Dim lLastError As Long
Dim lPtr As Long
Dim pData As WIN32_FIND_DATA
Dim sFilter As String
Dim lError As Long
Dim bRet As Boolean
Dim sItemName As String
Dim oRS As ADOR.Recordset
'
' Check if already connected, else raise an error
'
If mlConnection = 0 Then
Err.Raise errNotConnectedToSite, "CGFTP::GetDirectoryList", ERRNOCONNECTION
End If
'
' Build the disconnected recordset structure.
'
Set oRS = New ADOR.Recordset
oRS.CursorLocation = adUseClient
oRS.Fields.Append "Name", adBSTR
oRS.Open
'
' Change directory if required
'
If Len(Directory) > 0 Then
RemoteChDir Directory
End If
pData.cFileName = String$(MAX_PATH, vbNullChar)
If Len(FilterString) > 0 Then
sFilter = FilterString
Else
sFilter = "*.*"
End If
'
' Get the first file in the directory
'
lFind = FtpFindFirstFile(mlConnect
lLastError = Err.LastDllError
'
' If no files, then return an empty recordset.
'
If lFind = 0 Then
If lLastError = ERROR_NO_MORE_FILES Then
' Empty directory
Set GetDirectoryList = oRS
Exit Function
Else
On Error GoTo 0
Err.Raise lLastError, "cFTP::GetDirectoryList", "Error looking at directory " & Directory & "\" & FilterString
End If
Exit Function
End If
'
' Add the first found file into the recordset
'
sItemName = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar, vbBinaryCompare) - 1)
oRS.AddNew "Name", sItemName
'
' Get the rest of the files in the list
'
Do
pData.cFileName = String(MAX_PATH, vbNullChar)
bRet = InternetFindNextFile(lFind
If Not (bRet) Then
lLastError = Err.LastDllError
If lLastError = ERROR_NO_MORE_FILES Then
Exit Do
Else
InternetCloseHandle lFind
On Error GoTo 0
Err.Raise lLastError, "cFTP::GetDirectoryList", "Error looking at directory " & Directory & "\" & FilterString
Exit Function
End If
Else
sItemName = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar, vbBinaryCompare) - 1)
oRS.AddNew "Name", sItemName
End If
Loop
'
' Close the 'find' handle
'
InternetCloseHandle lFind
On Error Resume Next
oRS.MoveFirst
Err.Clear
On Error GoTo 0
Set GetDirectoryList = oRS
Exit Function
vbErrorHandler:
'
' Tidy up & raise an error
'
If lFind <> 0 Then
InternetCloseHandle lFind
End If
Set GetDirectoryList = oRS
Err.Raise Err.Number, "cFTP::GetDirectoryList", Err.Description
End Function
Public Function GetFile(ByVal ServerFileAndPath As String, ByVal DestinationFileAndPath As String, Optional TransferType As FileTransferType = ftAscii) As Boolean
Attribute GetFile.VB_Description = "Download a file from the FTP Server"
'
' Get the specified file to the desired location using the specified
' file transfer type
'
Dim bRet As Boolean
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String
Dim sTemp As String
Dim lPos As Long
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::GetFile", ERRNOCONNECTION
End If
'
' Get the file
'
bRet = FtpGetFile(mlConnection, ServerFileAndPath, DestinationFileAndPath, False, INTERNET_FLAG_RELOAD, TransferType, 0)
If bRet = False Then
sError = ERRNODOWNLOAD
sError = Replace(sError, "%s", ServerFileAndPath)
On Error GoTo 0
GetFile = False
Err.Raise errGetFileError, "CGFTP::GetFile", sError
End If
GetFile = True
Exit Function
vbErrorHandler:
GetFile = False
Err.Raise errGetFileError, "cFTP::GetFile", Err.Description
End Function
Public Function PutFile(ByVal LocalFileAndPath As String, ByVal ServerFileAndPath As String, Optional TransferType As FileTransferType) As Boolean
Attribute PutFile.VB_Description = "Upload a file to the FTP server"
Dim bRet As Boolean
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String
Dim sTemp As String
Dim lPos As Long
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error!
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::PutFile", ERRNOCONNECTION
End If
bRet = FtpPutFile(mlConnection, LocalFileAndPath, ServerFileAndPath, _
TransferType, 0)
If bRet = False Then
sError = ERRNODOWNLOAD
sError = Replace(sError, "%s", ServerFileAndPath)
On Error GoTo 0
PutFile = False
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotRename, "CGFTP::PutFile", sError
End If
PutFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::PutFile", Err.Description
End Function
Public Function RenameFile(ByVal ExistingName As String, ByVal NewName As String) As Boolean
Attribute RenameFile.VB_Description = "Rename a file on the FTP server"
Dim bRet As Boolean
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::RenameFile", ERRNOCONNECTION
End If
bRet = FtpRenameFile(mlConnection
'
' Raise an error if we couldn't rename the file (most likely that
' a file with the new name already exists
'
If bRet = False Then
sError = ERRNORENAME
sError = Replace(sError, "%s", ExistingName)
On Error GoTo 0
RenameFile = False
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotRename, "CGFTP::RenameFile", sError
End If
RenameFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::RenameFile", Err.Description
End Function
Public Function DeleteFile(ByVal ExistingName As String) As Boolean
Attribute DeleteFile.VB_Description = "Delete a file from the FTP server"
Dim bRet As Boolean
Dim sError As String
On Error GoTo vbErrorHandler
'
' Check for a connection
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::DeleteFile", ERRNOCONNECTION
End If
bRet = FtpDeleteFile(mlConnection
'
' Raise an error if the file couldn't be deleted
'
If bRet = False Then
sError = ERRNODELETE
sError = Replace(sError, "%s", ExistingName)
On Error GoTo 0
Err.Raise errCannotDelete, "CGFTP::DeleteFile", sError
End If
DeleteFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::DeleteFile", Err.Description
End Function
Private Sub RemoteChDir(ByVal sDir As String)
On Error GoTo vbErrorHandler
'
' Remote Change Directory Command through WININET
'
Dim sPathFromRoot As String
Dim bRet As Boolean
Dim sError As String
'
' Needs standard Unix Convention
'
sDir = Replace(sDir, "\", "/")
'
' Check for a connection
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::RemoteChDir", ERRNOCONNECTION
Exit Sub
End If
If Len(sDir) = 0 Then
Exit Sub
Else
sPathFromRoot = sDir
If Len(sPathFromRoot) = 0 Then
sPathFromRoot = "/"
End If
bRet = FtpSetCurrentDirectory(mlC
'
' If we couldn't change directory - raise an error
'
If bRet = False Then
sError = ERRCHANGEDIRSTR
sError = Replace(sError, "%s", sDir)
On Error GoTo 0
Err.Raise errNoDirChange, "CGFTP::ChangeDirectory", sError
End If
End If
Exit Sub
vbErrorHandler:
Err.Raise Err.Number, "cFTP::RemoteChDir", Err.Description
End Sub
Private Function GetINETErrorMsg(ByVal ErrNum As Long) As String
Dim lError As Long
Dim lLen As Long
Dim sBuffer As String
'
' Get Extra Info from the WinInet.DLL
'
If ErrNum = ERROR_INTERNET_EXTENDED_ER
'
' Get Message Size and Number
'
InternetGetLastResponseInf
sBuffer = String$(lLen + 1, vbNullChar)
'
' Get Message
'
InternetGetLastResponseInf
GetINETErrorMsg = vbCrLf & sBuffer
End If
End Function
ASKER
Waty,
Thanks your quick response. I will try and let you know.
?->
Thanks your quick response. I will try and let you know.
?->
:§)
ASKER
Sorry waty, I have to reject your answer.
http://www.vbip.com/wininet/files/wininet_ftpclient.zip
- did not time out if I passed an invalid address
http://www.netfokus.dk/vbadmincode/code/rftp50w.zip
- I already state that I can¡¦t use msinet.ocx
http://www.planetsourcecode.com/vb/default.asp?lngCId=3759&lngWId=1
- demo.vpb ?? not ftp ??
http://pc13.virtualave.net/files/FTP%20Client%20Example.zip
and also you example
- did not time out if I passed an invalid address
Waty:
What I really want is how to turn on the time out capability if I use wininet.dll on VB.
There is a property called Requesttimeout on the msinet.ocx which will unblock my task if the time out has been expired. I would like to do the same thing if I use wininet.dll. How can I do that.
?-<
http://www.vbip.com/wininet/files/wininet_ftpclient.zip
- did not time out if I passed an invalid address
http://www.netfokus.dk/vbadmincode/code/rftp50w.zip
- I already state that I can¡¦t use msinet.ocx
http://www.planetsourcecode.com/vb/default.asp?lngCId=3759&lngWId=1
- demo.vpb ?? not ftp ??
http://pc13.virtualave.net/files/FTP%20Client%20Example.zip
and also you example
- did not time out if I passed an invalid address
Waty:
What I really want is how to turn on the time out capability if I use wininet.dll on VB.
There is a property called Requesttimeout on the msinet.ocx which will unblock my task if the time out has been expired. I would like to do the same thing if I use wininet.dll. How can I do that.
?-<
The links I gave were just for info
I use myself this class wich I gave before
' #VBIDEUtils#**************
' * Programmer Name : Chris Eastwood
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : waty.thierry@usa.net
' * Date : 02/09/1999
' * Time : 14:37
' **************************
' * Comments : FTP Access through a Class Module for VB5/6
' *
' *
' **************************
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "cFTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'
' CodeGuru FTP Class
'
' Chris Eastwood July 1999
'
' This class wraps the functionality of the Win32 WinInet.DLL
'
' It could easily be expanded to provide HTTP/Gopher and other internet
' standard file protocols.
'
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private 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 Const ERROR_NO_MORE_FILES = 18
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
(ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" _
(ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _
lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" _
(ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
' Initializes an application's use of the Win32 Internet functions
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
' Use registry access settings.
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_INVALID_PORT_NUMB
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H1
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _
ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Const ERROR_INTERNET_EXTENDED_ER
Private Declare Function InternetGetLastResponseInf
lpdwError As Long, _
ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Boolean
' Type of service to access.
Private Const INTERNET_SERVICE_FTP = 1
'private Const INTERNET_SERVICE_GOPHER = 2
'private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECT
Private Const INTERNET_FLAG_MULTIPART = &H200000
Private Declare Function FtpOpenFile Lib "wininet.dll" Alias _
"FtpOpenFileA" (ByVal hFtpSession As Long, _
ByVal sFileName As String, ByVal lAccess As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function FtpDeleteFile Lib "wininet.dll" _
Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
ByVal lpszFileName As String) As Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias _
"FtpRenameFileA" (ByVal hFtpSession As Long, _
ByVal sExistingName As String, _
ByVal sNewName As String) As Boolean
' Closes a single Internet handle or a subtree of Internet handles.
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
'
' Our Defined Errors
'
Public Enum errFtpErrors
errCannotConnect = vbObjectError + 2001
errNoDirChange = vbObjectError + 2002
errCannotRename = vbObjectError + 2003
errCannotDelete = vbObjectError + 2004
errNotConnectedToSite = vbObjectError + 2005
errGetFileError = vbObjectError + 2006
errInvalidProperty = vbObjectError + 2007
errFatal = vbObjectError + 2008
End Enum
'
' File Transfer types
'
Public Enum FileTransferType
ftAscii = FTP_TRANSFER_TYPE_ASCII
ftBinary = FTP_TRANSFER_TYPE_BINARY
End Enum
'
' Error messages
'
Private Const ERRCHANGEDIRSTR As String = "Cannot Change Directory to %s. It either doesn't exist, or is protected"
Private Const ERRCONNECTERROR As String = "Cannot Connect to %s using User and Password Parameters"
Private Const ERRNOCONNECTION As String = "Not Connected to FTP Site"
Private Const ERRNODOWNLOAD As String = "Couldn't Get File %s from Server"
Private Const ERRNORENAME As String = "Couldn't Rename File %s"
Private Const ERRNODELETE As String = "Couldn't Delete File %s from Server"
Private Const ERRALREADYCONNECTED As String = "You cannot change this property while connected to an FTP server"
Private Const ERRFATALERROR As String = "Cannot get Connection to WinInet.dll !"
'
' Session Identifier to Windows
'
Private Const SESSION As String = "CGFtp Instance"
'
' Our INET handle
'
Private mlINetHandle As Long
'
' Our FTP Connection Handle
'
Private mlConnection As Long
'
' Standard FTP properties for this class
'
Private msHostAddress As String
Private msUser As String
Private msPassword As String
Private msDirectory As String
Private Sub Class_Initialize()
'
' Create Internet session handle
'
mlINetHandle = InternetOpen(SESSION, INTERNET_OPEN_TYPE_DIRECT,
If mlINetHandle = 0 Then
mlConnection = 0
Err.Raise errFatal, "CGFTP::Class_Initialise", ERRFATALERROR
End If
mlConnection = 0
End Sub
Private Sub Class_Terminate()
'
' Kill off any connection
'
If mlConnection <> 0 Then
InternetCloseHandle mlConnection
End If
'
' Kill off API Handle
'
If mlINetHandle <> 0 Then
InternetCloseHandle mlINetHandle
End If
mlConnection = 0
mlINetHandle = 0
End Sub
Public Property Let Host(ByVal sHostName As String)
Attribute Host.VB_Description = "Get/Set the Host Name of the FTP server"
'
' Set the Host Name - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "ACNFTP:Host_Let", ERRALREADYCONNECTED
End If
msHostAddress = sHostName
End Property
Public Property Get Host() As String
'
' Get Host Name
'
Host = msHostAddress
End Property
Public Property Let User(ByVal sUserName As String)
Attribute User.VB_Description = "Get/Set the login user id for the FTP server"
'
' Set the user - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "CGFTP::User_Let", ERRALREADYCONNECTED
End If
msUser = sUserName
End Property
Public Property Get User() As String
'
' Get the user information
'
User = msUser
End Property
Public Property Let Password(ByVal sPassword As String)
Attribute Password.VB_Description = "Get/Set the password for logging into the FTP server"
'
' Set the password - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "CGFTP::Password_Let", ERRALREADYCONNECTED
End If
msPassword = sPassword
End Property
Public Property Get Password() As String
'
' Get the password
'
Password = msPassword
End Property
Public Property Get Directory() As String
Attribute Directory.VB_Description = "Change Remote Directory"
'
' Get the directory
'
Directory = msDirectory
End Property
Public Property Let Directory(ByVal sDirectory As String)
'
' Set the directory - only if connected
'
On Error GoTo vbErrorHandler
Dim sError As String
If Not (mlConnection = 0) Then
RemoteChDir sDirectory
msDirectory = sDirectory
Else
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::Directory_Let", ERRNOCONNECTION
End If
Exit Property
vbErrorHandler:
Err.Raise errNoDirChange, "CGFTP::Directory[Let]", Err.Description
End Property
Public Property Get Connected() As Boolean
Attribute Connected.VB_Description = "Are we connected to an FTP server ? (True/False)"
'
' Are we connected to an FTP Server ? T/F
'
Connected = (mlConnection <> 0)
End Property
Public Function Connect(Optional Host As String, _
Optional User As String, _
Optional Password As String) As Boolean
Attribute Connect.VB_Description = "Connect to the FTP Server using the passed parameters (if any)"
'
' Connect to the FTP server
'
On Error GoTo vbErrorHandler
Dim sError As String
'
' If we already have a connection then raise an error
'
If mlConnection <> 0 Then
On Error GoTo 0
Err.Raise errInvalidProperty, "CGFTP::Connect", "You are already connected to FTP Server " & msHostAddress
Exit Function
End If
'
' Overwrite any existing properties if they were supplied in the
' arguments to this method
'
If Len(Host) > 0 Then
msHostAddress = Host
End If
If Len(User) > 0 Then
msUser = User
End If
If Len(Password) > 0 Then
msPassword = Password
End If
'
' Connect !
'
If Len(msHostAddress) = 0 Then
Err.Raise errInvalidProperty, "CGFTP::Connect", "No Host Address Specified!"
End If
mlConnection = InternetConnect(mlINetHand
msUser, msPassword, INTERNET_SERVICE_FTP, 0, 0)
'
' Check for connection errors
'
If mlConnection = 0 Then
sError = Replace(ERRCONNECTERROR, "%s", msHostAddress)
On Error GoTo 0
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotConnect, "CGFTP::Connect", sError
End If
Connect = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::Connect", Err.Description
End Function
Public Function Disconnect() As Boolean
Attribute Disconnect.VB_Description = "Disconnect from the remote FTP server"
'
' Disconnect, only if connected !
'
If mlConnection <> 0 Then
InternetCloseHandle mlConnection
mlConnection = 0
Else
Err.Raise errNotConnectedToSite, "CGFTP::Disconnect", ERRNOCONNECTION
End If
msHostAddress = ""
msUser = ""
msPassword = ""
msDirectory = ""
End Function
Public Function GetDirectoryList(Optional Directory As String, Optional FilterString As String) As ADOR.Recordset
Attribute GetDirectoryList.VB_Descri
'
' Returns a Disconnected record set for the
' directory and filterstring
'
' eg. "/NTFFiles", "*.ntf"
'
On Error GoTo vbErrorHandler
Dim oFileColl As Collection
Dim lFind As Long
Dim lLastError As Long
Dim lPtr As Long
Dim pData As WIN32_FIND_DATA
Dim sFilter As String
Dim lError As Long
Dim bRet As Boolean
Dim sItemName As String
Dim oRS As ADOR.Recordset
'
' Check if already connected, else raise an error
'
If mlConnection = 0 Then
Err.Raise errNotConnectedToSite, "CGFTP::GetDirectoryList", ERRNOCONNECTION
End If
'
' Build the disconnected recordset structure.
'
Set oRS = New ADOR.Recordset
oRS.CursorLocation = adUseClient
oRS.Fields.Append "Name", adBSTR
oRS.Open
'
' Change directory if required
'
If Len(Directory) > 0 Then
RemoteChDir Directory
End If
pData.cFileName = String$(MAX_PATH, vbNullChar)
If Len(FilterString) > 0 Then
sFilter = FilterString
Else
sFilter = "*.*"
End If
'
' Get the first file in the directory
'
lFind = FtpFindFirstFile(mlConnect
lLastError = Err.LastDllError
'
' If no files, then return an empty recordset.
'
If lFind = 0 Then
If lLastError = ERROR_NO_MORE_FILES Then
' Empty directory
Set GetDirectoryList = oRS
Exit Function
Else
On Error GoTo 0
Err.Raise lLastError, "cFTP::GetDirectoryList", "Error looking at directory " & Directory & "\" & FilterString
End If
Exit Function
End If
'
' Add the first found file into the recordset
'
sItemName = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar, vbBinaryCompare) - 1)
oRS.AddNew "Name", sItemName
'
' Get the rest of the files in the list
'
Do
pData.cFileName = String(MAX_PATH, vbNullChar)
bRet = InternetFindNextFile(lFind
If Not (bRet) Then
lLastError = Err.LastDllError
If lLastError = ERROR_NO_MORE_FILES Then
Exit Do
Else
InternetCloseHandle lFind
On Error GoTo 0
Err.Raise lLastError, "cFTP::GetDirectoryList", "Error looking at directory " & Directory & "\" & FilterString
Exit Function
End If
Else
sItemName = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar, vbBinaryCompare) - 1)
oRS.AddNew "Name", sItemName
End If
Loop
'
' Close the 'find' handle
'
InternetCloseHandle lFind
On Error Resume Next
oRS.MoveFirst
Err.Clear
On Error GoTo 0
Set GetDirectoryList = oRS
Exit Function
vbErrorHandler:
'
' Tidy up & raise an error
'
If lFind <> 0 Then
InternetCloseHandle lFind
End If
Set GetDirectoryList = oRS
Err.Raise Err.Number, "cFTP::GetDirectoryList", Err.Description
End Function
Public Function GetFile(ByVal ServerFileAndPath As String, ByVal DestinationFileAndPath As String, Optional TransferType As FileTransferType = ftAscii) As Boolean
Attribute GetFile.VB_Description = "Download a file from the FTP Server"
'
' Get the specified file to the desired location using the specified
' file transfer type
'
Dim bRet As Boolean
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String
Dim sTemp As String
Dim lPos As Long
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::GetFile", ERRNOCONNECTION
End If
'
' Get the file
'
bRet = FtpGetFile(mlConnection, ServerFileAndPath, DestinationFileAndPath, False, INTERNET_FLAG_RELOAD, TransferType, 0)
If bRet = False Then
sError = ERRNODOWNLOAD
sError = Replace(sError, "%s", ServerFileAndPath)
On Error GoTo 0
GetFile = False
Err.Raise errGetFileError, "CGFTP::GetFile", sError
End If
GetFile = True
Exit Function
vbErrorHandler:
GetFile = False
Err.Raise errGetFileError, "cFTP::GetFile", Err.Description
End Function
Public Function PutFile(ByVal LocalFileAndPath As String, ByVal ServerFileAndPath As String, Optional TransferType As FileTransferType) As Boolean
Attribute PutFile.VB_Description = "Upload a file to the FTP server"
Dim bRet As Boolean
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String
Dim sTemp As String
Dim lPos As Long
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error!
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::PutFile", ERRNOCONNECTION
End If
bRet = FtpPutFile(mlConnection, LocalFileAndPath, ServerFileAndPath, _
TransferType, 0)
If bRet = False Then
sError = ERRNODOWNLOAD
sError = Replace(sError, "%s", ServerFileAndPath)
On Error GoTo 0
PutFile = False
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotRename, "CGFTP::PutFile", sError
End If
PutFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::PutFile", Err.Description
End Function
Public Function RenameFile(ByVal ExistingName As String, ByVal NewName As String) As Boolean
Attribute RenameFile.VB_Description = "Rename a file on the FTP server"
Dim bRet As Boolean
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::RenameFile", ERRNOCONNECTION
End If
bRet = FtpRenameFile(mlConnection
'
' Raise an error if we couldn't rename the file (most likely that
' a file with the new name already exists
'
If bRet = False Then
sError = ERRNORENAME
sError = Replace(sError, "%s", ExistingName)
On Error GoTo 0
RenameFile = False
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotRename, "CGFTP::RenameFile", sError
End If
RenameFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::RenameFile", Err.Description
End Function
Public Function DeleteFile(ByVal ExistingName As String) As Boolean
Attribute DeleteFile.VB_Description = "Delete a file from the FTP server"
Dim bRet As Boolean
Dim sError As String
On Error GoTo vbErrorHandler
'
' Check for a connection
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::DeleteFile", ERRNOCONNECTION
End If
bRet = FtpDeleteFile(mlConnection
'
' Raise an error if the file couldn't be deleted
'
If bRet = False Then
sError = ERRNODELETE
sError = Replace(sError, "%s", ExistingName)
On Error GoTo 0
Err.Raise errCannotDelete, "CGFTP::DeleteFile", sError
End If
DeleteFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::DeleteFile", Err.Description
End Function
Private Sub RemoteChDir(ByVal sDir As String)
On Error GoTo vbErrorHandler
'
' Remote Change Directory Command through WININET
'
Dim sPathFromRoot As String
Dim bRet As Boolean
Dim sError As String
'
' Needs standard Unix Convention
'
sDir = Replace(sDir, "\", "/")
'
' Check for a connection
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::RemoteChDir", ERRNOCONNECTION
Exit Sub
End If
If Len(sDir) = 0 Then
Exit Sub
Else
sPathFromRoot = sDir
If Len(sPathFromRoot) = 0 Then
sPathFromRoot = "/"
End If
bRet = FtpSetCurrentDirectory(mlC
'
' If we couldn't change directory - raise an error
'
If bRet = False Then
sError = ERRCHANGEDIRSTR
sError = Replace(sError, "%s", sDir)
On Error GoTo 0
Err.Raise errNoDirChange, "CGFTP::ChangeDirectory", sError
End If
End If
Exit Sub
vbErrorHandler:
Err.Raise Err.Number, "cFTP::RemoteChDir", Err.Description
End Sub
Private Function GetINETErrorMsg(ByVal ErrNum As Long) As String
Dim lError As Long
Dim lLen As Long
Dim sBuffer As String
'
' Get Extra Info from the WinInet.DLL
'
If ErrNum = ERROR_INTERNET_EXTENDED_ER
'
' Get Message Size and Number
'
InternetGetLastResponseInf
sBuffer = String$(lLen + 1, vbNullChar)
'
' Get Message
'
InternetGetLastResponseInf
GetINETErrorMsg = vbCrLf & sBuffer
End If
End Function
I use myself this class wich I gave before
' #VBIDEUtils#**************
' * Programmer Name : Chris Eastwood
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : waty.thierry@usa.net
' * Date : 02/09/1999
' * Time : 14:37
' **************************
' * Comments : FTP Access through a Class Module for VB5/6
' *
' *
' **************************
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "cFTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'
' CodeGuru FTP Class
'
' Chris Eastwood July 1999
'
' This class wraps the functionality of the Win32 WinInet.DLL
'
' It could easily be expanded to provide HTTP/Gopher and other internet
' standard file protocols.
'
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private 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 Const ERROR_NO_MORE_FILES = 18
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
(ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" _
(ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _
lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" _
(ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
' Initializes an application's use of the Win32 Internet functions
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
' Use registry access settings.
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_INVALID_PORT_NUMB
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H1
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _
ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Const ERROR_INTERNET_EXTENDED_ER
Private Declare Function InternetGetLastResponseInf
lpdwError As Long, _
ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Boolean
' Type of service to access.
Private Const INTERNET_SERVICE_FTP = 1
'private Const INTERNET_SERVICE_GOPHER = 2
'private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECT
Private Const INTERNET_FLAG_MULTIPART = &H200000
Private Declare Function FtpOpenFile Lib "wininet.dll" Alias _
"FtpOpenFileA" (ByVal hFtpSession As Long, _
ByVal sFileName As String, ByVal lAccess As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function FtpDeleteFile Lib "wininet.dll" _
Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
ByVal lpszFileName As String) As Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias _
"FtpRenameFileA" (ByVal hFtpSession As Long, _
ByVal sExistingName As String, _
ByVal sNewName As String) As Boolean
' Closes a single Internet handle or a subtree of Internet handles.
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
'
' Our Defined Errors
'
Public Enum errFtpErrors
errCannotConnect = vbObjectError + 2001
errNoDirChange = vbObjectError + 2002
errCannotRename = vbObjectError + 2003
errCannotDelete = vbObjectError + 2004
errNotConnectedToSite = vbObjectError + 2005
errGetFileError = vbObjectError + 2006
errInvalidProperty = vbObjectError + 2007
errFatal = vbObjectError + 2008
End Enum
'
' File Transfer types
'
Public Enum FileTransferType
ftAscii = FTP_TRANSFER_TYPE_ASCII
ftBinary = FTP_TRANSFER_TYPE_BINARY
End Enum
'
' Error messages
'
Private Const ERRCHANGEDIRSTR As String = "Cannot Change Directory to %s. It either doesn't exist, or is protected"
Private Const ERRCONNECTERROR As String = "Cannot Connect to %s using User and Password Parameters"
Private Const ERRNOCONNECTION As String = "Not Connected to FTP Site"
Private Const ERRNODOWNLOAD As String = "Couldn't Get File %s from Server"
Private Const ERRNORENAME As String = "Couldn't Rename File %s"
Private Const ERRNODELETE As String = "Couldn't Delete File %s from Server"
Private Const ERRALREADYCONNECTED As String = "You cannot change this property while connected to an FTP server"
Private Const ERRFATALERROR As String = "Cannot get Connection to WinInet.dll !"
'
' Session Identifier to Windows
'
Private Const SESSION As String = "CGFtp Instance"
'
' Our INET handle
'
Private mlINetHandle As Long
'
' Our FTP Connection Handle
'
Private mlConnection As Long
'
' Standard FTP properties for this class
'
Private msHostAddress As String
Private msUser As String
Private msPassword As String
Private msDirectory As String
Private Sub Class_Initialize()
'
' Create Internet session handle
'
mlINetHandle = InternetOpen(SESSION, INTERNET_OPEN_TYPE_DIRECT,
If mlINetHandle = 0 Then
mlConnection = 0
Err.Raise errFatal, "CGFTP::Class_Initialise", ERRFATALERROR
End If
mlConnection = 0
End Sub
Private Sub Class_Terminate()
'
' Kill off any connection
'
If mlConnection <> 0 Then
InternetCloseHandle mlConnection
End If
'
' Kill off API Handle
'
If mlINetHandle <> 0 Then
InternetCloseHandle mlINetHandle
End If
mlConnection = 0
mlINetHandle = 0
End Sub
Public Property Let Host(ByVal sHostName As String)
Attribute Host.VB_Description = "Get/Set the Host Name of the FTP server"
'
' Set the Host Name - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "ACNFTP:Host_Let", ERRALREADYCONNECTED
End If
msHostAddress = sHostName
End Property
Public Property Get Host() As String
'
' Get Host Name
'
Host = msHostAddress
End Property
Public Property Let User(ByVal sUserName As String)
Attribute User.VB_Description = "Get/Set the login user id for the FTP server"
'
' Set the user - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "CGFTP::User_Let", ERRALREADYCONNECTED
End If
msUser = sUserName
End Property
Public Property Get User() As String
'
' Get the user information
'
User = msUser
End Property
Public Property Let Password(ByVal sPassword As String)
Attribute Password.VB_Description = "Get/Set the password for logging into the FTP server"
'
' Set the password - only if not connected
'
If mlConnection <> 0 Then
Err.Raise errInvalidProperty, "CGFTP::Password_Let", ERRALREADYCONNECTED
End If
msPassword = sPassword
End Property
Public Property Get Password() As String
'
' Get the password
'
Password = msPassword
End Property
Public Property Get Directory() As String
Attribute Directory.VB_Description = "Change Remote Directory"
'
' Get the directory
'
Directory = msDirectory
End Property
Public Property Let Directory(ByVal sDirectory As String)
'
' Set the directory - only if connected
'
On Error GoTo vbErrorHandler
Dim sError As String
If Not (mlConnection = 0) Then
RemoteChDir sDirectory
msDirectory = sDirectory
Else
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::Directory_Let", ERRNOCONNECTION
End If
Exit Property
vbErrorHandler:
Err.Raise errNoDirChange, "CGFTP::Directory[Let]", Err.Description
End Property
Public Property Get Connected() As Boolean
Attribute Connected.VB_Description = "Are we connected to an FTP server ? (True/False)"
'
' Are we connected to an FTP Server ? T/F
'
Connected = (mlConnection <> 0)
End Property
Public Function Connect(Optional Host As String, _
Optional User As String, _
Optional Password As String) As Boolean
Attribute Connect.VB_Description = "Connect to the FTP Server using the passed parameters (if any)"
'
' Connect to the FTP server
'
On Error GoTo vbErrorHandler
Dim sError As String
'
' If we already have a connection then raise an error
'
If mlConnection <> 0 Then
On Error GoTo 0
Err.Raise errInvalidProperty, "CGFTP::Connect", "You are already connected to FTP Server " & msHostAddress
Exit Function
End If
'
' Overwrite any existing properties if they were supplied in the
' arguments to this method
'
If Len(Host) > 0 Then
msHostAddress = Host
End If
If Len(User) > 0 Then
msUser = User
End If
If Len(Password) > 0 Then
msPassword = Password
End If
'
' Connect !
'
If Len(msHostAddress) = 0 Then
Err.Raise errInvalidProperty, "CGFTP::Connect", "No Host Address Specified!"
End If
mlConnection = InternetConnect(mlINetHand
msUser, msPassword, INTERNET_SERVICE_FTP, 0, 0)
'
' Check for connection errors
'
If mlConnection = 0 Then
sError = Replace(ERRCONNECTERROR, "%s", msHostAddress)
On Error GoTo 0
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotConnect, "CGFTP::Connect", sError
End If
Connect = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::Connect", Err.Description
End Function
Public Function Disconnect() As Boolean
Attribute Disconnect.VB_Description = "Disconnect from the remote FTP server"
'
' Disconnect, only if connected !
'
If mlConnection <> 0 Then
InternetCloseHandle mlConnection
mlConnection = 0
Else
Err.Raise errNotConnectedToSite, "CGFTP::Disconnect", ERRNOCONNECTION
End If
msHostAddress = ""
msUser = ""
msPassword = ""
msDirectory = ""
End Function
Public Function GetDirectoryList(Optional Directory As String, Optional FilterString As String) As ADOR.Recordset
Attribute GetDirectoryList.VB_Descri
'
' Returns a Disconnected record set for the
' directory and filterstring
'
' eg. "/NTFFiles", "*.ntf"
'
On Error GoTo vbErrorHandler
Dim oFileColl As Collection
Dim lFind As Long
Dim lLastError As Long
Dim lPtr As Long
Dim pData As WIN32_FIND_DATA
Dim sFilter As String
Dim lError As Long
Dim bRet As Boolean
Dim sItemName As String
Dim oRS As ADOR.Recordset
'
' Check if already connected, else raise an error
'
If mlConnection = 0 Then
Err.Raise errNotConnectedToSite, "CGFTP::GetDirectoryList", ERRNOCONNECTION
End If
'
' Build the disconnected recordset structure.
'
Set oRS = New ADOR.Recordset
oRS.CursorLocation = adUseClient
oRS.Fields.Append "Name", adBSTR
oRS.Open
'
' Change directory if required
'
If Len(Directory) > 0 Then
RemoteChDir Directory
End If
pData.cFileName = String$(MAX_PATH, vbNullChar)
If Len(FilterString) > 0 Then
sFilter = FilterString
Else
sFilter = "*.*"
End If
'
' Get the first file in the directory
'
lFind = FtpFindFirstFile(mlConnect
lLastError = Err.LastDllError
'
' If no files, then return an empty recordset.
'
If lFind = 0 Then
If lLastError = ERROR_NO_MORE_FILES Then
' Empty directory
Set GetDirectoryList = oRS
Exit Function
Else
On Error GoTo 0
Err.Raise lLastError, "cFTP::GetDirectoryList", "Error looking at directory " & Directory & "\" & FilterString
End If
Exit Function
End If
'
' Add the first found file into the recordset
'
sItemName = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar, vbBinaryCompare) - 1)
oRS.AddNew "Name", sItemName
'
' Get the rest of the files in the list
'
Do
pData.cFileName = String(MAX_PATH, vbNullChar)
bRet = InternetFindNextFile(lFind
If Not (bRet) Then
lLastError = Err.LastDllError
If lLastError = ERROR_NO_MORE_FILES Then
Exit Do
Else
InternetCloseHandle lFind
On Error GoTo 0
Err.Raise lLastError, "cFTP::GetDirectoryList", "Error looking at directory " & Directory & "\" & FilterString
Exit Function
End If
Else
sItemName = Left$(pData.cFileName, InStr(1, pData.cFileName, vbNullChar, vbBinaryCompare) - 1)
oRS.AddNew "Name", sItemName
End If
Loop
'
' Close the 'find' handle
'
InternetCloseHandle lFind
On Error Resume Next
oRS.MoveFirst
Err.Clear
On Error GoTo 0
Set GetDirectoryList = oRS
Exit Function
vbErrorHandler:
'
' Tidy up & raise an error
'
If lFind <> 0 Then
InternetCloseHandle lFind
End If
Set GetDirectoryList = oRS
Err.Raise Err.Number, "cFTP::GetDirectoryList", Err.Description
End Function
Public Function GetFile(ByVal ServerFileAndPath As String, ByVal DestinationFileAndPath As String, Optional TransferType As FileTransferType = ftAscii) As Boolean
Attribute GetFile.VB_Description = "Download a file from the FTP Server"
'
' Get the specified file to the desired location using the specified
' file transfer type
'
Dim bRet As Boolean
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String
Dim sTemp As String
Dim lPos As Long
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::GetFile", ERRNOCONNECTION
End If
'
' Get the file
'
bRet = FtpGetFile(mlConnection, ServerFileAndPath, DestinationFileAndPath, False, INTERNET_FLAG_RELOAD, TransferType, 0)
If bRet = False Then
sError = ERRNODOWNLOAD
sError = Replace(sError, "%s", ServerFileAndPath)
On Error GoTo 0
GetFile = False
Err.Raise errGetFileError, "CGFTP::GetFile", sError
End If
GetFile = True
Exit Function
vbErrorHandler:
GetFile = False
Err.Raise errGetFileError, "cFTP::GetFile", Err.Description
End Function
Public Function PutFile(ByVal LocalFileAndPath As String, ByVal ServerFileAndPath As String, Optional TransferType As FileTransferType) As Boolean
Attribute PutFile.VB_Description = "Upload a file to the FTP server"
Dim bRet As Boolean
Dim sFileRemote As String
Dim sDirRemote As String
Dim sFileLocal As String
Dim sTemp As String
Dim lPos As Long
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error!
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::PutFile", ERRNOCONNECTION
End If
bRet = FtpPutFile(mlConnection, LocalFileAndPath, ServerFileAndPath, _
TransferType, 0)
If bRet = False Then
sError = ERRNODOWNLOAD
sError = Replace(sError, "%s", ServerFileAndPath)
On Error GoTo 0
PutFile = False
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotRename, "CGFTP::PutFile", sError
End If
PutFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::PutFile", Err.Description
End Function
Public Function RenameFile(ByVal ExistingName As String, ByVal NewName As String) As Boolean
Attribute RenameFile.VB_Description = "Rename a file on the FTP server"
Dim bRet As Boolean
Dim sError As String
On Error GoTo vbErrorHandler
'
' If not connected, raise an error
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::RenameFile", ERRNOCONNECTION
End If
bRet = FtpRenameFile(mlConnection
'
' Raise an error if we couldn't rename the file (most likely that
' a file with the new name already exists
'
If bRet = False Then
sError = ERRNORENAME
sError = Replace(sError, "%s", ExistingName)
On Error GoTo 0
RenameFile = False
sError = sError & vbCrLf & GetINETErrorMsg(Err.LastDl
Err.Raise errCannotRename, "CGFTP::RenameFile", sError
End If
RenameFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::RenameFile", Err.Description
End Function
Public Function DeleteFile(ByVal ExistingName As String) As Boolean
Attribute DeleteFile.VB_Description = "Delete a file from the FTP server"
Dim bRet As Boolean
Dim sError As String
On Error GoTo vbErrorHandler
'
' Check for a connection
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::DeleteFile", ERRNOCONNECTION
End If
bRet = FtpDeleteFile(mlConnection
'
' Raise an error if the file couldn't be deleted
'
If bRet = False Then
sError = ERRNODELETE
sError = Replace(sError, "%s", ExistingName)
On Error GoTo 0
Err.Raise errCannotDelete, "CGFTP::DeleteFile", sError
End If
DeleteFile = True
Exit Function
vbErrorHandler:
Err.Raise Err.Number, "cFTP::DeleteFile", Err.Description
End Function
Private Sub RemoteChDir(ByVal sDir As String)
On Error GoTo vbErrorHandler
'
' Remote Change Directory Command through WININET
'
Dim sPathFromRoot As String
Dim bRet As Boolean
Dim sError As String
'
' Needs standard Unix Convention
'
sDir = Replace(sDir, "\", "/")
'
' Check for a connection
'
If mlConnection = 0 Then
On Error GoTo 0
Err.Raise errNotConnectedToSite, "CGFTP::RemoteChDir", ERRNOCONNECTION
Exit Sub
End If
If Len(sDir) = 0 Then
Exit Sub
Else
sPathFromRoot = sDir
If Len(sPathFromRoot) = 0 Then
sPathFromRoot = "/"
End If
bRet = FtpSetCurrentDirectory(mlC
'
' If we couldn't change directory - raise an error
'
If bRet = False Then
sError = ERRCHANGEDIRSTR
sError = Replace(sError, "%s", sDir)
On Error GoTo 0
Err.Raise errNoDirChange, "CGFTP::ChangeDirectory", sError
End If
End If
Exit Sub
vbErrorHandler:
Err.Raise Err.Number, "cFTP::RemoteChDir", Err.Description
End Sub
Private Function GetINETErrorMsg(ByVal ErrNum As Long) As String
Dim lError As Long
Dim lLen As Long
Dim sBuffer As String
'
' Get Extra Info from the WinInet.DLL
'
If ErrNum = ERROR_INTERNET_EXTENDED_ER
'
' Get Message Size and Number
'
InternetGetLastResponseInf
sBuffer = String$(lLen + 1, vbNullChar)
'
' Get Message
'
InternetGetLastResponseInf
GetINETErrorMsg = vbCrLf & sBuffer
End If
End Function
ASKER
Waty,
I've tried your example too.
The problem is if I passed the invalid IP address to your class, the InternetConnect(mlINetHand
Am I right?
What I really want is how to turn on the time out capability if I use wininet.dll on VB.
There is a property called Requesttimeout on the msinet.ocx which will unblock my task if the time out has been expired. I would like to do the same thing if I use wininet.dll. How can I do that.
I've tried your example too.
The problem is if I passed the invalid IP address to your class, the InternetConnect(mlINetHand
Am I right?
What I really want is how to turn on the time out capability if I use wininet.dll on VB.
There is a property called Requesttimeout on the msinet.ocx which will unblock my task if the time out has been expired. I would like to do the same thing if I use wininet.dll. How can I do that.
There is somewhere a timeout to setup....
I will try to take a look to that...
I will try to take a look to that...
use,
Private Declare Function InternetSetOption Lib "wininet.dll" Alias "InternetSetOptionA" _
(ByVal hInternet As Long, _
ByVal dwOption As Long, _
lpBuffer As Long, _
ByVal dwBufferLength As Long) As Boolean
Private Const INTERNET_OPTION_CONNECT_TI
Private m_lConnectTimeOut As Long 'in milliseconds
Private m_hOpen As Long 'hanlde returned by InternetOpen function
Private bSetOption As Boolean
bSetOption = InternetSetOption(m_hOpen,
Private Declare Function InternetSetOption Lib "wininet.dll" Alias "InternetSetOptionA" _
(ByVal hInternet As Long, _
ByVal dwOption As Long, _
lpBuffer As Long, _
ByVal dwBufferLength As Long) As Boolean
Private Const INTERNET_OPTION_CONNECT_TI
Private m_lConnectTimeOut As Long 'in milliseconds
Private m_hOpen As Long 'hanlde returned by InternetOpen function
Private bSetOption As Boolean
bSetOption = InternetSetOption(m_hOpen,
ASKER
Sorry manojamin
It doesn't work.
The function (internetsetoptions) itself returned true but Internetconnect function still blocks for over 1 min
So, any more idea?
Waty?
It doesn't work.
The function (internetsetoptions) itself returned true but Internetconnect function still blocks for over 1 min
So, any more idea?
Waty?
ASKER
Waty,
I just noticed your picture is on EE.
8->
I just noticed your picture is on EE.
8->
If you want, you can ping the host before you try to connect using an ICMP Ping Packet. Stick the following code in a module, then you can this:
If IsHostAlive("gateway") = True Then
'Do your FTP HERE
Else
'HOST IS NOT VALID OR IS NOT ONLINE
End If
Cheers!
THE CODE:
Option Explicit
Private Const WS32_NOT_ENOUGH_SOCKETS = -4
Private Const WS32_NOT_SUPPORTED = -3
Private Const WS32_NOT_RESPONDING = -2
Private Const IP_STATUS_BASE = 11000
Private Const IP_SUCCESS = 0
Private Const IP_BUF_TOO_SMALL = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Private Const IP_NO_RESOURCES = (11000 + 6)
Private Const IP_BAD_OPTION = (11000 + 7)
Private Const IP_HW_ERROR = (11000 + 8)
Private Const IP_PACKET_TOO_BIG = (11000 + 9)
Private Const IP_REQ_TIMED_OUT = (11000 + 10)
Private Const IP_BAD_REQ = (11000 + 11)
Private Const IP_BAD_ROUTE = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Private Const IP_PARAM_PROBLEM = (11000 + 15)
Private Const IP_SOURCE_QUENCH = (11000 + 16)
Private Const IP_OPTION_TOO_BIG = (11000 + 17)
Private Const IP_BAD_DESTINATION = (11000 + 18)
Private Const IP_ADDR_DELETED = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Private Const IP_MTU_CHANGE = (11000 + 21)
Private Const IP_UNLOAD = (11000 + 22)
Private Const IP_ADDR_ADDED = (11000 + 23)
Private Const IP_GENERAL_FAILURE = (11000 + 50)
Private Const MAX_IP_STATUS = 11000 + 50
Private Const IP_PENDING = (11000 + 255)
Private Const PING_TIMEOUT = 200
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
Private Type ICMP_OPTIONS
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Private Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
Public Type LHOSTENTRY
hName As String
hAddress As String
hStatus As String
End Type
Private Type WSADATA
wversion As Integer
wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End Type
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal IcmpHandle As Long) As Long
Private Declare Function IcmpSendEcho Lib "icmp.dll" _
(ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, _
ByVal RequestData As String, ByVal RequestSize As Integer, _
ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, ByVal Timeout As Long) As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" _
(ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" _
(ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal szHost As String) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, _
ByVal hpvSource As Long, ByVal cbCopy As Long)
Private G_lhEntry As LHOSTENTRY
Public Function GetHostInfo(lHost As String) As LHOSTENTRY
Dim WSAD As WSADATA
Dim rVal As Long
Dim hostname As String * 256
Dim hostent_addr As Long
Dim host As HOSTENT
Dim hostip_addr As Long
Dim temp_ip_address() As Byte
Dim iVal As Integer
Dim ip_address As String
rVal = WSAStartup(WS_VERSION_REQD
If rVal <> 0 Then
GetHostInfo.hStatus = WS32_NOT_RESPONDING
Exit Function
End If
If CvtLoByte(WSAD.wversion) < WS_VERSION_MAJOR Or _
(CvtLoByte(WSAD.wversion) = WS_VERSION_MAJOR And _
CvtHiByte(WSAD.wversion) < WS_VERSION_MINOR) Then
GetHostInfo.hStatus = WS32_NOT_SUPPORTED
WSACleanup
Exit Function
End If
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
GetHostInfo.hStatus = WS32_NOT_ENOUGH_SOCKETS
WSACleanup
Exit Function
End If
GetHostInfo.hStatus = SOCKET_ERROR
GetHostInfo.hName = Trim$(LCase$(lHost))
hostname = Left$(lHost + String(256, Chr$(0)), 256)
hostent_addr = gethostbyname(hostname)
If hostent_addr = 0 Then
WSACleanup
Exit Function
End If
RtlMoveMemory host, hostent_addr, LenB(host)
RtlMoveMemory hostip_addr, host.hAddrList, 4
ReDim temp_ip_address(1 To host.hLength)
RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
For iVal = 1 To host.hLength
ip_address = ip_address & temp_ip_address(iVal) & "."
Next
ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
GetHostInfo.hAddress = ip_address
GetHostInfo.hStatus = IP_SUCCESS
WSACleanup
End Function
Public Function GetPingMsg(status As Long) As String
Dim msg As String
Select Case status
Case WS32_NOT_ENOUGH_SOCKETS: msg = "Not enough sockets available"
Case WS32_NOT_SUPPORTED: msg = "Socket version not supported"
Case WS32_NOT_RESPONDING: msg = "Winsock 32 not responding"
Case IP_SUCCESS: msg = "OK"
Case IP_BUF_TOO_SMALL: msg = "IP buf too small"
Case IP_DEST_NET_UNREACHABLE: msg = "Destination network unreachable"
Case IP_DEST_HOST_UNREACHABLE: msg = "Destination host unreachable"
Case IP_DEST_PROT_UNREACHABLE: msg = "Destination protocol unreachable"
Case IP_DEST_PORT_UNREACHABLE: msg = "Destination port unreachable"
Case IP_NO_RESOURCES: msg = "IP no resources"
Case IP_BAD_OPTION: msg = "IP bad option"
Case IP_HW_ERROR: msg = "IP hardware error"
Case IP_PACKET_TOO_BIG: msg = "IP packet too big"
Case IP_REQ_TIMED_OUT: msg = "Request timed out"
Case IP_BAD_REQ: msg = "Bad request"
Case IP_BAD_ROUTE: msg = "Bad route"
Case IP_TTL_EXPIRED_TRANSIT: msg = "IP TTL expired transit"
Case IP_TTL_EXPIRED_REASSEM: msg = "IP TTL expired reassem"
Case IP_PARAM_PROBLEM: msg = "IP param problem"
Case IP_SOURCE_QUENCH: msg = "IP source quench"
Case IP_OPTION_TOO_BIG: msg = "IP option too big"
Case IP_BAD_DESTINATION: msg = "IP bad destination"
Case IP_ADDR_DELETED: msg = "IP address deleted"
Case IP_SPEC_MTU_CHANGE: msg = "IP spec mtu change"
Case IP_MTU_CHANGE: msg = "IP mtu change"
Case IP_UNLOAD: msg = "IP unload"
Case IP_ADDR_ADDED: msg = "IP address added"
Case IP_GENERAL_FAILURE: msg = "IP general failure"
Case IP_PENDING: msg = "IP pending"
Case PING_TIMEOUT: msg = "Ping timeout"
Case Else: msg = "Unknown message returned"
End Select
GetPingMsg = msg
End Function
Private Function CvtHiByte(ByVal wParam As Integer)
CvtHiByte = wParam \ &H100 And &HFF&
End Function
Private Function CvtLoByte(ByVal wParam As Integer)
CvtLoByte = wParam And &HFF&
End Function
Public Function IsHostAlive(lHost As String) As Boolean
Dim ECHO As ICMP_ECHO_REPLY
Dim pos As Integer
IsHostAlive = False
SysPing lHost, ECHO
If ECHO.status = IP_SUCCESS Then IsHostAlive = True
End Function
Public Function GetPingString(lHost As String) As String
Dim ECHO As ICMP_ECHO_REPLY
Dim pos As Integer
SysPing lHost, ECHO
If ECHO.status = IP_SUCCESS Then
GetPingString = "Reply from " & G_lhEntry.hAddress & ": bytes=" & Trim$(CStr(ECHO.DataSize))
& " time=" & Trim$(CStr(ECHO.RoundTripT
& Trim$(CStr(ECHO.Options.Tt
Else
GetPingString = GetPingMsg(ECHO.status)
End If
End Function
Private Function SysPing(lhostname As String, ECHO As ICMP_ECHO_REPLY, Optional EchoString As String) As Long
Dim WSAD As WSADATA
Dim hPort As Long
Dim dwAddr As Long
Dim iOpt As Long
Dim rVal As Long
Dim eString As String
Dim szLoByte As String
Dim szHiByte As String
Dim szBuf As String
eString = "ABCDEFGHIJKLMNOPQRSTUVWXY
G_lhEntry = GetHostInfo(lhostname)
If Not G_lhEntry.hStatus = 0 Then
SysPing = IP_BAD_DESTINATION
ECHO.status = IP_BAD_DESTINATION
Exit Function
End If
dwAddr = CvtIPAddrClng(G_lhEntry.hA
If dwAddr = 0 Then
SysPing = IP_BAD_DESTINATION
ECHO.status = IP_BAD_DESTINATION
Exit Function
End If
rVal = WSAStartup(WS_VERSION_REQD
If rVal <> 0 Then
SysPing = WS32_NOT_RESPONDING
ECHO.status = WS32_NOT_RESPONDING
Exit Function
End If
If CvtLoByte(WSAD.wversion) < WS_VERSION_MAJOR Or _
(CvtLoByte(WSAD.wversion) = WS_VERSION_MAJOR And _
CvtHiByte(WSAD.wversion) < WS_VERSION_MINOR) Then
SysPing = WS32_NOT_SUPPORTED
ECHO.status = WS32_NOT_SUPPORTED
WSACleanup
Exit Function
End If
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
SysPing = WS32_NOT_ENOUGH_SOCKETS
ECHO.status = WS32_NOT_ENOUGH_SOCKETS
WSACleanup
Exit Function
End If
hPort = IcmpCreateFile()
rVal = IcmpSendEcho(hPort, dwAddr, eString, Len(eString), 0, ECHO, Len(ECHO), PING_TIMEOUT)
If rVal = 1 Then
SysPing = IP_SUCCESS
Else
If ECHO.status = 0 Then ECHO.status = IP_DEST_NET_UNREACHABLE
SysPing = ECHO.status * -1
End If
IcmpCloseHandle hPort
WSACleanup
End Function
Private Function CvtIPAddrClng(ByVal tmp As String) As Long
Dim iVal As Integer
Dim IpWord(4) As String
CvtIPAddrClng = 0: iVal = 0
While InStr(tmp, ".") > 0
iVal = iVal + 1
IpWord(iVal) = Mid(tmp, 1, InStr(tmp, ".") - 1)
tmp = Mid(tmp, InStr(tmp, ".") + 1)
Wend
iVal = iVal + 1
IpWord(iVal) = tmp
If iVal <> 4 Then Exit Function
CvtIPAddrClng = Val("&H" & Right("00" & Hex(IpWord(4)), 2) & _
Right("00" & Hex(IpWord(3)), 2) & Right("00" & Hex(IpWord(2)), 2) & _
Right("00" & Hex(IpWord(1)), 2))
End Function
If IsHostAlive("gateway") = True Then
'Do your FTP HERE
Else
'HOST IS NOT VALID OR IS NOT ONLINE
End If
Cheers!
THE CODE:
Option Explicit
Private Const WS32_NOT_ENOUGH_SOCKETS = -4
Private Const WS32_NOT_SUPPORTED = -3
Private Const WS32_NOT_RESPONDING = -2
Private Const IP_STATUS_BASE = 11000
Private Const IP_SUCCESS = 0
Private Const IP_BUF_TOO_SMALL = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Private Const IP_NO_RESOURCES = (11000 + 6)
Private Const IP_BAD_OPTION = (11000 + 7)
Private Const IP_HW_ERROR = (11000 + 8)
Private Const IP_PACKET_TOO_BIG = (11000 + 9)
Private Const IP_REQ_TIMED_OUT = (11000 + 10)
Private Const IP_BAD_REQ = (11000 + 11)
Private Const IP_BAD_ROUTE = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Private Const IP_PARAM_PROBLEM = (11000 + 15)
Private Const IP_SOURCE_QUENCH = (11000 + 16)
Private Const IP_OPTION_TOO_BIG = (11000 + 17)
Private Const IP_BAD_DESTINATION = (11000 + 18)
Private Const IP_ADDR_DELETED = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Private Const IP_MTU_CHANGE = (11000 + 21)
Private Const IP_UNLOAD = (11000 + 22)
Private Const IP_ADDR_ADDED = (11000 + 23)
Private Const IP_GENERAL_FAILURE = (11000 + 50)
Private Const MAX_IP_STATUS = 11000 + 50
Private Const IP_PENDING = (11000 + 255)
Private Const PING_TIMEOUT = 200
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
Private Type ICMP_OPTIONS
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Private Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
Public Type LHOSTENTRY
hName As String
hAddress As String
hStatus As String
End Type
Private Type WSADATA
wversion As Integer
wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End Type
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal IcmpHandle As Long) As Long
Private Declare Function IcmpSendEcho Lib "icmp.dll" _
(ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, _
ByVal RequestData As String, ByVal RequestSize As Integer, _
ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, ByVal Timeout As Long) As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" _
(ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" _
(ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal szHost As String) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, _
ByVal hpvSource As Long, ByVal cbCopy As Long)
Private G_lhEntry As LHOSTENTRY
Public Function GetHostInfo(lHost As String) As LHOSTENTRY
Dim WSAD As WSADATA
Dim rVal As Long
Dim hostname As String * 256
Dim hostent_addr As Long
Dim host As HOSTENT
Dim hostip_addr As Long
Dim temp_ip_address() As Byte
Dim iVal As Integer
Dim ip_address As String
rVal = WSAStartup(WS_VERSION_REQD
If rVal <> 0 Then
GetHostInfo.hStatus = WS32_NOT_RESPONDING
Exit Function
End If
If CvtLoByte(WSAD.wversion) < WS_VERSION_MAJOR Or _
(CvtLoByte(WSAD.wversion) = WS_VERSION_MAJOR And _
CvtHiByte(WSAD.wversion) < WS_VERSION_MINOR) Then
GetHostInfo.hStatus = WS32_NOT_SUPPORTED
WSACleanup
Exit Function
End If
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
GetHostInfo.hStatus = WS32_NOT_ENOUGH_SOCKETS
WSACleanup
Exit Function
End If
GetHostInfo.hStatus = SOCKET_ERROR
GetHostInfo.hName = Trim$(LCase$(lHost))
hostname = Left$(lHost + String(256, Chr$(0)), 256)
hostent_addr = gethostbyname(hostname)
If hostent_addr = 0 Then
WSACleanup
Exit Function
End If
RtlMoveMemory host, hostent_addr, LenB(host)
RtlMoveMemory hostip_addr, host.hAddrList, 4
ReDim temp_ip_address(1 To host.hLength)
RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
For iVal = 1 To host.hLength
ip_address = ip_address & temp_ip_address(iVal) & "."
Next
ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
GetHostInfo.hAddress = ip_address
GetHostInfo.hStatus = IP_SUCCESS
WSACleanup
End Function
Public Function GetPingMsg(status As Long) As String
Dim msg As String
Select Case status
Case WS32_NOT_ENOUGH_SOCKETS: msg = "Not enough sockets available"
Case WS32_NOT_SUPPORTED: msg = "Socket version not supported"
Case WS32_NOT_RESPONDING: msg = "Winsock 32 not responding"
Case IP_SUCCESS: msg = "OK"
Case IP_BUF_TOO_SMALL: msg = "IP buf too small"
Case IP_DEST_NET_UNREACHABLE: msg = "Destination network unreachable"
Case IP_DEST_HOST_UNREACHABLE: msg = "Destination host unreachable"
Case IP_DEST_PROT_UNREACHABLE: msg = "Destination protocol unreachable"
Case IP_DEST_PORT_UNREACHABLE: msg = "Destination port unreachable"
Case IP_NO_RESOURCES: msg = "IP no resources"
Case IP_BAD_OPTION: msg = "IP bad option"
Case IP_HW_ERROR: msg = "IP hardware error"
Case IP_PACKET_TOO_BIG: msg = "IP packet too big"
Case IP_REQ_TIMED_OUT: msg = "Request timed out"
Case IP_BAD_REQ: msg = "Bad request"
Case IP_BAD_ROUTE: msg = "Bad route"
Case IP_TTL_EXPIRED_TRANSIT: msg = "IP TTL expired transit"
Case IP_TTL_EXPIRED_REASSEM: msg = "IP TTL expired reassem"
Case IP_PARAM_PROBLEM: msg = "IP param problem"
Case IP_SOURCE_QUENCH: msg = "IP source quench"
Case IP_OPTION_TOO_BIG: msg = "IP option too big"
Case IP_BAD_DESTINATION: msg = "IP bad destination"
Case IP_ADDR_DELETED: msg = "IP address deleted"
Case IP_SPEC_MTU_CHANGE: msg = "IP spec mtu change"
Case IP_MTU_CHANGE: msg = "IP mtu change"
Case IP_UNLOAD: msg = "IP unload"
Case IP_ADDR_ADDED: msg = "IP address added"
Case IP_GENERAL_FAILURE: msg = "IP general failure"
Case IP_PENDING: msg = "IP pending"
Case PING_TIMEOUT: msg = "Ping timeout"
Case Else: msg = "Unknown message returned"
End Select
GetPingMsg = msg
End Function
Private Function CvtHiByte(ByVal wParam As Integer)
CvtHiByte = wParam \ &H100 And &HFF&
End Function
Private Function CvtLoByte(ByVal wParam As Integer)
CvtLoByte = wParam And &HFF&
End Function
Public Function IsHostAlive(lHost As String) As Boolean
Dim ECHO As ICMP_ECHO_REPLY
Dim pos As Integer
IsHostAlive = False
SysPing lHost, ECHO
If ECHO.status = IP_SUCCESS Then IsHostAlive = True
End Function
Public Function GetPingString(lHost As String) As String
Dim ECHO As ICMP_ECHO_REPLY
Dim pos As Integer
SysPing lHost, ECHO
If ECHO.status = IP_SUCCESS Then
GetPingString = "Reply from " & G_lhEntry.hAddress & ": bytes=" & Trim$(CStr(ECHO.DataSize))
& " time=" & Trim$(CStr(ECHO.RoundTripT
& Trim$(CStr(ECHO.Options.Tt
Else
GetPingString = GetPingMsg(ECHO.status)
End If
End Function
Private Function SysPing(lhostname As String, ECHO As ICMP_ECHO_REPLY, Optional EchoString As String) As Long
Dim WSAD As WSADATA
Dim hPort As Long
Dim dwAddr As Long
Dim iOpt As Long
Dim rVal As Long
Dim eString As String
Dim szLoByte As String
Dim szHiByte As String
Dim szBuf As String
eString = "ABCDEFGHIJKLMNOPQRSTUVWXY
G_lhEntry = GetHostInfo(lhostname)
If Not G_lhEntry.hStatus = 0 Then
SysPing = IP_BAD_DESTINATION
ECHO.status = IP_BAD_DESTINATION
Exit Function
End If
dwAddr = CvtIPAddrClng(G_lhEntry.hA
If dwAddr = 0 Then
SysPing = IP_BAD_DESTINATION
ECHO.status = IP_BAD_DESTINATION
Exit Function
End If
rVal = WSAStartup(WS_VERSION_REQD
If rVal <> 0 Then
SysPing = WS32_NOT_RESPONDING
ECHO.status = WS32_NOT_RESPONDING
Exit Function
End If
If CvtLoByte(WSAD.wversion) < WS_VERSION_MAJOR Or _
(CvtLoByte(WSAD.wversion) = WS_VERSION_MAJOR And _
CvtHiByte(WSAD.wversion) < WS_VERSION_MINOR) Then
SysPing = WS32_NOT_SUPPORTED
ECHO.status = WS32_NOT_SUPPORTED
WSACleanup
Exit Function
End If
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
SysPing = WS32_NOT_ENOUGH_SOCKETS
ECHO.status = WS32_NOT_ENOUGH_SOCKETS
WSACleanup
Exit Function
End If
hPort = IcmpCreateFile()
rVal = IcmpSendEcho(hPort, dwAddr, eString, Len(eString), 0, ECHO, Len(ECHO), PING_TIMEOUT)
If rVal = 1 Then
SysPing = IP_SUCCESS
Else
If ECHO.status = 0 Then ECHO.status = IP_DEST_NET_UNREACHABLE
SysPing = ECHO.status * -1
End If
IcmpCloseHandle hPort
WSACleanup
End Function
Private Function CvtIPAddrClng(ByVal tmp As String) As Long
Dim iVal As Integer
Dim IpWord(4) As String
CvtIPAddrClng = 0: iVal = 0
While InStr(tmp, ".") > 0
iVal = iVal + 1
IpWord(iVal) = Mid(tmp, 1, InStr(tmp, ".") - 1)
tmp = Mid(tmp, InStr(tmp, ".") + 1)
Wend
iVal = iVal + 1
IpWord(iVal) = tmp
If iVal <> 4 Then Exit Function
CvtIPAddrClng = Val("&H" & Right("00" & Hex(IpWord(4)), 2) & _
Right("00" & Hex(IpWord(3)), 2) & Right("00" & Hex(IpWord(2)), 2) & _
Right("00" & Hex(IpWord(1)), 2))
End Function
ASKER
mcrider,
please submit as answer. I don't see any button that I can accept your comment as answer.
Waty & manojamin
Thanks for spending time to solve by problem.
8->
please submit as answer. I don't see any button that I can accept your comment as answer.
Waty & manojamin
Thanks for spending time to solve by problem.
8->
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
' * Programmer Name : Oleg Gdalevich
' * Web Site : http://www.vbip.com/wininet/wininet_connection_01.asp
' * E-Mail : webmaster@vbip.com
' * Date : 03/12/1999
' * Time : 10:22
' **************************
' * Comments : Class CWinInetConnection
' *
' *
' **************************
'*************************
'WinInet API declarations
'*************************
'Flags for InternetGetConnectedState and Ex
Private Const INTERNET_CONNECTION_MODEM = &H1
Private Const INTERNET_CONNECTION_LAN = &H2
Private Const INTERNET_CONNECTION_PROXY = &H4
Private Const INTERNET_RAS_INSTALLED = &H10
Private Const INTERNET_CONNECTION_OFFLIN
Private Const INTERNET_CONNECTION_CONFIG
'Flags for InternetAutodial
Private Const INTERNET_AUTODIAL_FORCE_ON
Private Const INTERNET_AUTODIAL_FORCE_UN
Private Const INTERNET_AUTODIAL_FAILIFSE
'Flags for InternetDial - must not conflict with InternetAutodial
' flags as they are valid here also.
Private Const INTERNET_DIAL_FORCE_PROMPT
Private Const INTERNET_DIAL_SHOW_OFFLINE
Private Const INTERNET_DIAL_UNATTENDED = &H8000
'
Private Const INTERNET_OPTION_CONNECTED_
Private Const INTERNET_STATE_DISCONNECTE
Private Const ISO_FORCE_DISCONNECTED = &H1
Private Const INTERNET_STATE_CONNECTED = &H1
'
Private Type INTERNET_CONNECTED_INFO
dwConnectedState As Long
dwFlags As Long
End Type
'
'functions
'
Private Declare Function InternetSetOption Lib "wininet.dll" Alias "InternetSetOptionA" (ByVal hInternet As Long, ByVal dwOption As Long, lpBuffer As Any, ByVal dwBufferLength As Long) As Long
Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal hwndParent As Long) As Long
Private Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long
Private Declare Function InternetDial Lib "wininet.dll" Alias "InternetDialA" (ByVal hwndParent As Long, ByVal lpszConnectoid As String, ByVal dwFlags As Long, lpdwConnection As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetGoOnline Lib "wininet.dll" Alias "InternetGoOnlineA" (ByVal lpszURL As String, ByVal hwndParent As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetHangUp Lib "wininet.dll" (ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetGetConnectedStateE
'*************************
'Win32API declarations
'*************************
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
'
Private Const ERROR_SUCCESS = 0&
Private Const FORMAT_MESSAGE_FROM_SYSTEM
Private Const FORMAT_MESSAGE_IGNORE_INSE
Private Const FORMAT_MESSAGE_MAX_WIDTH_M
Private Const LANG_USER_DEFAULT = &H400&
Private Const FORMAT_MESSAGE_FROM_HMODUL
'
'*************************
'Custom data types
'*************************
Public Enum AutoDialsFlags
ADF_FORCE_ONLINE = INTERNET_AUTODIAL_FORCE_ON
ADF_FORCE_UNATTENDED = INTERNET_AUTODIAL_FORCE_UN
End Enum
Public Enum DialsFlags
DF_FORCE_ONLINE = INTERNET_AUTODIAL_FORCE_ON
DF_FORCE_UNATTENDED = INTERNET_AUTODIAL_FORCE_UN
DF_DIAL_FORCE_PROMPT = INTERNET_DIAL_FORCE_PROMPT
DF_DIAL_UNATTENDED = INTERNET_DIAL_UNATTENDED
End Enum
'*************************
'local variables for the class properties
'*************************
Private mvarUseModem As Boolean
Private mvarUseLAN As Boolean
Private mvarUseProxy As Boolean
Private mvarIsRasInstalled As Boolean
Private mvarIsOffline As Boolean
Private mvarIsConnectionConfigured
Private mvarConnectionName As String
Private mvarIsConnected As Boolean
'
Private m_lConnectionID As Long
Public Function SetGlobalOnline() As Boolean
Attribute SetGlobalOnline.VB_Descrip
'*************************
'Author :Oleg Gdalevich
'Date/Time :07.10.99
'Purpose :Turns the local system to global online mode.
'*************************
Dim ConInfo As INTERNET_CONNECTED_INFO, lRetValue As Long
On Error GoTo SetGlobalOnline_Err_Handle
ConInfo.dwConnectedState = INTERNET_STATE_CONNECTED
lRetValue = InternetSetOption(0&, INTERNET_OPTION_CONNECTED_
If lRetValue <> 0 Then
SetGlobalOnline = True
Else
SetGlobalOnline = False
Call ProcessError("SetGlobalOnl
End If
Exit_Label:
Exit Function
SetGlobalOnline_Err_Handle
Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.SetGlo
GoTo Exit_Label
End Function
Public Function SetGlobalOffline() As Boolean
'*************************
'Author :Oleg Gdalevich
'Date/Time :06.10.99
'Purpose :
'Arguments :
'*************************
Dim ConInfo As INTERNET_CONNECTED_INFO, lRetValue As Long
On Error GoTo SetGlobalOffline_Err_Handl
ConInfo.dwConnectedState = INTERNET_STATE_DISCONNECTE
ConInfo.dwFlags = ISO_FORCE_DISCONNECTED
lRetValue = InternetSetOption(0&, INTERNET_OPTION_CONNECTED_
If lRetValue <> 0 Then
SetGlobalOffline = True
Else
SetGlobalOffline = False
Call ProcessError("SetGlobalOff
End If
Exit_Label:
Exit Function
SetGlobalOffline_Err_Handl
Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.SetGlo
GoTo Exit_Label
End Function
Public Function GoOnline(strURL As String, hwndParentWindow As Long) As Boolean
Attribute GoOnline.VB_Description = "Prompts the user for permission to initiate connection to a URL."
'*************************
'Author :Oleg Gdalevich
'Date/Time :06.10.99
'Purpose :Prompts the user for permission to initiate connection to a URL.
'Arguments :
'*************************
Dim lRetValue As Long
On Error GoTo GoOnline_Err_Handler
'
lRetValue = InternetGoOnline(strURL, hwndParentWindow, 0&)
'
If lRetValue <> 0 Then
GoOnline = True
Else
GoOnline = False
Call ProcessError("GoOnline")
End If
'
Exit_Label:
Exit Function
GoOnline_Err_Handler:
Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.GoOnli
GoTo Exit_Label
End Function
Public Function HangUp()
Attribute HangUp.VB_Description = "Instructs the modem to disconnect from the Internet."
'*************************
'Author :Oleg Gdalevich
'Date/Time :06.10.99
'Purpose :Instructs the modem to disconnect from the Internet.
'*************************
Dim lRetValue As Long
On Error GoTo HangUp_Err_Handler
lRetValue = InternetHangUp(m_lConnecti
HangUp = (lRetValue = ERROR_SUCCESS)
Exit_Label:
Exit Function
HangUp_Err_Handler:
Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.HangUp
GoTo Exit_Label
End Function
Public Function Dial(hwndParentWindow As Long, strConnectionName As String, lOption As DialsFlags, Optional bShowOfflineButton As Boolean = False) As Boolean
Attribute Dial.VB_Description = "Initiates a connection to the Internet using a modem."
'*************************
'Author :Oleg Gdalevich
'Date/Time :06.10.99
'Purpose :Initiates a connection to the Internet using a modem.
'Arguments :
'*************************
Dim lFlags As Long, lRetValue As Long
On Error GoTo Dial_Err_Handler
'
If bShowOfflineButton Then
lFlags = lOption Or INTERNET_DIAL_SHOW_OFFLINE
Else
lFlags = lOption
End If
'
lRetValue = InternetDial(hwndParentWin
'
If lRetValue <> 0 Then
Dial = True
Else
Dial = False
Call ProcessError("Dial")
End If
'
Exit_Label:
Exit Function
Dial_Err_Handler:
Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.Dial",
GoTo Exit_Label
End Function
Public Sub AutodialHangup()
Attribute AutodialHangup.VB_Descript
'*************************
'Author :Oleg Gdalevich
'Date/Time :06.10.99
'Description :Disconnects an automatic dial-up connection.
'*************************
On Error GoTo AutodialHangup_Err_Handler
Call InternetAutodialHangup(0&)
Exit_Label:
Exit Sub
AutodialHangup_Err_Handler
Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.Autodi
GoTo Exit_Label
End Sub
Public Function Autodial(hwndParentWindow As Long, lOption As AutoDialsFlags, Optional bFailIfSecurityCheck As Boolean = True) As Boolean
Attribute Autodial.VB_Description = "Causes the modem to automatically dial the default Internet connection."
'*************************
'Author :Oleg Gdalevich
'Date/Time :06.10.99
'Return :Returns TRUE if successful, or FALSE otherwise.
'Description :Causes the modem to automatically dial the default
' Internet connection.Causes the modem to automatically
' dial the default Internet connection.
'*************************
Dim lFlags As Long, lRetValue As Long
On Error GoTo Autodial_Err_Handler
'
If bFailIfSecurityCheck Then
lFlags = lOption Or INTERNET_AUTODIAL_FAILIFSE
End If
'
lRetValue = InternetAutodial(lFlags, hwndParentWindow)
'
If lRetVal <> 0 Then
Autodial = True
Else
Autodial = False
Call ProcessError("Autodial")
End If
'
Exit_Label:
Exit Function
Autodial_Err_Handler:
' Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.Autodi
GoTo Exit_Label
End Function
Public Sub Refresh()
Attribute Refresh.VB_Description = "Refresh the class data."
'-------------------------
'Author :Oleg Gdalevich
'Date/Time :05.10.99
'Purpose :
'-------------------------
Dim strConnectionName As String
Dim lNameLen As Long
Dim lRetVal As Long
Dim lConnectionFlags As Long
Dim lPtr As Long
Dim lNameLenPtr As Long
On Error GoTo Refresh_Err_Handler
strConnectionName = Space(256)
lNameLen = 256
lPtr = StrPtr(strConnectionName)
lNameLenPtr = VarPtr(lNameLen)
lRetVal = InternetGetConnectedStateE
If lRetVal <> 0 Then
mvarIsConnected = True
Else
mvarIsConnected = False
Call ProcessError("Refresh")
End If
mvarUseModem = lConnectionFlags And INTERNET_CONNECTION_MODEM
mvarUseLAN = lConnectionFlags And INTERNET_CONNECTION_LAN
mvarUseProxy = lConnectionFlags And INTERNET_CONNECTION_PROXY
mvarIsRasInstalled = lConnectionFlags And INTERNET_RAS_INSTALLED
mvarIsOffline = lConnectionFlags And INTERNET_CONNECTION_OFFLIN
mvarIsConnectionConfigured
mvarConnectionName = StringFromPointer(lPtr)
Exit_Label:
Exit Sub
Refresh_Err_Handler:
Err.Raise vbObjectError + Err.Number, "CWinInetConnection.Refres
GoTo Exit_Label
End Sub
Public Property Get IsConnected() As Boolean
IsConnected = mvarIsConnected
End Property
Public Property Get ConnectionName() As String
Attribute ConnectionName.VB_Descript
ConnectionName = mvarConnectionName
End Property
Public Property Get IsConnectionConfigured() As Boolean
Attribute IsConnectionConfigured.VB_
IsConnectionConfigured = mvarIsConnectionConfigured
End Property
Public Property Get IsOffline() As Boolean
Attribute IsOffline.VB_Description = "Local system is in offline mode."
IsOffline = mvarIsOffline
End Property
Public Property Get IsRasInstalled() As Boolean
Attribute IsRasInstalled.VB_Descript
IsRasInstalled = mvarIsRasInstalled
End Property
Public Property Get UseProxy() As Boolean
Attribute UseProxy.VB_Description = "Local system uses a proxy server to connect to the Internet."
UseProxy = mvarUseProxy
End Property
Public Property Get UseLAN() As Boolean
Attribute UseLAN.VB_Description = "Local system uses a local area network to connect to the Internet."
UseLAN = mvarUseLAN
End Property
Public Property Get UseModem() As Boolean
Attribute UseModem.VB_Description = "Local system uses a modem to connect to the Internet."
UseModem = mvarUseModem
End Property
'*************************
'Helper functions and procedures:
' GetWininetErrorDesc
' GetWinApiDesc
' StringFromPointer
' ProcessError
'*************************
Private Function GetWininetErrorDesc(lErrNu
Dim dwLength As Long
Dim strBuffer As String * 257
Dim hModule As Long
Dim dError As Long
Dim bLoadLib As Boolean
hModule = GetModuleHandle("wininet.d
If hModule = 0 Then
hModule = LoadLibrary("wininet.dll")
bLoadLib = True
End If
dwLength = FormatMessage(FORMAT_MESSA
ByVal hModule, lErrNumber, 0&, _
ByVal strBuffer, 256&, 0&)
If dwLength > 0 Then
GetWininetErrorDesc = Left$(strBuffer, dwLength - 2)
End If
If bLoadLib Then FreeLibrary hModule
End Function
Function GetWinApiDesc(lErrNumber As Long) As String
Dim strBuffer As String * 257
Dim dwLength As Long
dwLength = FormatMessage(FORMAT_MESSA
Or FORMAT_MESSAGE_MAX_WIDTH_M
ByVal strBuffer, 256&, 0&)
If dwLength > 0 Then
GetWinApiDesc = Left$(strBuffer, dwLength)
End If
End Function
Private Function StringFromPointer(ByVal lPointer As Long) As String
Dim strTemp As String
Dim lRetVal As Long
strTemp = String$(lstrlen(ByVal lPointer), 0)
lRetVal = lstrcpy(ByVal strTemp, ByVal lPointer)
If lRetVal Then StringFromPointer = strTemp
End Function
Private Sub ProcessError(strProcedureN
'*************************
'Author :Oleg Gdalevich
'Date/Time :06.10.99
'Description :process Win32API and WinInet API errors
'*************************
Dim lLastDllError As Long
On Error GoTo ProcessError_Err_Handler
lLastDllError = Err.LastDllError
If lLastDllError > 0 Then
If lLastDllError > 12000 Then
Err.Raise vbObjectError + 1000 + lLastDllError, _
"CWinInetConnection." & strProcedureName, _
"WinInet API Error: " & lLastDllError & " " & _
GetWininetErrorDesc(lLastD
Else
Err.Raise vbObjectError + 1000 + lLastDllError, _
"CWinInetConnection." & strProcedureName, _
"Win32API Error: " & lLastDllError & " " & _
GetWinApiDesc(lLastDllErro
End If
End If
Exit_Label:
Exit Sub
ProcessError_Err_Handler:
Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.Proces
GoTo Exit_Label
End Sub