Dim curFile As Integer
Dim errors As Boolean
Dim ftpFiles(3000) As String
Dim numFtpFiles As Integer
Dim outFile As Integer
Dim inboundDir As String
Dim outboundDir As String
Dim outFileName As String
Dim sizeData As String
Dim startTime As Long
Dim system As dirTypes
Dim timeoutMinutes As Integer
' Number of minutes to kill program if it runs this long
Const ProgramTimeout = 10
Enum ftpStates
ftpCD
ftpClose
ftpConnect
ftpDelete
FTPDir
ftpGet
ftpPut
ftpSize
End Enum
' These values determine how to parse off file names from the different system's
directories
Enum dirTypes
dirUNIX = 1
dirWindows
End Enum
Private ftpIsConnected As Boolean
Private ftpState As Integer
Private ftpError As Boolean
Private WithEvents inetFTP As Inet
Attribute inetFTP.VB_VarHelpID = -1
Private WithEvents timClock As VB.Timer
Attribute timClock.VB_VarHelpID = -1
'************************************************************************
' Properties
'************************************************************************
Property Get fileSize() As Long
If sizeData <> "" Then
fileSize = CLng(sizeData)
Else
fileSize = -1
End If
End Property
Property Let FTPSystem(sys As dirTypes)
system = sys
End Property
Property Let InboundDirectory(doh As String)
inboundDir = doh
If Right(inboundDir, 1) <> "\" Then inboundDir = inboundDir + "\"
End Property
Property Get NextFile() As String
If curFile + 1 > numFtpFiles Then
NextFile = ""
Else
curFile = curFile + 1
NextFile = ftpFiles(curFile)
End If
End Property
Property Let OutboundDirectory(doh As String)
outboundDir = doh
If Right(outboundDir, 1) <> "\" Then outboundDir = outboundDir + "\"
End Property
Property Get UNIX()
UNIX = dirUNIX
End Property
'************************************************************************
' Public routines
'************************************************************************
Public Function Connected() As Boolean
Connected = ftpIsConnected
End Function
Public Function DoFTPCD(cdDir As String) As Integer
DoFTPCD = DoFTPCommand("cd " + cdDir, ftpCD)
End Function
Public Function DoFTPClose() As Integer
DoFTPClose = DoFTPCommand("close", ftpClose)
ftpIsConnected = False
End Function
Public Function DoFTPDelete(fname As String) As Integer
DoFTPDelete = DoFTPCommand("delete " + fname, ftpCD)
End Function
Public Function DoFTPDir(Optional mask As String = "*.*") As Integer
' Retrieve all files (no directories) in the current directory
' No path information is included
DoFTPDir = DoFTPCommand("dir " + mask, FTPDir)
curFile = 0
End Function
Public Function DoFTPGet(fname As String) As Integer
DoFTPGet = DoFTPCommand("get " + fname + " " + inboundDir + fname, ftpGet)
End Function
Public Function DoFTPPut(fname As String) As Integer
DoFTPPut = DoFTPCommand("put " + outboundDir + fname + " " + fname, ftpPut)
End Function
Public Function InitFTP(net As Inet, tc As VB.Timer, url As String, userid As String,
_
password As String, Optional numRetries As Integer = 3, Optional retryTime = 30, _
Optional timeout As Integer = ProgramTimeout) As Integer
' Uses the internet transfer control to ftp files
Dim i As Integer
Dim fname As String
Dim t As Long
On Error Resume Next
errors = False
system = dirUNIX
InitFTP = -1
Set inetFTP = net
Set timClock = tc
' Initialize the timer
timeoutMinutes = timeout
timClock.Enabled = False
timClock.Interval = 60000
' Connect to the ftp site
' Timeout is in seconds
inetFTP.Protocol = icFTP
inetFTP.RequestTimeout = 60
inetFTP.url = url
inetFTP.UserName = userid
inetFTP.password = password
' Try up to numRetries times to get a connection
' Delay a user-defined interval in seconds between retries, since a connection failure
' may return immediately rather than be timed-out
On Error Resume Next
For i = 1 To numRetries
DoFTPCommand "", ftpConnect
If Err.Number <> 0 Then
If Err.Number = icTimeout Or Err.Number = icConnectFailed Then
' Cancel the command and delay
t = Timer
Do While Timer < t + retryTime
DoEvents
Loop
Else
Err.Raise Err.Number, , Err.Description
Exit Function
End If
Else
Exit For
End If
Next
If Err.Number = icTimeout Or Err.Number = icConnectFailed Then
Err.Raise Err.Number, , Err.Description + vbNewLine + "On retry number " +
CStr(i) + _
" with an interval of " + CStr(retryTime) + " seconds"
Exit Function
End If
InitFTP = 0
ftpIsConnected = True
End Function
Public Sub Ping(url As String)
' Ping the ftp site
' Just start a command with a ping an wait a few seconds for it to finish
Shell "ping " + url, vbMinimizedNoFocus
startTime = Timer
Do While Timer < startTime + 5
DoEvents
Loop
End Sub
'************************************************************************
' Control events
'************************************************************************
Private Sub timClock_Timer()
' Kill program if it runs too long
If Timer > startTime + timeoutMinutes * 60 Then
timClock.Interval = 0
ftpError = True
Exit Sub
End If
End Sub
'************************************************************************
' Private routines
'************************************************************************
Function DoFTPCommand(Command As String, mode As ftpStates) As Integer
' Do the ftp command and set the mode for processing
' Allow for testing without being connected - ftp commands will just be ignored
If Not ftpIsConnected And mode <> ftpConnect Then
DoFTPCommand = 0
Exit Function
End If
On Error Resume Next
' Set a timer to cancel program if it gets hung up except on connect, which has
' it's own time-out
' ALWAYS enabling timer - program has been hanging...
' If mode <> ftpConnect Then timClock.Enabled = True
timClock.Enabled = True
startTime = Timer
ftpError = False
ftpState = mode
inetFTP.Execute , Command
While inetFTP.StillExecuting And Not ftpError
DoEvents
Wend
timClock.Enabled = False
If (inetFTP.ResponseCode <> 18 And inetFTP.ResponseCode <> 0) Or ftpError Or Err.Number
<> 0 Then
' An error occurred during the command, get from server
If inetFTP.ResponseCode <> 18 And inetFTP.ResponseCode <> 0 Then
Err.Raise inetFTP.ResponseCode, "DoFTPCommand", inetFTP.ResponseInfo
ElseIf Err.Number = 0 Then
Err.Raise 9999, "DoFTPCommand", "Unknown error or time-out during FTP
command"
End If
DoFTPCommand = -1
Else
FTPComplete
DoFTPCommand = 0
End If
End Function
Public Sub FTPComplete()
Dim tmpData As Variant
Dim dirData As String
Dim strEntry As String
Dim i As Long
Dim k As Long
Dim s As Long
Dim doh As String
On Error Resume Next
Select Case ftpState
Case FTPDir:
dirData = ""
Do
tmpData = inetFTP.GetChunk(4096, icString)
If Len(tmpData) = 0 Then Exit Do
DoEvents
dirData = dirData + tmpData
Loop
numFtpFiles = 0
If dirData <> "" Then
Select Case system
Case dirUNIX
For i = 1 To Len(dirData) - 1
k = InStr(i, dirData, vbCrLf) ' We don't want
CRLF
strEntry = Mid(dirData, i, k - i)
If Right(strEntry, 1) = "/" And Trim(strEntry) <> ""
Then
numFtpFiles = numFtpFiles + 1
ftpFiles(numFtpFiles) = strEntry
End If
i = k + 1
DoEvents
Next i
Case dirWindows
For i = 1 To Len(dirData) - 1
k = InStr(i, dirData, vbCrLf) ' We don't want
CRLF
strEntry = Mid(dirData, i, k - i)
If Trim(strEntry) <> "" Then
numFtpFiles = numFtpFiles + 1
ftpFiles(numFtpFiles) = strEntry
End If
i = k + 1
DoEvents
Next i
End Select
End If
Case ftpSize:
' Return the file size
tmpData = inetFTP.GetChunk(1024, icString)
sizeData = ""
If Len(tmpData) > 0 Then sizeData = tmpData
End Select
End Sub
Sub GetFileList(path As String, ext As String, files() As String, nfiles As Integer)
' Get a list of files from a directory without the extension
Dim fname As String, cpos As Integer
nfiles = 0
fname = Dir(path + "*." + ext)
Do While fname <> ""
nfiles = nfiles + 1
files(nfiles) = fname
fname = Dir
Loop
End Sub
![[jester]](/data/assets/smilies/jester.gif "[jester] [jester]")
