www.pudn.com > 020925_ftp.zip > fmVBFTPJR.frm
VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.2#0"; "comctl32.ocx"
Begin VB.Form fmVBFTPJR
Caption = "vbftpjr"
ClientHeight = 5640
ClientLeft = 60
ClientTop = 345
ClientWidth = 8715
LinkTopic = "Form1"
ScaleHeight = 5640
ScaleWidth = 8715
StartUpPosition = 3 'Windows Default
Begin VB.OptionButton optAscii
Caption = "Ascii"
Height = 195
Left = 3600
TabIndex = 20
Top = 3120
Width = 1095
End
Begin VB.OptionButton optBin
Caption = "Binary"
Height = 375
Left = 3600
TabIndex = 19
Top = 2640
Width = 855
End
Begin VB.CommandButton cmdPut
Caption = "<---Put<---"
Height = 495
Left = 3480
TabIndex = 18
Top = 3840
Width = 975
End
Begin VB.CommandButton cmdGet
Caption = "--->Get--->"
Height = 495
Left = 3480
TabIndex = 17
Top = 3360
Width = 975
End
Begin ComctlLib.TreeView TreeView1
Height = 2655
Left = 360
TabIndex = 16
Top = 2640
Width = 3015
_ExtentX = 5318
_ExtentY = 4683
_Version = 327682
Style = 7
Appearance = 1
End
Begin VB.FileListBox File1
Height = 2040
Left = 6960
TabIndex = 15
Top = 3120
Width = 1575
End
Begin VB.DirListBox Dir1
Height = 2115
Left = 5040
TabIndex = 14
Top = 3120
Width = 1695
End
Begin VB.DriveListBox Drive1
Height = 315
Left = 5040
TabIndex = 13
Top = 2640
Width = 3495
End
Begin VB.CheckBox chkPassive
Caption = "Passive FTP syntax"
Height = 255
Left = 3120
TabIndex = 12
Top = 1800
Width = 2175
End
Begin VB.CommandButton cmdDisconnect
Caption = "Disconnect"
Height = 495
Left = 5760
TabIndex = 11
Top = 1680
Width = 1815
End
Begin VB.CommandButton cmdConnect
Caption = "Connect"
Height = 495
Left = 360
TabIndex = 10
Top = 1680
Width = 2175
End
Begin VB.TextBox txtPassword
Height = 375
IMEMode = 3 'DISABLE
Left = 7200
PasswordChar = "*"
TabIndex = 9
Top = 1080
Width = 1095
End
Begin VB.TextBox txtUser
Height = 375
Left = 4680
TabIndex = 7
Top = 1080
Width = 1095
End
Begin VB.TextBox txtServer
Height = 375
Left = 1680
TabIndex = 4
Top = 1080
Width = 1455
End
Begin VB.CommandButton cmdClosehOpen
Caption = "Close Internet Session"
Height = 495
Left = 2280
TabIndex = 3
Top = 240
Width = 1935
End
Begin VB.TextBox txtProxy
Height = 435
Left = 7200
TabIndex = 1
Top = 240
Width = 1095
End
Begin VB.CommandButton cmdInternetOpen
Caption = "Start Internet Session"
Height = 495
Left = 240
TabIndex = 0
Top = 240
Width = 1935
End
Begin ComctlLib.ImageList ImageList1
Left = 2280
Top = 5160
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
MaskColor = 12632256
_Version = 327682
End
Begin VB.Label label4
Caption = "Password:"
Height = 255
Left = 6000
TabIndex = 8
Top = 1080
Width = 855
End
Begin VB.Label Label3
Caption = "User Name:"
Height = 255
Left = 3360
TabIndex = 6
Top = 1080
Width = 975
End
Begin VB.Label Label2
Caption = "FTP Server Name:"
Height = 255
Left = 120
TabIndex = 5
Top = 1080
Width = 1335
End
Begin VB.Line Line1
X1 = 240
X2 = 8520
Y1 = 840
Y2 = 840
End
Begin VB.Label Label1
Caption = "TIS Compatible Proxy (No CERN):"
Height = 255
Left = 4440
TabIndex = 2
Top = 360
Width = 2535
End
End
Attribute VB_Name = "fmVBFTPJR"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim bActiveSession As Boolean
Dim hOpen As Long, hConnection As Long
Dim dwType As Long
Dim EnumItemNameBag As New Collection
Dim EnumItemAttributeBag As New Collection
Private Sub Form_Load()
bActiveSession = False
hOpen = 0
hConnection = 0
chkPassive.Value = 1
optBin.Value = 1
dwType = FTP_TRANSFER_TYPE_BINARY
Dim imgI As ListImage
Set imgI = ImageList1.ListImages.Add(, "open", LoadPicture("open.bmp"))
Set imgI = ImageList1.ListImages.Add(, "closed", LoadPicture("closed.bmp"))
Set imgI = ImageList1.ListImages.Add(, "leaf", LoadPicture("leaf.bmp"))
Set imgI = ImageList1.ListImages.Add(, "root", LoadPicture("root.bmp"))
TreeView1.ImageList = ImageList1
TreeView1.Style = tvwTreelinesPictureText
EnableUI (False)
End Sub
Private Sub Form_Unload(Cancel As Integer)
cmdClosehOpen_Click
End Sub
Private Sub cmdInternetOpen_Click()
If Len(txtProxy.Text) <> 0 Then
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PROXY, txtProxy.Text, vbNullString, 0)
Else
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
End If
If hOpen = 0 Then ErrorOut Err.LastDllError, "InternetOpen"
EnableUI (True)
End Sub
Private Sub cmdClosehOpen_Click()
If hConnection <> 0 Then InternetCloseHandle (hConnection)
If hOpen <> 0 Then InternetCloseHandle (hOpen)
hConnection = 0
hOpen = 0
If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text
bActiveSession = False
ClearTextBoxAndBag
EnableUI (False)
End Sub
Private Sub cmdConnect_Click()
If Not bActiveSession And hOpen <> 0 Then
If txtServer.Text = "" Then
MsgBox "Please enter a server name!"
Exit Sub
End If
Dim nFlag As Long
If chkPassive.Value Then
nFlag = INTERNET_FLAG_PASSIVE
Else
nFlag = 0
End If
hConnection = InternetConnect(hOpen, txtServer.Text, INTERNET_INVALID_PORT_NUMBER, _
txtUser, txtPassword, INTERNET_SERVICE_FTP, nFlag, 0)
If hConnection = 0 Then
bActiveSession = False
ErrorOut Err.LastDllError, "InternetConnect"
Else
bActiveSession = True
EnableUI (CBool(hOpen))
FillTreeViewControl (txtServer.Text)
FtpEnumDirectory ("")
If EnumItemNameBag.Count = 0 Then Exit Sub
FillTreeViewControl (txtServer.Text)
End If
End If
End Sub
Private Sub cmdDisconnect_Click()
bDirEmpty = True
If hConnection <> 0 Then InternetCloseHandle hConnection
hConnection = 0
ClearBag
TreeView1.Nodes.Remove txtServer.Text
bActiveSession = False
EnableUI (True)
End Sub
Private Sub ClearTextBoxAndBag()
txtServer.Text = ""
txtUser.Text = ""
txtPassword.Text = ""
txtProxy.Text = ""
ClearBag
End Sub
Private Sub ClearBag()
Dim Num As Integer
For Num = 1 To EnumItemNameBag.Count
EnumItemNameBag.Remove 1
Next Num
For Num = 1 To EnumItemAttributeBag.Count
EnumItemAttributeBag.Remove 1
Next Num
End Sub
Private Sub FillTreeViewControl(strParentKey As String)
Dim nodX As Node
Dim strImg As String
Dim nCount As Integer, i As Integer
Dim nAttr As Integer
Dim strItem As String
If EnumItemNameBag.Count = 0 And strParentKey = txtServer.Text Then
Set nodX = TreeView1.Nodes.Add(, tvwFirst, txtServer.Text, txtServer.Text, "root")
Exit Sub
End If
nCount = EnumItemAttributeBag.Count
If nCount = 0 Then Exit Sub
For i = 1 To nCount
nAttr = EnumItemAttributeBag.Item(i)
strItem = EnumItemNameBag(i)
If nAttr = FILE_ATTRIBUTE_DIRECTORY Then
strImg = "closed"
Else
strImg = "leaf"
End If
Set nodX = TreeView1.Nodes.Add(strParentKey, tvwChild, strParentKey & "/" & strItem, _
strParentKey & "/" & strItem, strImg)
Next
nodX.EnsureVisible
End Sub
Private Sub cmdGet_Click()
Dim bRet As Boolean
Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
Dim szTempString As String
Dim nPos As Long, nTemp As Long
Dim nodX As Node
Set nodX = TreeView1.SelectedItem
If bActiveSession Then
If nodX Is Nothing Then
MsgBox "Please select the item to GET!"
Exit Sub
End If
szTempString = TreeView1.SelectedItem.Text
szFileRemote = szTempString
nPos = 0
nTemp = 0
Do
nTemp = InStr(1, szTempString, "/", vbBinaryCompare)
If nTemp = 0 Then Exit Do
szTempString = Right(szTempString, Len(szTempString) - nTemp)
nPos = nTemp + nPos
Loop
szDirRemote = Left(szFileRemote, nPos)
szFileRemote = Right(szFileRemote, Len(szFileRemote) - nPos)
szFileLocal = File1.Path
rcd szDirRemote
bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal & "/" & szFileRemote, False, _
INTERNET_FLAG_RELOAD, dwType, 0)
File1.Refresh
If bRet = False Then ErrorOut Err.LastDllError, "FtpGetFile"
Else
MsgBox "Not in session"
End If
End Sub
Private Sub cmdPut_Click()
Dim bRet As Boolean
Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
Dim szTempString As String
Dim nPos As Long, nTemp As Long
Dim nodX As Node
Set nodX = TreeView1.SelectedItem
If bActiveSession Then
If nodX Is Nothing Then
MsgBox "Please select a remote directory to PUT to!"
Exit Sub
End If
If nodX.Image = "leaf" Then
MsgBox "Please select a remote directory to PUT to!"
Exit Sub
End If
If File1.filename = "" Then
MsgBox "Please select a local file to put"
Exit Sub
End If
szTempString = nodX.Text
szDirRemote = Right(szTempString, Len(szTempString) - Len(txtServer.Text))
szFileRemote = File1.filename
szFileLocal = File1.Path & "\" & File1.filename
If (szDirRemote = "") Then szDirRemote = "\"
rcd szDirRemote
bRet = FtpPutFile(hConnection, szFileLocal, szFileRemote, _
dwType, 0)
If bRet = False Then
ErrorOut Err.LastDllError, "FtpPutFile"
Exit Sub
End If
Dim nodChild As Node, nodNextChild As Node
Set nodChild = nodX.Child
Do
If nodChild Is Nothing Then Exit Do
Set nodNextChild = nodChild.Next
TreeView1.Nodes.Remove nodChild.Index
If nodNextChild Is Nothing Then Exit Do
Set nodChild = nodNextChild
Loop
If nodX.Image = "closed" Then
nodX.Image = "open"
End If
FtpEnumDirectory (nodX.Text)
FillTreeViewControl (nodX.Text)
End If
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
On Error GoTo ErrProc
Dir1.Path = Drive1.Drive
Exit Sub
ErrProc:
Drive1.Drive = "c:"
Dir1.Path = Drive1.Drive
End Sub
Private Sub rcd(pszDir As String)
If pszDir = "" Then
MsgBox "Please enter the directory to CD"
Exit Sub
Else
Dim sPathFromRoot As String
Dim bRet As Boolean
If InStr(1, pszDir, txtServer.Text) Then
sPathFromRoot = Mid(pszDir, Len(txtServer.Text) + 1, Len(pszDir) - Len(txtServer.Text))
Else
sPathFromRoot = pszDir
End If
If sPathFromRoot = "" Then sPathFromRoot = "/"
bRet = FtpSetCurrentDirectory(hConnection, sPathFromRoot)
If bRet = False Then ErrorOut Err.LastDllError, "rcd"
End If
End Sub
Function ErrorOut(dError As Long, szCallFunction As String)
Dim dwIntError As Long, dwLength As Long
Dim strBuffer As String
If dError = ERROR_INTERNET_EXTENDED_ERROR Then
InternetGetLastResponseInfo dwIntError, vbNullString, dwLength
strBuffer = String(dwLength + 1, 0)
InternetGetLastResponseInfo dwIntError, strBuffer, dwLength
MsgBox szCallFunction & " Extd Err: " & dwIntError & " " & strBuffer
End If
If MsgBox(szCallFunction & " Err: " & dError & _
vbCrLf & "Close Connection and Session?", vbYesNo) = vbYes Then
If hConnection Then InternetCloseHandle hConnection
If hOpen Then InternetCloseHandle hOpen
hConnection = 0
hOpen = 0
If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text
bActiveSession = False
ClearTextBoxAndBag
EnableUI (False)
End If
End Function
Private Sub EnableUI(bEnabled As Boolean)
txtServer.Enabled = bEnabled
txtUser.Enabled = bEnabled
txtPassword.Enabled = bEnabled
cmdConnect.Enabled = bEnabled And Not bActiveSession
cmdDisconnect.Enabled = bEnabled And bActiveSession
chkPassive.Enabled = bEnabled
cmdClosehOpen.Enabled = bEnabled
cmdInternetOpen.Enabled = Not bEnabled
txtProxy.Enabled = Not bEnabled
optBin.Enabled = bEnabled
optAscii.Enabled = bEnabled
cmdGet.Enabled = bEnabled And bActiveSession
cmdPut.Enabled = bEnabled And bActiveSession
End Sub
Private Sub FtpEnumDirectory(strDirectory As String)
ClearBag
Dim hFind As Long
Dim nLastError As Long
Dim dError As Long
Dim ptr As Long
Dim pData As WIN32_FIND_DATA
If Len(strDirectory) > 0 Then rcd (strDirectory)
pData.cFileName = String(MAX_PATH, 0)
hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
nLastError = Err.LastDllError
If hFind = 0 Then
If (nLastError = ERROR_NO_MORE_FILES) Then
MsgBox "This directory is empty!"
Else
ErrorOut nLastError, "FtpFindFirstFile"
End If
Exit Sub
End If
dError = NO_ERROR
Dim bRet As Boolean
Dim strItemName As String
EnumItemAttributeBag.Add pData.dwFileAttributes
strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
EnumItemNameBag.Add strItemName
Do
pData.cFileName = String(MAX_PATH, 0)
bRet = InternetFindNextFile(hFind, pData)
If Not bRet Then
dError = Err.LastDllError
If dError = ERROR_NO_MORE_FILES Then
Exit Do
Else
ErrorOut dError, "InternetFindNextFile"
InternetCloseHandle (hFind)
Exit Sub
End If
Else
EnumItemAttributeBag.Add pData.dwFileAttributes
strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
EnumItemNameBag.Add strItemName
End If
Loop
InternetCloseHandle (hFind)
End Sub
Private Sub optAscii_Click()
dwType = FTP_TRANSFER_TYPE_ASCII
End Sub
Private Sub optBin_Click()
dwType = FTP_TRANSFER_TYPE_BINARY
End Sub
Private Sub TreeView1_DblClick()
Dim nodX As Node
Set nodX = TreeView1.SelectedItem
If Not bActiveSession Then
MsgBox "No in session!"
Exit Sub
End If
If nodX Is Nothing Then
MsgBox "no Selection to enumerate"
End If
If nodX.Image = "closed" Then
nodX.Image = "open"
FtpEnumDirectory (nodX.Text)
FillTreeViewControl (nodX.Text)
Else
If nodX.Image = "open" Then
nodX.Image = "closed"
Dim nodChild As Node, nodNextChild As Node
Set nodChild = nodX.Child
Do
Set nodNextChild = nodChild.Next
TreeView1.Nodes.Remove nodChild.Index
If nodNextChild Is Nothing Then Exit Do
Set nodChild = nodNextChild
Loop
End If
End If
End Sub