UID 1 精华 244
积分 75910 威望 743 点
宅币 24221 个
贡献 46222 次
宅之契约 0 份
最后登录 2024-4-18
在线时间 2296 小时
QQ
用户组: 管理员
一只技术宅
UID 1 精华 244 威望 743 点
宅币 24221 个
贡献 46222 次
宅之契约 0 份
在线时间 2296 小时
注册时间 2014-1-26
这是个FTP工具。
Attribute VB_Name = "FTPOperation" Option Explicit '安全属性 Private Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Long End Type '启动信息 Private Type STARTUPINFO cb As Long lpReserved As String lpDesktop As String lpTitle As String dwX As Long dwY As Long dwXSize As Long dwYSize As Long dwXCountChars As Long dwYCountChars As Long dwFillAttribute As Long dwFlags As Long wShowWindow As Integer cbReserved2 As Integer lpReserved2 As Long hStdInput As Long hStdOutput As Long hStdError As Long End Type '进程信息 Private Type PROCESS_INFORMATION hProcess As Long hThread As Long dwProcessId As Long dwThreadId As Long End Type '重叠 Private Type OVERLAPPED Internal As Long InternalHigh As Long offset As Long OffsetHigh As Long hEvent As Long End Type '一些基本的API Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function GetLastError Lib "kernel32" () As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) '启动信息属性 Private Const STARTF_USESHOWWINDOW = &H1 Private Const STARTF_USESTDHANDLES = &H100 '启动窗口的属性 Private Const SW_HIDE = 0 '进程状态 Private Const STATUS_PENDING = &H103& Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long '句柄控制 Private Const DUPLICATE_SAME_ACCESS = &H2 Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long Private Declare Function PeekNamedPipe Lib "kernel32" (ByVal hNamedPipe As Long, lpBuffer As Any, ByVal nBufferSize As Long, lpBytesRead As Long, lpTotalBytesAvail As Long, lpBytesLeftThisMessage As Long) As Long Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long Private Declare Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 'FTP进程信息 Global FTPProcInfo As PROCESS_INFORMATION 'FTP.exe的StdIn的写句柄和StdOut的读句柄 Global hChildIn As Long, hChildOut As Long '从FTP.exe的StdOut读取的字符串，和字符串大小 Global StrBuf() As Byte, cbStrBuf As Long '主机、用户名、密码 Global Host As String, Username As String, Password As String Global CurPath As String '当前操作的远程路径 Global LastStatus As String, LastContactTime As Single '最后状态、最后交互时间 Global LastFile As String '最后操作的文件 Global Script As String, ScriptSetPW As Boolean '登录脚本文件地址、是否通过这个脚本输入账号密码 '是不是错误地关闭了、操作后是否刷新 Global CloseOnError As Boolean Type CmdType Cmd As String Stt As String End Type Global Commands() As CmdType, NbCommands As Long '启动FTP.exe进程，并对其进行控制 Sub StartProc() Dim SecAttr As SECURITY_ATTRIBUTES '安全属性 SecAttr.nLength = Len(SecAttr) SecAttr.bInheritHandle = True '承接句柄 SecAttr.lpSecurityDescriptor = 0 '创建StdIn的管道 Dim StdInR As Long, StdInW As Long If CreatePipe(StdInR, StdInW, SecAttr, 0) = 0 Then AddLog "StdIn pipe creation failed:" & GetLastError End If '创建StdOut的管道 Dim StdOutR As Long, StdOutW As Long If CreatePipe(StdOutR, StdOutW, SecAttr, 0) = 0 Then AddLog "StdOut pipe creation failed:" & GetLastError End If '启动信息 Dim StartInfo As STARTUPINFO StartInfo.cb = Len(StartInfo) StartInfo.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW '修改管道和窗口方式 StartInfo.wShowWindow = SW_HIDE '隐藏FTP.exe的窗口 StartInfo.hStdInput = StdInR '改变其控制台管道 StartInfo.hStdOutput = StdOutW StartInfo.hStdError = StdOutW hChildIn = StdInW '这是留给我们来操作的管道句柄 hChildOut = StdOutR LastStatus = "START" '当前状态：启动 LastContactTime = Timer '最后一次发送命令的时间。 '用来登录的脚本。貌似WriteStr无法填写密码 '因此采用这种方式登录 Script = App.Path & "\script.txt" Open Script For Output As #1 Print #1, Username '写入用户名 Print #1, Password '写入密码 Close #1 ScriptSetPW = True '创建进程 If CreateProcess(vbNullString, "ftp -v -s:" & Script & " " & Host, ByVal 0, ByVal 0, True, 0, ByVal 0, vbNullString, StartInfo, FTPProcInfo) = 0 Then MsgBox "创建FTP进程失败。", vbCritical End If LastStatus = "OPEN" '关闭我们不需要的句柄 CloseHandle StdInR CloseHandle StdOutW End Sub '结束FTP进程 Sub EndProc() If hChildIn Then CloseHandle hChildIn If hChildOut Then CloseHandle hChildOut If FTPProcInfo.hProcess Then AddLog "Task killed." TerminateProcess FTPProcInfo.hProcess, 0 '结束进程 CloseHandle FTPProcInfo.hProcess End If If FTPProcInfo.hThread Then CloseHandle FTPProcInfo.hThread hChildIn = 0 hChildOut = 0 FTPProcInfo.hProcess = 0 FTPProcInfo.hThread = 0 LastStatus = "" If CloseOnError Then MsgBox "连接已经中断。" '如果是出着错退出的，提示用户 If frmMain.Conn Then frmMain.cmdConnect_Click End If CloseOnError = False End Sub '发送命令 Sub SendCommand(ByVal Cmd As String, ByVal Status As String) If LastStatus = "" Then CheckRun If NbCommands Then ReDim Preserve Commands(NbCommands) Else ReDim Commands(NbCommands) End If Commands(NbCommands).Cmd = Cmd Commands(NbCommands).Stt = Status NbCommands = NbCommands + 1 End Sub '将下一个命令写入到FTP进程的StdIn管道 Function WriteNextCommand() As Boolean If NbCommands Then WriteNextCommand = WriteStr(hChildIn, Commands(0).Cmd) LastStatus = Commands(0).Stt NbCommands = NbCommands - 1 If NbCommands Then Dim I& For I = 1 To NbCommands Commands(I - 1) = Commands(I) Next ReDim Preserve Commands(NbCommands - 1) Else Erase Commands End If End If End Function '写入字符串到FTP进程的StdIn管道 Private Function WriteStr(ByVal Handle As Long, Str_ As String) As Boolean CheckRun Dim StrMB() As Byte, NbWrite As Long AddLog Str_ StrMB = StrConv(Str_ & vbCrLf, vbFromUnicode) WriteStr = WriteFile(Handle, StrMB(0), UBound(StrMB) + 1, NbWrite, ByVal 0) LastContactTime = Timer End Function '检查是否已经运行FTP.exe，如果没有则启动它 Sub CheckRun() Dim ExitCode As Long If FTPProcInfo.hProcess Then If GetExitCodeProcess(FTPProcInfo.hProcess, ExitCode) Then If ExitCode <> STATUS_PENDING Then StartProc Else StartProc End If Else StartProc End If End Sub '打开FTP服务器。 Sub OpenFTP() '不知道为毛非得先写一个回车到StdIn才能启动进程 WriteStr hChildIn, vbCrLf SendCommand "binary", "SETBIN" SendCommand "quote pasv", "SETPASV" DirList End Sub '取得当前目录 Sub GetCurDir() SendCommand "pwd", "GETCUR" End Sub '显示目录 Sub DirList() SendCommand "dir", "DIR" End Sub '切换文件夹 Sub ChangeDir(ByVal Target As String) SendCommand "cd " & Target, "CD" End Sub '创建文件夹 Sub MakeDir(ByVal DirName As String) SendCommand "mkdir " & DirName, "MKDIR" End Sub '移除文件夹 Sub RemoveDir(ByVal DirName As String) SendCommand "rmdir " & DirName, "RMDIR" End Sub '上传文件 Sub PutFile(ByVal LocalPath As String, ByVal RemotePath As String) SendCommand "put " & LocalPath & " " & RemotePath, "PUT" End Sub '下载文件 Sub GetFile(ByVal RemotePath As String, ByVal LocalPath As String) SendCommand "get " & RemotePath & " " & LocalPath, "GET" End Sub '移除文件 Sub DelFile(ByVal FilePath As String) SendCommand "del " & FilePath, "DEL" End Sub '关闭连接 Sub CloseFTP(ByVal OnError As Boolean) CloseOnError = OnError LastStatus = "CLOSE" WriteStr hChildIn, "close" Erase Commands NbCommands = 0 End Sub '清空文件夹 Sub ClearDir() Dim I& For I = 0 To NbFList - 1 If FList(I).IsDir = False And FList(I).IsLink = False Then DelFile FList(I).FileName Next End Sub '检查FTP.exe对StdOut的输出，然后将内容读取到StrBuf Function CheckToBuf(ByVal Handle As Long) As String Dim NbTobeRead As Long, NbGot As Long PeekNamedPipe Handle, ByVal 0, 0, 0, NbTobeRead, ByVal 0 If NbTobeRead Then If cbStrBuf Then ReDim Preserve StrBuf(cbStrBuf + NbTobeRead - 1) Else ReDim StrBuf(NbTobeRead - 1) End If ReadFile Handle, StrBuf(cbStrBuf), NbTobeRead, NbGot, ByVal 0 cbStrBuf = cbStrBuf + NbTobeRead End If CheckBuf End Function '检查StrBuf，如果它包含了一个完整的行，则将其取出并分析。 Sub CheckBuf() Dim I&, J&, K&, S$ If cbStrBuf Then I = GetLfFromMB(StrBuf) If I Then Dim SingleLine() As Byte ReDim SingleLine(I) CopyMemory SingleLine(0), StrBuf(0), I + 1 For J = I + 1 To cbStrBuf - 1 StrBuf(K) = StrBuf(J) K = K + 1 Next cbStrBuf = K If cbStrBuf Then ReDim Preserve StrBuf(cbStrBuf - 1) Else Erase StrBuf End If S = StrConv(SingleLine, vbUnicode) S = Left$(S, Len(S) - 2) If Right$(S, 1) = vbCr Then S = Left$(S, Len(S) - 1) ProcLine S End If End If If LastStatus = "OK" Or LastStatus = "FAILED" Then '如果有空 WriteNextCommand '写入下一条命令 End If If LastStatus <> "OK" And LastStatus <> "PUTTING" And LastStatus <> "GETTING" And Timer - LastContactTime >= 3 Then '三秒超时 AddLog "No response." CloseOnError = True EndProc End If If LastStatus = "CLOSED" Then If frmMain.Conn Then frmMain.cmdConnect_Click EndProc End If End Sub '处理一行消息。 Sub ProcLine(LineStr As String) On Error Resume Next AddLog LineStr LastContactTime = Timer If CLng(Val(LineStr)) = 421 Then '如果已经超时 EndProc OpenFTP Exit Sub End If If Len(LineStr) = 0 Then Exit Sub Debug.Print LastStatus, LineStr Select Case LastStatus Case "" '无状态 '什么也不做 Case "OPEN" '打开服务器 If InStr(LineStr, "220") Then '显示欢迎信息 LastStatus = "LOGIN1" '输入用户名状态 If Not ScriptSetPW Then WriteStr hChildIn, Username & vbCrLf ElseIf InStr(LineStr, "250") Then '消息 Else LastStatus = "UNKNOWN" End If Case "LOGIN1" '输入用户名后 If InStr(LineStr, "220") Then '仍然在显示欢迎信息 ElseIf InStr(LineStr, "331") Then '输入密码的状态 If Not ScriptSetPW Then WriteStr hChildIn, Password & vbCrLf LastStatus = "LOGIN2" ElseIf InStr(LineStr, "250") Then '消息 Else LastStatus = "UNKNOWN" End If Case "LOGIN2" '输入密码后 If InStr(LineStr, "230") Then '登录成功 LastStatus = "OK" Kill Script '删除登录脚本文件，以免泄露用户名密码，虽说本程序本来就不安全 ScriptSetPW = False ElseIf InStr(LineStr, "250") Then '消息 Else LastStatus = "UNKNOWN" End If Case "SETBIN" '设置二进制传输 If InStr(LineStr, "200") Then '命令成功 LastStatus = "OK" ElseIf InStr(LineStr, "250") Then '消息 Else LastStatus = "UNKNOWN" End If Case "SETPASV" '设置被动模式 If InStr(LineStr, "227") Then '命令成功 LastStatus = "OK" Else LastStatus = "UNKNOWN" End If Case "GETCUR" '取得当前路径 If InStr(LineStr, "257") Then '命令成功 CurPath = GetQuote(LineStr) frmMain.txtCurDir.Text = CurPath '显示到主窗体 LastStatus = "OK" ElseIf InStr(LineStr, "250") Then '消息 Else LastStatus = "UNKNOWN" End If Case "CD" '切换目录 If InStr(LineStr, "250") Then LastStatus = "OK" ElseIf InStr(LineStr, "550") Then LastStatus = "FAILED" '切换目录失败 Else LastStatus = "UNKNOWN" End If Case "MKDIR" '创建文件夹 If InStr(LineStr, "257") Then LastStatus = "OK" ElseIf InStr(LineStr, "550") Then LastStatus = "FAILED" '创建文件夹失败 ElseIf InStr(LineStr, "250") Then '消息 Else LastStatus = "UNKNOWN" End If Case "RMDIR" '移除文件夹 If InStr(LineStr, "250") Then LastStatus = "OK" ElseIf InStr(LineStr, "550") Then LastStatus = "FAILED" '删除文件夹失败 Else LastStatus = "UNKNOWN" End If Case "DEL" '删除文件 If InStr(LineStr, "250") Then LastStatus = "OK" ElseIf InStr(LineStr, "550") Then LastStatus = "FAILED" '删除文件失败 Else LastStatus = "UNKNOWN" End If Case "PUT" '上传文件 If InStr(LineStr, "200") Then 'PORT命令成功 ElseIf InStr(LineStr, "150") Then '开始传送 LastStatus = "PUTTING" ElseIf InStr(LineStr, "550") Then '上传失败 LastStatus = "FAILED" ElseIf InStr(LineStr, "250") Then '消息 Else LastStatus = "UNKNOWN" End If Case "PUTTING" '正在上传文件 If InStr(LineStr, "226") Then '上传成功 LastStatus = "OK" ElseIf InStr(LineStr, "250") Then '消息 ElseIf InStr(LineStr, "550") Then '上传失败 LastStatus = "FAILED" Else LastStatus = "UNKNOWN" End If Case "GET" '下载文件 If InStr(LineStr, "200") Then 'PORT命令成功 ElseIf InStr(LineStr, "150") Then '开始传送 LastStatus = "GETTING" ElseIf InStr(LineStr, "550") Then '下载失败 LastStatus = "FAILED" ElseIf InStr(LineStr, "250") Then '消息 Else LastStatus = "UNKNOWN" End If Case "GETTING" '正在下载文件 If InStr(LineStr, "226") Then '上传成功 LastStatus = "OK" ElseIf InStr(LineStr, "250") Then '消息 ElseIf InStr(LineStr, "550") Then '下载失败 LastStatus = "FAILED" Else LastStatus = "UNKNOWN" End If Case "DIR" '列出目录 If InStr(LineStr, "200") Then 'PORT命令成功 ElseIf InStr(LineStr, "250") Then '消息 ElseIf InStr(LineStr, "150") Then '传输目录成功 LastStatus = "DIROK" ClearFileList Else LastStatus = "UNKNOWN" End If Case "DIROK" '传输目录成功 'If LineStr Like "?????????? * * * * * * ??:?? *" Then '如果看起来是目录格式 If InStr(LineStr, "226") Then '命令成功 LastStatus = "OK" ElseIf InStr(LineStr, "250") Then '消息 Else ParseFListString LineStr frmMain.UpdateFileList End If Case "CLOSE" '关闭连接 If InStr(LineStr, "221") Then '关闭成功 LastStatus = "CLOSED" ElseIf InStr(LineStr, "250") Then '消息 Else LastStatus = "CLOSED" End If End Select End Sub 复制代码
VisualFTP.7z
(22.21 KB, 下载次数: 8)
VisualFTP_Src.7z
(33.99 KB, 下载次数: 12, 售价: 10 个宅币)
|Archiver|小黑屋|技术宅的结界
( 滇ICP备16008837号 )|网站地图
发表于 2015-2-11 17:17:04
发表于 2015-2-11 17:37:52
