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

?-<
LVL 26
EDDYKTAsked:
Who is Participating?

[Webinar] Streamline your web hosting managementRegister Today

x
 
mcriderConnect With a Mentor Commented:
Posting for points...

By the way, there are a couple of other function in that block I gave you...

GetHostInfo returns a User-Defined Type that contains the HostName and IP address of any host you pass to it. It does a DNS Lookup.

GetPingSring will ping a host and return a string containing the ping results... Try'em!


Thanks for the points... Hoping for a good grade ;-)


Cheers!
0
 
watyCommented:
' #VBIDEUtils#************************************************************
' * 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_OFFLINE = &H20
Private Const INTERNET_CONNECTION_CONFIGURED = &H40
'Flags for InternetAutodial
Private Const INTERNET_AUTODIAL_FORCE_ONLINE = 1&
Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2&
Private Const INTERNET_AUTODIAL_FAILIFSECURITYCHECK = 4&
'Flags for InternetDial - must not conflict with InternetAutodial
'                         flags as they are valid here also.
Private Const INTERNET_DIAL_FORCE_PROMPT = &H2000
Private Const INTERNET_DIAL_SHOW_OFFLINE = &H4000
Private Const INTERNET_DIAL_UNATTENDED = &H8000
'
Private Const INTERNET_OPTION_CONNECTED_STATE = 50
Private Const INTERNET_STATE_DISCONNECTED_BY_USER = &H10
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 InternetGetConnectedStateEx Lib "wininet.dll" Alias "InternetGetConnectedStateExA" (lpdwFlags As Long, lpszConnectionName As Long, dwNameLen As Long, ByVal dwReserved As Long) As Long
'***************************************************************************
'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 = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const LANG_USER_DEFAULT = &H400&
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
'
'********************************************************************************
'Custom data types
'********************************************************************************
Public Enum AutoDialsFlags
   ADF_FORCE_ONLINE = INTERNET_AUTODIAL_FORCE_ONLINE
   ADF_FORCE_UNATTENDED = INTERNET_AUTODIAL_FORCE_UNATTENDED
End Enum

Public Enum DialsFlags
   DF_FORCE_ONLINE = INTERNET_AUTODIAL_FORCE_ONLINE
   DF_FORCE_UNATTENDED = INTERNET_AUTODIAL_FORCE_UNATTENDED
   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  As Boolean
Private mvarConnectionName          As String
Private mvarIsConnected             As Boolean
'
Private m_lConnectionID As Long

Public Function SetGlobalOnline() As Boolean
   Attribute SetGlobalOnline.VB_Description = "Turns the local system to global online mode."
   '********************************************************************************
   '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_Handler

   ConInfo.dwConnectedState = INTERNET_STATE_CONNECTED

   lRetValue = InternetSetOption(0&, INTERNET_OPTION_CONNECTED_STATE, ConInfo, Len(ConInfo))

   If lRetValue <> 0 Then
      SetGlobalOnline = True
   Else
      SetGlobalOnline = False
      Call ProcessError("SetGlobalOnline")
   End If

Exit_Label:
   Exit Function

SetGlobalOnline_Err_Handler:
   Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.SetGlobalOnline", Err.Description
   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_Handler

   ConInfo.dwConnectedState = INTERNET_STATE_DISCONNECTED_BY_USER
   ConInfo.dwFlags = ISO_FORCE_DISCONNECTED

   lRetValue = InternetSetOption(0&, INTERNET_OPTION_CONNECTED_STATE, ConInfo, Len(ConInfo))

   If lRetValue <> 0 Then
      SetGlobalOffline = True
   Else
      SetGlobalOffline = False
      Call ProcessError("SetGlobalOffline")
   End If

Exit_Label:
   Exit Function

SetGlobalOffline_Err_Handler:
   Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.SetGlobalOffline", Err.Description
   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.GoOnline", Err.Description
   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_lConnectionID, 0&)
   HangUp = (lRetValue = ERROR_SUCCESS)

Exit_Label:
   Exit Function

HangUp_Err_Handler:
   Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.HangUp", Err.Description
   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(hwndParentWindow, strConnectionName, lFlags, m_lConnectionID, 0&)
   '
   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", Err.Description
   GoTo Exit_Label

End Function

Public Sub AutodialHangup()
   Attribute AutodialHangup.VB_Description = "Disconnects an automatic dial-up connection."
   '********************************************************************************
   '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.AutodialHangup", Err.Description
   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_FAILIFSECURITYCHECK
   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.Autodial", Err.Description
   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 = InternetGetConnectedStateEx(lConnectionFlags, ByVal lPtr, ByVal lNameLen, 0&)

   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_OFFLINE
   mvarIsConnectionConfigured = lConnectionFlags And INTERNET_CONNECTION_CONFIGURED
   mvarConnectionName = StringFromPointer(lPtr)

Exit_Label:
   Exit Sub

Refresh_Err_Handler:
   Err.Raise vbObjectError + Err.Number, "CWinInetConnection.Refresh", Err.Description
   GoTo Exit_Label

End Sub

Public Property Get IsConnected() As Boolean
   IsConnected = mvarIsConnected
End Property

Public Property Get ConnectionName() As String
   Attribute ConnectionName.VB_Description = "Name of the active connection."
   ConnectionName = mvarConnectionName
End Property

Public Property Get IsConnectionConfigured() As Boolean
   Attribute IsConnectionConfigured.VB_Description = "Local system has a valid connection to the Internet, but it may or may not be currently connected."
   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_Description = "Local system has RAS installed."
   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(lErrNumber As Long) As String

   Dim dwLength As Long
   Dim strBuffer As String * 257
   Dim hModule As Long
   Dim dError As Long
   Dim bLoadLib As Boolean

   hModule = GetModuleHandle("wininet.dll")

   If hModule = 0 Then
      hModule = LoadLibrary("wininet.dll")
      bLoadLib = True
   End If

   dwLength = FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, _
      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_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS _
      Or FORMAT_MESSAGE_MAX_WIDTH_MASK, ByVal 0&, lErrNumber, LANG_USER_DEFAULT, _
      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(strProcedureName As String)
   '********************************************************************************
   '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(lLastDllError)
      Else
         Err.Raise vbObjectError + 1000 + lLastDllError, _
            "CWinInetConnection." & strProcedureName, _
            "Win32API Error: " & lLastDllError & " " & _
            GetWinApiDesc(lLastDllError)
      End If
   End If

Exit_Label:
   Exit Sub

ProcessError_Err_Handler:
   Err.Raise vbObjectError + 1000 + Err.Number, "CWinInetConnection.ProcessError", Err.Description
   GoTo Exit_Label

End Sub
0
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

 
watyCommented:
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_NUMBER = 0

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_ERROR = 12003

Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" ( _
   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_CONNECTION = &H400000
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, vbNullString, vbNullString, 0)

   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(mlINetHandle, msHostAddress, INTERNET_INVALID_PORT_NUMBER, _
      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.LastDllError)
      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_Description = "Return a Directory List as a Disconnected Record set"
   '
   ' 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(mlConnection, sFilter, pData, 0, 0)
   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, pData)
      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.LastDllError)
      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, ExistingName, NewName)
   '
   ' 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.LastDllError)
      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, ExistingName)
   '
   ' 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(mlConnection, sPathFromRoot)
      '
      ' 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_ERROR Then
      '
      ' Get Message Size and Number
      '
      InternetGetLastResponseInfo lError, vbNullString, lLen
      sBuffer = String$(lLen + 1, vbNullChar)
      '
      ' Get Message
      '
      InternetGetLastResponseInfo lError, sBuffer, lLen
      GetINETErrorMsg = vbCrLf & sBuffer
   End If
End Function
0
 
EDDYKTAuthor Commented:
Waty,

Thanks your quick response. I will try and let you know.

?->
0
 
watyCommented:
:§)
0
 
EDDYKTAuthor Commented:
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.

?-<
0
 
watyCommented:
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_NUMBER = 0

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_ERROR = 12003

Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" ( _
   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_CONNECTION = &H400000
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, vbNullString, vbNullString, 0)

   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(mlINetHandle, msHostAddress, INTERNET_INVALID_PORT_NUMBER, _
      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.LastDllError)
      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_Description = "Return a Directory List as a Disconnected Record set"
   '
   ' 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(mlConnection, sFilter, pData, 0, 0)
   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, pData)
      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.LastDllError)
      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, ExistingName, NewName)
   '
   ' 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.LastDllError)
      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, ExistingName)
   '
   ' 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(mlConnection, sPathFromRoot)
      '
      ' 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_ERROR Then
      '
      ' Get Message Size and Number
      '
      InternetGetLastResponseInfo lError, vbNullString, lLen
      sBuffer = String$(lLen + 1, vbNullChar)
      '
      ' Get Message
      '
      InternetGetLastResponseInfo lError, sBuffer, lLen
      GetINETErrorMsg = vbCrLf & sBuffer
   End If
End Function
0
 
EDDYKTAuthor Commented:
Waty,

I've tried your example too.

The problem is if I passed the invalid IP address to your class, the InternetConnect(mlINetHandle, msHostAddress will block me for over 1 min.

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.

0
 
watyCommented:
There is somewhere a timeout to setup....
I will try to take a look to that...
0
 
manojaminCommented:
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_TIMEOUT = 2
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, INTERNET_OPTION_CONNECT_TIMEOUT, m_lConnectTimeOut, 4)

0
 
EDDYKTAuthor Commented:
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?
0
 
EDDYKTAuthor Commented:
Waty,

I just noticed your picture is on EE.

8->
0
 
mcriderCommented:
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, WSAD)
    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.RoundTripTime)) & "ms TTL=" _
            & Trim$(CStr(ECHO.Options.Ttl))
    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 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ012345": If Not EchoString = "" Then eString = EchoString
    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.hAddress)
    If dwAddr = 0 Then
        SysPing = IP_BAD_DESTINATION
        ECHO.status = IP_BAD_DESTINATION
        Exit Function
    End If
    rVal = WSAStartup(WS_VERSION_REQD, WSAD)
    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
0
 
EDDYKTAuthor Commented:
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->
0
All Courses

From novice to tech pro — start learning today.