With the attached form module. when closing the application, it seems the connection is still open in the background.
I've tried "Quit" & "CLOSE" but may have it in the incorrect position within the module.
When the application has closed, if I try to run it again, I have to terminate it through Task Manager
Can anyone see where it's hanging ?
This only happens once files have been uploaded using Inet1
Option Explicit
Private msCurrentFile As String
Friend Sub FTPFile(ByVal sFTPServer As String, _
ByVal sFTPCommand As String, _
ByVal sFTPUser As String, _
ByVal sFTPPwd As String, _
ByVal sFTPSrcFileName As String, _
ByVal sFTPTgtFileName As String)
Dim oFS As Scripting.FileSystemObject
Dim sURL As String
On Error GoTo FTPFileExit
Me.HRG True
msCurrentFile = ""
Set oFS = New Scripting.FileSystemObject
sURL = "ftp://" & sFTPUser & ":" & sFTPPwd & "@" & sFTPServer
Inet1.Protocol = icFTP
Inet1.RequestTimeout = 60
Inet1.RemotePort = 21
Inet1.AccessType = icDirect
Inet1.URL = sURL
Select Case sFTPCommand
Case "PUT"
msCurrentFile = sFTPSrcFileName
If oFS.FileExists(sFTPSrcFileName) = False Then GoTo FTPFileExit
Inet1.Execute sURL, sFTPCommand & Space(1) & sFTPSrcFileName & " " & sFTPTgtFileName
Case "GET"
msCurrentFile = sFTPTgtFileName
If oFS.FileExists(sFTPTgtFileName) = True Then oFS.DeleteFile sFTPTgtFileName, True
Inet1.Execute sURL, sFTPCommand & Space(1) & sFTPSrcFileName & " " & sFTPTgtFileName
End Select
Me.WaitForResponse
Inet1.Execute sURL, "quit"
Me.WaitForResponse
FTPFileExit:
Set oFS = Nothing
HRG False
End Sub
Friend Sub WaitForResponse()
Dim fWait As Boolean
On Error GoTo ErrHandler
fWait = True
Do Until fWait = False
DoEvents
fWait = Inet1.StillExecuting
Loop
ErrHandler:
Err.Clear
End Sub
Private Sub Command1_Click()
If Me.List1.SelCount = 0 Then
MsgBox "You Must Select Who To Send The Files To", vbInformation, "FTP Selection"
Exit Sub
End If
Dim N As Integer
Dim FTPPath As String
Dim FTPSource As String
Dim strRef As String
Dim strRecip As String
Dim strRecipDisplay As String
Dim FF As String 'Final FileName
Select Case List1
Case "Kindleys"
strRef = InputBox("Please Enter A Kindleys Reference", "")
strRecip = "E:mail Address"
strRecipDisplay = "Kindleys Documents"
If strRef = "" Then
MsgBox "You Must Enter A Kindleys Reference Before Proceeding", vbInformation, "Reference Error"
Exit Sub
End If
If Len(strRef) > 5 Then
MsgBox "Too Many Characters" & vbCrLf & _
"You Can Only Use 5 Characters" & vbCrLf & _
"Please Enter A Valid 5 Character Number", vbInformation, "Information": Exit Sub
End If
If Len(strRef) < 5 Then
MsgBox "Not Enough Characters" & vbCrLf & _
"You Need To Use 5 Characters" & vbCrLf & _
"Please Enter A Valid 5 Character Number", vbInformation, "Information": Exit Sub
End If
For N = 0 To List2.ListCount - 1
If Right(List2.List(N), 3) = "jpg" Then
FTPSource = "L:\MMPDF\Image\"
FTPPath = "\MMPDF\Image\"
FF = Right(List2.List(N), 7)
End If
If Right(List2.List(N), 3) = "pdf" Then
FTPSource = "L:\MMPDF\EstPdf\"
FTPPath = "\MMPDF\EstPdf\"
FF = "-" & Right(List2.List(N), 7)
End If
frmFTP1024.FTPFile "URL.##.###.###", "PUT", "UserName", "Password", FTPSource & List2.List(N), FTPPath & strRef & FF
Next N
Case "Calverts"
MsgBox "No IP Address Yet For Calverts": Exit Sub
Case "M&M Leek"
MsgBox "No IP Address Yet For M&M Leek": Exit Sub
Case "M&M Longton"
MsgBox "No IP Address Yet For M&M Longton": Exit Sub
End Select
MAPISession1.SignOn
With MAPIMessages1
.SessionID = MAPISession1.SessionID
.Compose
.MsgSubject = "Files Transferred For Job No: " & strRef
.RecipIndex = 0
.RecipDisplayName = "Kindleys Documents"
.RecipAddress = strRecip
.RecipType = mapToList
.MsgNoteText = Space(List2.SelCount) & vbCrLf & "Files Transferred From M&M Vehicle Repairs"
.Send True
End With
On Error Resume Next
exitHandler:
MAPISession1.SignOff
Inet1.Execute "CLOSE"
Unload Me
errorHandler:
If Err <> 0 Then
MsgBox Err.Description & " " & Err.Number & " Contact Dave Willett" & vbCrLf & _
" Quoting This Error Message", vbCritical, "Error"
Resume exitHandler
End If
End Sub
Private Sub Form_Load()
Dim N As Integer
With List1
.AddItem "Kindleys"
.AddItem "Calverts"
.AddItem "M&M Leek"
.AddItem "M&M Longton"
End With
With List2
For N = 0 To Form1024Image.lstFTP.ListCount - 1
.AddItem Form1024Image.lstFTP.List(N)
Next N
End With
selImages True
End Sub
Private Sub Inet1_StateChanged(ByVal State As Integer)
On Error Resume Next
Select Case State
Case icNone
Case icResolvingHost: Me.lblRESPONSE.Caption = "Resolving Host"
Case icHostResolved: Me.lblRESPONSE.Caption = "Host Resolved"
Case icConnecting: Me.lblRESPONSE.Caption = "Connecting..."
Case icConnected: Me.lblRESPONSE.Caption = "Connected"
Case icResponseReceived: Me.lblRESPONSE.Caption = "Transferring File:" & Space(5) & msCurrentFile
Case icDisconnecting: Me.lblRESPONSE.Caption = "Disconnecting..."
Case icDisconnected: Me.lblRESPONSE.Caption = "Disconnected"
Case icError: MsgBox "FTP Error: " & Inet1.ResponseCode & " " & Inet1.ResponseInfo
Case icResponseCompleted: Me.lblRESPONSE.Caption = "Process Complete."
End Select
Me.lblRESPONSE.Refresh
Err.Clear
End Sub
Friend Sub HRG(fShowHourGlass As Boolean)
If fShowHourGlass = True Then
Screen.MousePointer = 11
Else
Screen.MousePointer = 0
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Form1024Image.lstFTP.Clear
End Sub
Private Sub selImages(aBool As Boolean)
' Routine to either check or uncheck all of the items in the list of
' available images. Dirt simple.
Dim i As Integer
Dim sel As Long
Me.MousePointer = vbHourglass
sel = List2.ListIndex
LockWindowUpdate List2.hwnd
For i = 0 To List2.ListCount - 1
List2.Selected(i) = aBool
Next i
List2.ListIndex = sel
LockWindowUpdate False
Me.MousePointer = vbDefault
End Sub
Regards
I've tried "Quit" & "CLOSE" but may have it in the incorrect position within the module.
When the application has closed, if I try to run it again, I have to terminate it through Task Manager
Can anyone see where it's hanging ?
This only happens once files have been uploaded using Inet1
Option Explicit
Private msCurrentFile As String
Friend Sub FTPFile(ByVal sFTPServer As String, _
ByVal sFTPCommand As String, _
ByVal sFTPUser As String, _
ByVal sFTPPwd As String, _
ByVal sFTPSrcFileName As String, _
ByVal sFTPTgtFileName As String)
Dim oFS As Scripting.FileSystemObject
Dim sURL As String
On Error GoTo FTPFileExit
Me.HRG True
msCurrentFile = ""
Set oFS = New Scripting.FileSystemObject
sURL = "ftp://" & sFTPUser & ":" & sFTPPwd & "@" & sFTPServer
Inet1.Protocol = icFTP
Inet1.RequestTimeout = 60
Inet1.RemotePort = 21
Inet1.AccessType = icDirect
Inet1.URL = sURL
Select Case sFTPCommand
Case "PUT"
msCurrentFile = sFTPSrcFileName
If oFS.FileExists(sFTPSrcFileName) = False Then GoTo FTPFileExit
Inet1.Execute sURL, sFTPCommand & Space(1) & sFTPSrcFileName & " " & sFTPTgtFileName
Case "GET"
msCurrentFile = sFTPTgtFileName
If oFS.FileExists(sFTPTgtFileName) = True Then oFS.DeleteFile sFTPTgtFileName, True
Inet1.Execute sURL, sFTPCommand & Space(1) & sFTPSrcFileName & " " & sFTPTgtFileName
End Select
Me.WaitForResponse
Inet1.Execute sURL, "quit"
Me.WaitForResponse
FTPFileExit:
Set oFS = Nothing
HRG False
End Sub
Friend Sub WaitForResponse()
Dim fWait As Boolean
On Error GoTo ErrHandler
fWait = True
Do Until fWait = False
DoEvents
fWait = Inet1.StillExecuting
Loop
ErrHandler:
Err.Clear
End Sub
Private Sub Command1_Click()
If Me.List1.SelCount = 0 Then
MsgBox "You Must Select Who To Send The Files To", vbInformation, "FTP Selection"
Exit Sub
End If
Dim N As Integer
Dim FTPPath As String
Dim FTPSource As String
Dim strRef As String
Dim strRecip As String
Dim strRecipDisplay As String
Dim FF As String 'Final FileName
Select Case List1
Case "Kindleys"
strRef = InputBox("Please Enter A Kindleys Reference", "")
strRecip = "E:mail Address"
strRecipDisplay = "Kindleys Documents"
If strRef = "" Then
MsgBox "You Must Enter A Kindleys Reference Before Proceeding", vbInformation, "Reference Error"
Exit Sub
End If
If Len(strRef) > 5 Then
MsgBox "Too Many Characters" & vbCrLf & _
"You Can Only Use 5 Characters" & vbCrLf & _
"Please Enter A Valid 5 Character Number", vbInformation, "Information": Exit Sub
End If
If Len(strRef) < 5 Then
MsgBox "Not Enough Characters" & vbCrLf & _
"You Need To Use 5 Characters" & vbCrLf & _
"Please Enter A Valid 5 Character Number", vbInformation, "Information": Exit Sub
End If
For N = 0 To List2.ListCount - 1
If Right(List2.List(N), 3) = "jpg" Then
FTPSource = "L:\MMPDF\Image\"
FTPPath = "\MMPDF\Image\"
FF = Right(List2.List(N), 7)
End If
If Right(List2.List(N), 3) = "pdf" Then
FTPSource = "L:\MMPDF\EstPdf\"
FTPPath = "\MMPDF\EstPdf\"
FF = "-" & Right(List2.List(N), 7)
End If
frmFTP1024.FTPFile "URL.##.###.###", "PUT", "UserName", "Password", FTPSource & List2.List(N), FTPPath & strRef & FF
Next N
Case "Calverts"
MsgBox "No IP Address Yet For Calverts": Exit Sub
Case "M&M Leek"
MsgBox "No IP Address Yet For M&M Leek": Exit Sub
Case "M&M Longton"
MsgBox "No IP Address Yet For M&M Longton": Exit Sub
End Select
MAPISession1.SignOn
With MAPIMessages1
.SessionID = MAPISession1.SessionID
.Compose
.MsgSubject = "Files Transferred For Job No: " & strRef
.RecipIndex = 0
.RecipDisplayName = "Kindleys Documents"
.RecipAddress = strRecip
.RecipType = mapToList
.MsgNoteText = Space(List2.SelCount) & vbCrLf & "Files Transferred From M&M Vehicle Repairs"
.Send True
End With
On Error Resume Next
exitHandler:
MAPISession1.SignOff
Inet1.Execute "CLOSE"
Unload Me
errorHandler:
If Err <> 0 Then
MsgBox Err.Description & " " & Err.Number & " Contact Dave Willett" & vbCrLf & _
" Quoting This Error Message", vbCritical, "Error"
Resume exitHandler
End If
End Sub
Private Sub Form_Load()
Dim N As Integer
With List1
.AddItem "Kindleys"
.AddItem "Calverts"
.AddItem "M&M Leek"
.AddItem "M&M Longton"
End With
With List2
For N = 0 To Form1024Image.lstFTP.ListCount - 1
.AddItem Form1024Image.lstFTP.List(N)
Next N
End With
selImages True
End Sub
Private Sub Inet1_StateChanged(ByVal State As Integer)
On Error Resume Next
Select Case State
Case icNone
Case icResolvingHost: Me.lblRESPONSE.Caption = "Resolving Host"
Case icHostResolved: Me.lblRESPONSE.Caption = "Host Resolved"
Case icConnecting: Me.lblRESPONSE.Caption = "Connecting..."
Case icConnected: Me.lblRESPONSE.Caption = "Connected"
Case icResponseReceived: Me.lblRESPONSE.Caption = "Transferring File:" & Space(5) & msCurrentFile
Case icDisconnecting: Me.lblRESPONSE.Caption = "Disconnecting..."
Case icDisconnected: Me.lblRESPONSE.Caption = "Disconnected"
Case icError: MsgBox "FTP Error: " & Inet1.ResponseCode & " " & Inet1.ResponseInfo
Case icResponseCompleted: Me.lblRESPONSE.Caption = "Process Complete."
End Select
Me.lblRESPONSE.Refresh
Err.Clear
End Sub
Friend Sub HRG(fShowHourGlass As Boolean)
If fShowHourGlass = True Then
Screen.MousePointer = 11
Else
Screen.MousePointer = 0
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Form1024Image.lstFTP.Clear
End Sub
Private Sub selImages(aBool As Boolean)
' Routine to either check or uncheck all of the items in the list of
' available images. Dirt simple.
Dim i As Integer
Dim sel As Long
Me.MousePointer = vbHourglass
sel = List2.ListIndex
LockWindowUpdate List2.hwnd
For i = 0 To List2.ListCount - 1
List2.Selected(i) = aBool
Next i
List2.ListIndex = sel
LockWindowUpdate False
Me.MousePointer = vbDefault
End Sub
Regards
