|
VERSION 2.00
Begin Form frmClient
BackColor = &H00C0C0C0&
Caption = "FTP Client"
ClientHeight = 4200
ClientLeft = 1215
ClientTop = 1635
ClientWidth = 7110
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 4890
Icon = FTPMAIN.FRX:0000
Left = 1155
LinkTopic = "Form1"
ScaleHeight = 4200
ScaleWidth = 7110
Top = 1005
Width = 7230
Begin SSPanel pnlXferStat
Height = 1755
Left = 1440
TabIndex = 26
Top = 2220
Visible = 0 'False
Width = 4215
Begin SSPanel pnlXferGauge
BackColor = &H000000FF&
BevelOuter = 1 'Inset
BevelWidth = 2
FloodColor = &H0000C000&
FloodType = 1 'Left To Right
Height = 315
Left = 180
TabIndex = 28
Top = 960
Width = 3855
End
Begin CommandButton cmdXferCancel
Caption = "&Cancel"
Height = 255
Left = 1560
TabIndex = 27
TabStop = 0 'False
Top = 1380
Width = 1215
End
Begin Label lblXferText
BackStyle = 0 'Transparent
Height = 795
Left = 180
TabIndex = 29
Top = 120
Width = 3855
End
End
Begin DriveListBox lstDrives
Height = 315
Left = 3240
TabIndex = 23
TabStop = 0 'False
Top = 3660
Visible = 0 'False
Width = 495
End
Begin Frame fraTransfer
BackColor = &H00C0C0C0&
Caption = "Transfer"
Height = 1035
Left = 3000
TabIndex = 19
Top = 1200
Width = 1035
Begin OptionButton rdoAscii
BackColor = &H00C0C0C0&
Caption = "ASCII"
Height = 255
Left = 60
TabIndex = 21
Top = 360
Value = -1 'True
Width = 855
End
Begin OptionButton rdoBinary
BackColor = &H00C0C0C0&
Caption = "Binary"
Height = 255
Left = 60
TabIndex = 20
Top = 660
Width = 915
End
End
Begin Socket Socket2
Backlog = 1
Binary = -1 'True
Blocking = -1 'True
Broadcast = 0 'False
BufferSize = 0
HostAddress = ""
HostFile = ""
HostName = ""
InLine = 0 'False
Interval = 0
KeepAlive = 0 'False
Left = 3060
Linger = 0
LocalPort = 0
LocalService = ""
Peek = 0 'False
Protocol = 0
RecvLen = 0
RemotePort = 0
RemoteService = ""
ReuseAddress = 0 'False
Route = -1 'True
SendLen = 0
TabIndex = 16
Timeout = 0
Top = 3180
Type = 1
Urgent = 0 'False
End
Begin Socket Socket1
Backlog = 1
Binary = -1 'True
Blocking = -1 'True
Broadcast = 0 'False
BufferSize = 0
HostAddress = ""
HostFile = ""
HostName = ""
InLine = 0 'False
Interval = 0
KeepAlive = 0 'False
Left = 3540
Linger = 0
LocalPort = 0
LocalService = ""
Peek = 0 'False
Protocol = 0
RecvLen = 0
RemotePort = 0
RemoteService = ""
ReuseAddress = 0 'False
Route = -1 'True
SendLen = 0
TabIndex = 15
Timeout = 60000
Top = 3180
Type = 1
Urgent = 0 'False
End
Begin CommandButton btnCopy
Caption = "Copy"
Enabled = 0 'False
Height = 375
Left = 3000
TabIndex = 5
Top = 2280
Width = 1035
End
Begin Frame fraRemote
BackColor = &H00C0C0C0&
Caption = "Remote"
Height = 2955
Left = 4080
TabIndex = 14
Top = 1140
Width = 2895
Begin TextBox txtRemDir
BackColor = &H00C0C0C0&
Enabled = 0 'False
Height = 555
Left = 600
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 25
Top = 300
Width = 2175
End
Begin CommandButton cmdRemRef
Caption = "Refresh"
Enabled = 0 'False
Height = 315
Left = 180
TabIndex = 4
Top = 2580
Width = 2595
End
Begin ListBox lstRemFiles
DragIcon = FTPMAIN.FRX:0302
Height = 1590
Left = 180
MultiSelect = 2 'Extended
Sorted = -1 'True
TabIndex = 3
Tag = "Remote"
Top = 960
Width = 2595
End
Begin Label Label6
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Path:"
Height = 195
Left = 120
TabIndex = 18
Top = 360
Width = 465
End
Begin Label lblRemPath
BackStyle = 0 'Transparent
BorderStyle = 1 'Fixed Single
Height = 555
Left = 600
TabIndex = 17
Top = 300
Visible = 0 'False
Width = 2175
WordWrap = -1 'True
End
End
Begin Frame fraLocalInfo
BackColor = &H00C0C0C0&
Caption = "Local"
Height = 2955
Left = 60
TabIndex = 13
Top = 1140
Width = 2895
Begin TextBox txtLocDir
BackColor = &H00C0C0C0&
Enabled = 0 'False
Height = 555
Left = 600
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 24
Top = 300
Width = 2175
End
Begin CommandButton cmdLocRef
Caption = "Refresh"
Height = 315
Left = 180
TabIndex = 2
Top = 2580
Width = 2595
End
Begin ListBox lstLocFiles
DragIcon = FTPMAIN.FRX:0604
Height = 1590
Left = 180
MultiSelect = 2 'Extended
Sorted = -1 'True
TabIndex = 1
Tag = "Local"
Top = 960
Width = 2595
End
Begin Label lblLocPath
BackStyle = 0 'Transparent
BorderStyle = 1 'Fixed Single
Height = 555
Left = 600
TabIndex = 8
Top = 300
Visible = 0 'False
Width = 2175
WordWrap = -1 'True
End
Begin Label Label7
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Path:"
Height = 195
Left = 120
TabIndex = 7
Top = 360
Width = 465
End
End
Begin Frame RemoteFrame
BackColor = &H00C0C0C0&
Caption = "System"
Height = 1095
Left = 60
TabIndex = 12
Top = 0
Width = 6915
Begin TextBox txtStatus
BackColor = &H00C0C0C0&
Height = 555
Left = 780
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 6
Top = 480
Width = 5955
End
Begin Label lblIPAddress
BackStyle = 0 'Transparent
BorderStyle = 1 'Fixed Single
Height = 255
Left = 4620
TabIndex = 9
Top = 180
Width = 2115
End
Begin Label lblHostName
BackStyle = 0 'Transparent
BorderStyle = 1 'Fixed Single
Height = 255
Left = 1080
TabIndex = 10
Top = 180
Width = 1935
End
Begin Label Label3
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Status:"
Height = 195
Left = 120
TabIndex = 22
Top = 480
Width = 615
End
Begin Label Label2
BackStyle = 0 'Transparent
Caption = "IP &Address:"
Height = 255
Left = 3540
TabIndex = 0
Top = 240
Width = 1095
End
Begin Label Label1
BackStyle = 0 'Transparent
Caption = "&Hostname:"
Height = 255
Left = 120
TabIndex = 11
Top = 240
Width = 975
End
End
Begin CommandButton cmdShow
Caption = "Show"
Enabled = 0 'False
Height = 375
Left = 3000
TabIndex = 32
Top = 3540
Visible = 0 'False
Width = 1035
End
Begin CommandButton cmdDelete
Caption = "Delete"
Enabled = 0 'False
Height = 375
Left = 3000
TabIndex = 31
Top = 3120
Width = 1035
End
Begin CommandButton cmdRename
Caption = "Rename"
Enabled = 0 'False
Height = 375
Left = 3000
TabIndex = 30
Top = 2700
Width = 1035
End
Begin Menu FileMenu
Caption = "&File"
Begin Menu ExitApp
Caption = "E&xit"
End
End
Begin Menu mnuSession
Caption = "&Session"
Begin Menu mnuSessionConnect
Caption = "&Connect..."
End
Begin Menu mnuSessionDisconnect
Caption = "&Disconnect"
Enabled = 0 'False
End
Begin Menu mnuSessionChange
Caption = "C&hange Directory"
Enabled = 0 'False
End
End
Begin Menu mnuOpt
Caption = "&Options"
Begin Menu mnuOptPrompt
Caption = "&Prompts"
Checked = -1 'True
End
Begin Menu mnuOptAppend
Caption = "&Append if existing"
End
End
End
Option Explicit
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Const LB_SETHORIZONTALEXTENT = (WM_USER + 21)
'prevent listbox event cascade
Dim StopCascade As Integer
Sub btnCopy_Click ()
Dim strFilePath As String
Dim strFileName As String
Dim strFileNew As String
Dim strPathnew As String
Dim strFileLocal As String 'fully qualified with path
Dim strFileRemote As String 'fully qualified with path
Dim strDir As String 'which way do we go? text
Dim intDirection As Integer 'which way do we go? flag
Dim intLpCnt As Integer
Dim intMaxLp As Integer
Dim intNumDots As Integer
On Error Resume Next
intXferStop = False
'figure direction
intDirection = 1 'remote to local
strDir = "local"
strFileName = lstRemFiles.List(lstRemFiles.ListIndex)
strFilePath = lblRemPath.Caption
strPathnew = lblLocPath.Caption
intMaxLp = lstRemFiles.ListCount - 1
For intLpCnt = 0 To lstLocFiles.ListCount - 1
If lstLocFiles.Selected(intLpCnt) Then
intDirection = 0 'local to remote
strDir = "remote"
strFilePath = lblLocPath.Caption
strPathnew = lblRemPath.Caption
intMaxLp = lstLocFiles.ListCount - 1
Exit For
End If
Next intLpCnt
'disable buttons
btnCopy.Enabled = False
cmdDelete.Enabled = False
cmdRename.Enabled = False
'now go through and copy each file
For intLpCnt = 0 To intMaxLp
strFileName = ""
If intDirection = 0 Then
If lstLocFiles.Selected(intLpCnt) Then
strFileName = lstLocFiles.List(intLpCnt)
End If
Else
If lstRemFiles.Selected(intLpCnt) Then
strFileName = lstRemFiles.List(intLpCnt)
End If
End If
'verify that the file is not a directory
If Left$(strFileName, 1) = "<" Then
MsgBox "Cannot copy directories"
strFileName = ""
End If
If Left$(strFileName, 1) = "[" Then
MsgBox "Cannot copy drives"
strFileName = ""
End If
'prompt for file name
If strFileName <> "" Then
intNumDots = CountOf(strFileName, ".")
If intNumDots > 1 Then
strFileNew = Replace(strFileName, ".", "_", intNumDots - 1)
Else
strFileNew = strFileName
End If
strFileNew = Left$(GetField(strFileNew, 1, "."), 8)
If CountOf(strFileName, ".") > 0 Then
strFileNew = strFileNew & "." & Left$(GetField(strFileName, intNumDots + 1, "."), 3)
End If
End If
If mnuOptPrompt.Checked And strFileName <> "" Then
strFileNew = InputBox$("Please enter the name for the file '" & strFileName & "' on the " & strDir & " system", "VB FTP Copy", strFileNew)
End If
'call the proper get/put command
If strFileNew <> "" And strFileName <> "" Then
If intDirection = 0 Then
'put onto remote
'Me.MousePointer = 11
'filelocal will be strFilePath & strFileName
If Right$(strFilePath, 1) <> "\" Then
strFilePath = strFilePath & "\"
End If
strFileLocal = strFilePath & strFileName
'fileremote will be strPathNew & strFileNew
If InStr(strPathnew, "/") > 0 Then
If Right$(strPathnew, 1) <> "/" Then
strPathnew = strPathnew & "/"
End If
strFileRemote = strPathnew & strFileNew
Else
strFileRemote = strFileNew
End If
If Not (FTPPutFile(strFileLocal, strFileRemote, (mnuOptAppend.Checked))) And Not intXferStop Then
MsgBox "Could not copy to remote system."
End If
Me.MousePointer = 0
Else
'get from remote
'Me.MousePointer = 11
'fileremote will be strFilePath & strFileName
If InStr(strFilePath, "/") > 0 Then
If Right$(strFilePath, 1) <> "/" Then
strFilePath = strFilePath & "/"
End If
strFileRemote = strFilePath & strFileName
Else
strFileRemote = strFileName
End If
'fileLocal will be strPathNew & strFileNew
If Right$(strPathnew, 1) <> "\" Then
strPathnew = strPathnew & "\"
End If
strFileLocal = strPathnew & strFileNew
Kill strFileLocal
If Not (FTPGetFile(strFileRemote, strFileLocal)) And Not intXferStop Then
MsgBox "Could not copy to local system."
End If
Me.MousePointer = 0
End If
End If
If intXferStop Then Exit For
Next intLpCnt
If intDirection = 0 Then
FTPGetDirectory 'refresh remote files
Else
lblLocPath_change 'refresh local files
End If
btnCopy.Enabled = True
cmdDelete.Enabled = True
cmdRename.Enabled = True
End Sub
Sub cmdDelete_Click ()
Dim intDirection As Integer
Dim strFileNew As String
Dim strFileName As String
Dim strFilePath As String
Dim CtlData As String
Dim strCommand As String
Dim intRC As Integer
Dim intLpCnt As Integer
Dim intMaxLp As Integer
On Error Resume Next
'figure direction
intDirection = 1 'remote
strFilePath = lblRemPath.Caption
intMaxLp = lstRemFiles.ListCount - 1
For intLpCnt = 0 To lstLocFiles.ListCount - 1
If lstLocFiles.Selected(intLpCnt) Then
intDirection = 0 'local
strFilePath = lblLocPath.Caption
intMaxLp = lstLocFiles.ListCount - 1
Exit For
End If
Next intLpCnt
'now go through and delete each file
For intLpCnt = 0 To intMaxLp
strFileName = ""
If intDirection = 0 Then
If lstLocFiles.Selected(intLpCnt) Then
strFileName = lstLocFiles.List(intLpCnt)
End If
Else
If lstRemFiles.Selected(intLpCnt) Then
strFileName = lstRemFiles.List(intLpCnt)
End If
End If
'verify that the file is not a directory
If Left$(strFileName, 1) = "<" Then
MsgBox "Cannot delete directories"
strFileName = ""
End If
If Left$(strFileName, 1) = "[" Then
MsgBox "Cannot delete drives"
strFileName = ""
End If
If intDirection = 0 Then
If strFileName <> "" Then
If mnuOptPrompt.Checked Then
intRC = MsgBox("Are you sure you want to delete '" & strFileName & "'?", 1, "VB FTP Delete")
If intRC <> 1 Then Exit Sub
End If
'remove
If Right$(strFilePath, 1) <> "\" Then strFilePath = strFilePath & "\"
If CountOf(strFileNew, "\") = 0 Then strFileNew = strFilePath & strFileNew
Kill strFilePath & strFileName
End If
Else
If strFileName <> "" Then
If mnuOptPrompt.Checked Then
intRC = MsgBox("Are you sure you want to delete '" & strFileName & "'?", 1, "VB FTP Delete")
If intRC <> 1 Then Exit Sub
End If
'send the command DELE (DELETE) to remote
strCommand = "DELE " & strFileName
If Not ftpcommand(strCommand) Then
MsgBox "Error deleting remote file!"
Exit Sub
End If
'code 250 - removed file
If Left$(Str$(FTPResult(CtlData)), 3) <> " 25" Then
MsgBox "Error deleting remote file!"
Exit Sub
End If
End If
End If
Next intLpCnt
Me.MousePointer = 11
If intDirection = 0 Then
Call lblLocPath_change
Else
Call FTPGetDirectory
End If
Me.MousePointer = 0
btnCopy.Enabled = False
cmdRename.Enabled = False
cmdDelete.Enabled = False
cmdShow.Enabled = False
End Sub
Sub cmdLocRef_Click ()
Call lblLocPath_change
End Sub
Sub cmdRemRef_Click ()
Me.MousePointer = 11
Call FTPGetDirectory
Me.MousePointer = 0
btnCopy.Caption = "Copy"
btnCopy.Enabled = False
cmdRename.Enabled = False
cmdDelete.Enabled = False
cmdShow.Enabled = False
End Sub
Sub cmdRename_Click ()
Dim intDirection As Integer
Dim strFileNew As String
Dim strFileName As String
Dim strFilePath As String
Dim CtlData As String
Dim strCommand As String
Dim intLpCnt As Integer
Dim intMaxLp As Integer
'find out which side its on and rename it
On Error Resume Next
'figure direction
intDirection = 1 'remote
strFilePath = lblRemPath.Caption
intMaxLp = lstRemFiles.ListCount - 1
For intLpCnt = 0 To lstLocFiles.ListCount - 1
If lstLocFiles.Selected(intLpCnt) Then
intDirection = 0 'local
strFilePath = lblLocPath.Caption
intMaxLp = lstLocFiles.ListCount - 1
Exit For
End If
Next intLpCnt
For intLpCnt = 0 To intMaxLp
If intDirection = 0 Then
'get new name - dialog
strFileName = ""
If lstLocFiles.Selected(intLpCnt) Then
strFileName = lstLocFiles.List(intLpCnt)
End If
strFilePath = lblLocPath.Caption
strFileNew = strFileName
If strFileName <> "" Then
strFileNew = InputBox$("Please enter the new name for the file '" & strFileName & "' .", "VB FTP Rename", strFileNew)
End If
If strFileNew <> "" And strFileNew <> strFileName Then
'copy
If Right$(strFilePath, 1) <> "\" Then strFilePath = strFilePath & "\"
If CountOf(strFileNew, "\") = 0 Then strFileNew = strFilePath & strFileNew
Err = 0
FileCopy strFilePath & strFileName, strFileNew
'remove
If Err = 0 Then
Kill strFilePath & strFileName
Else
MsgBox "Could not copy file. Error - " & Error$
End If
End If
Else
strFileName = ""
If lstRemFiles.Selected(intLpCnt) Then
strFileName = lstRemFiles.List(intLpCnt)
End If
strFileNew = strFileName
If strFileName <> "" Then
strFileNew = InputBox$("Please enter the new name for the file '" & strFileName & "' .", "VB FTP Rename", strFileNew)
End If
If strFileNew <> "" And strFileNew <> strFileName Then
'send the command RNFR (RENAME FROM) to remote
strCommand = "RNFR " & strFileName
If Not ftpcommand(strCommand) Then
MsgBox "Error Renamimg remote file!"
Exit Sub
End If
'code 257 - got directory
If Left$(Str$(FTPResult(CtlData)), 3) <> " 35" Then
MsgBox "Error Renamimg remote file!"
Exit Sub
End If
'send the command RNFR (RENAME TO) to remote
strCommand = "RNTO " & strFileNew
If Not ftpcommand(strCommand) Then
MsgBox "Error Renamimg remote file!"
Exit Sub
End If
'code 257 - got directory
If Left$(Str$(FTPResult(CtlData)), 3) <> " 25" Then
MsgBox "Error Renamimg remote file!"
Exit Sub
End If
End If
End If
Next intLpCnt
Me.MousePointer = 11
If intDirection = 0 Then
Call lblLocPath_change
Else
Call FTPGetDirectory
End If
Me.MousePointer = 0
btnCopy.Enabled = False
cmdRename.Enabled = False
cmdDelete.Enabled = False
cmdShow.Enabled = False
End Sub
Sub cmdXferCancel_Click ()
If intXferStop Then Exit Sub
intXferStop = True
lblXferText.Caption = lblXferText.Caption & " Cancel Pressed!"
'frmClient.Socket1.Action = SOCKET_ABORT
'frmClient.Socket2.Action = SOCKET_ABORT
End Sub
Sub ExitApp_Click ()
Unload frmClient
End Sub
Sub Form_Activate ()
Dim intRC As Integer
intRC = SendMessage(lstRemFiles.hWnd, LB_SETHORIZONTALEXTENT, 500, 0)
intRC = SendMessage(lstLocFiles.hWnd, LB_SETHORIZONTALEXTENT, 500, 0)
End Sub
Sub Form_Load ()
Dim intLpCnt As Integer
Dim intMaxCnt As Integer
Dim intRC As Integer
Dim strEntry As String
Dim strMachine As String * 512
Dim strName As String
'get machine list from ini file
intRC = GetPrivateProfileString("Machine Count", "Counter", "", strMachine, 512, "vbftp.ini")
strName = Trim$(strMachine)
On Error Resume Next
intMaxCnt = Val(strName)
If Err <> 0 Then
intMaxCnt = 0
End If
'frmConnect.cboHostName.Clear
intMachineCnt = 0
For intLpCnt = 1 To intMaxCnt
strEntry = "Machine" & intLpCnt
strMachine = ""
intRC = GetPrivateProfileString("VBFTP", strEntry, "", strMachine, 512, "vbftp.ini")
strName = Trim$(strMachine)
If Asc(strName) = 0 Then
Exit For
Else
frmConnect.cboHostName.AddItem strName
intMachineCnt = intMachineCnt + 1
End If
strMachine = ""
Next intLpCnt
'set local directory
lblLocPath.Caption = CurDir$
StopCascade = False
End Sub
Sub Form_Resize ()
'if not minimizing then resize all controls
If Me.WindowState = WINSTATE_MINIMIZED Then Exit Sub
'if size is smaller than original, go to smallest
If Me.Width < 5625 Then Me.Width = 5625
If Me.Height < 3585 Then Me.Height = 3585
'width first
RemoteFrame.Width = Me.Width - 240
lblHostName.Width = (RemoteFrame.Width / 2) - lblHostName.Left - 240
label2.Left = (RemoteFrame.Width / 2) + 120
lblIPAddress.Left = label2.Left + label2.Width
lblIPAddress.Width = lblHostName.Width
txtStatus.Width = RemoteFrame.Width - txtStatus.Left - 120
fraLocalInfo.Width = (RemoteFrame.Width / 2) - (fraTransfer.Width / 2) - 120
txtLocDir.Width = fraLocalInfo.Width - txtLocDir.Left - 60
lstLocFiles.Width = fraLocalInfo.Width - lstLocFiles.Left - 60
cmdLocRef.Width = lstLocFiles.Width
fraTransfer.Left = fraLocalInfo.Left + fraLocalInfo.Width + 120
btnCopy.Left = fraTransfer.Left
cmdRename.Left = fraTransfer.Left
cmdDelete.Left = fraTransfer.Left
cmdShow.Left = fraTransfer.Left
fraRemote.Left = fraTransfer.Left + fraTransfer.Width + 120
fraRemote.Width = fraLocalInfo.Width
txtRemDir.Width = txtLocDir.Width
lstRemFiles.Width = lstLocFiles. |
