【VB】VisualFTP：演示如何通过管道与控制台程序交互
这是个FTP工具。这个程序写得很简单，功能并没有完全实现。源码演示如何通过STDIN和STDOUT控制一个程序。也就是相当于我给ftp.exe写了一个图形界面。
它的反应并不是很快，而且无法下载文件夹、无法上传文件夹、无法删除有内容的文件夹。只能对文件进行操作。
随时欢迎VB高手帮忙完善！
重要部分的代码：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这个程序因为是临时作品，我并没有给它写好注释，还请大家见谅。
BIN:
SRC: 我觉得它的亮点其实是左边和右边那个文件列表视图。那是用PictureBox画的。 嗯我调用CMD.EXE做的"远程终端"就是这么做的 不错，不过我更喜欢目录树形式的 请问怎么向管道发送crtl+z? FFFFFFFE 发表于 2015-5-30 11:48
请问怎么向管道发送crtl+z?
你先写个控制台程序判断Ctrl+Z是什么值，然后再用我这个源码发送那个值就行了。 过来学习下 下次我再写管道交互的话我不会再用这种一问一答方式了。 这 个很不错.可以借鉴给控制台程序写界面
论坛有你真的精彩~
页:
[1]