使用Pipe与CMD通信

瘋子愛老婆

rt

家里边网络坏了2天
本来早就写好了的

有点不解的地方就是
理论上应该可以和其他的cui通信，但是我失败了
而且执行其他程序大部分都是拒绝访问，何解？？

使用了管道技术和多线程，因为写的时候上不去网，所以手上也没多少资料，写的很烂，大家将就看吧。。。

btw:那2天没网络无聊。。写了n长的版权声明- -###（cls_PipeAccess.cls）

mThreadDoThis.bas: 引用:
Attribute VB_Name = "mThreadDoThis"
Option Explicit
Public myPipe As New cls_PipeAccess
Public Function GetPipeStr()
        '<EhHeader>
        On Error GoTo GetPipeStr_Err
        '</EhHeader>
100     With frmControl.txtOutput
102             .SelText = myPipe.GetStringFromPipe
104             .SelLength = 0
106             .Refresh
108             .SelStart = Len(.Text)  '自动卷屏
        End With
110     GetPipeStr '递归，反正俺多线程，readfile是同步的，俺不怕~哼哼。。。
        '不过貌似readfileex是异步的，可惜不知道那个函数的回调怎么声明参数 - -
        '<EhFooter>
        Exit Function
GetPipeStr_Err:
        MsgBox "#" & Err.Number & "(" & Err.Description & ")" & vbCrLf & _
                "错误发生于 Pipe_EG.mThreadDoThis.GetPipeStr " & "在 " & Erl & " 行."
        Resume Next
        '</EhFooter>
End Function
frmControl.frm: 引用:
VERSION 5.00
Begin VB.Form frmControl
   Caption         =   "控制台UI"
   ClientHeight    =   5640
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7110
   Icon            =   "frmControl.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   5640
   ScaleWidth      =   7110
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox txtOutput
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      BeginProperty Font
         Name            =   "Fixedsys"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   2895
      Left            =   0
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      TabIndex        =   2
      Top             =   0
      Width           =   4695
   End
   Begin VB.PictureBox Picture1
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   60
      Left            =   0
      ScaleHeight     =   30
      ScaleWidth      =   4665
      TabIndex        =   1
      Top             =   2880
      Width           =   4695
   End
   Begin VB.TextBox txtInput
      Appearance      =   0  'Flat
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      BeginProperty Font
         Name            =   "Fixedsys"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   375
      Left            =   0
      TabIndex        =   0
      Top             =   3000
      Width           =   4695
   End
End
Attribute VB_Name = "frmControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'终止线程API
Private Declare Function TerminateThread _
                Lib "kernel32" (ByVal hThread As Long, _
                                ByVal dwExitCode As Long) As Long
Private Declare Function GetCurrentThread _
                Lib "kernel32" () As Long
Private myThread As New cls_MultiThread
Private Const my_Program_Address As String = "cmd.exe"
Private Sub Form_Load()
        '<EhHeader>
        On Error GoTo Form_Load_Err
        '</EhHeader>
100     If myPipe.CreateProcessWithPipe(my_Program_Address) = False Then MsgBox "Error while creating process, program will terminate soon!": End
102     With myThread
104             .Initialize AddressOf GetPipeStr
106             .ThreadEnabled = True
        End With
        '<EhFooter>
        Exit Sub
Form_Load_Err:
        MsgBox "#" & Err.Number & "(" & Err.Description & ")" & vbCrLf & _
                "错误发生于 Pipe_EG.frmControl.Form_Load " & "在 " & Erl & " 行."
        Resume Next
        '</EhFooter>
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, _
                             UnloadMode As Integer)
        '<EhHeader>
        On Error GoTo Form_QueryUnload_Err
        '</EhHeader>
100         myThread.Terminate
102         myPipe.TerminateProcessAndClosePipe
104         Call TerminateThread(GetCurrentThread(), 0)
        '<EhFooter>
        Exit Sub
Form_QueryUnload_Err:
        MsgBox "#" & Err.Number & "(" & Err.Description & ")" & vbCrLf & _
               "错误发生于 Pipe_EG.frmControl.Form_QueryUnload " & _
               "在 " & Erl & " 行."
        Resume Next
        '</EhFooter>
End Sub
Private Sub Form_Resize()
    '<EhHeader>
    On Error Resume Next
    '</EhHeader>
        With Me
                txtOutput.Move 0, 0, .ScaleWidth, .ScaleHeight - txtInput.Height - _
                        Picture1.Height
                Picture1.Move -30, txtOutput.Height, .Width + 60
                txtInput.Move 0, txtOutput.Height + Picture1.Height, .ScaleWidth
        End With
End Sub
Private Sub txtInput_KeyUp(KeyCode As Integer, _
                           Shift As Integer)
        '<EhHeader>
        On Error GoTo txtInput_KeyUp_Err
        '</EhHeader>
100         If KeyCode = vbKeyReturn Then
102                 If LCase(txtInput) = "exit" Then Unload Me '不然cmd退了你不退你不就废了？
104                 Call myPipe.PutStringToPipe(txtInput & vbCrLf)
106                 DoEvents
108                 txtInput = ""
110                 DoEvents
            End If
        '<EhFooter>
        Exit Sub
txtInput_KeyUp_Err:
        MsgBox "#" & Err.Number & "(" & Err.Description & ")" & vbCrLf & _
               "错误发生于 Pipe_EG.frmControl.txtInput_KeyUp " & _
               "在 " & Erl & " 行."
        Resume Next
        '</EhFooter>
End Sub
cls_MultiThread.cls: 引用:
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cls_MultiThread"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'功能：创建多线程类，用于初始化线程。   类名：cls_Thread
'参数：LongPointFunction 用于接收主调过程传递过来的函数地址值
'调用方法：1.声明线程类对象变量 Dim mythread as cls_Thread
'          2.调用形式：With mythread
'                         .Initialize AddressOf 自定义过程或函数名 '(初始化线程) .
'                         .ThreadEnabled = True                  '(设置线程是否激活)
'                      End With
'          3.终止调用： Set mythread = Nothing
'   Crate By : 陈宇 On 2004.5.10     Copyright(C).Ldt By CY-soft 2001--2004
'   Email:4y4ycoco@163.com
'   Test On： VB6.0+Win98  AND  VB6.0+WinXP     It's Pass ！
Option Explicit
'创建线程API
'此API经过改造，lpThreadAttributes改为Any型，lpStartAddress改为传值引用：
'因为函数的入口地址由形参变量传递，如果用传址那将传递形参变量的地址而不是函数的入口地址
Private Declare Function CreateThread _
                Lib "kernel32" (ByVal lpThreadAttributes As Any, _
                                ByVal dwStackSize As Long, _
                                ByVal lpStartAddress As Long, _
                                lpParameter As Any, _
                                ByVal dwCreationFlags As Long, _
                                LpthreadId As Long) As Long
'终止线程API
Private Declare Function TerminateThread _
                Lib "kernel32" (ByVal hThread As Long, _
                                ByVal dwExitCode As Long) As Long
'激活线程API
Private Declare Function ResumeThread _
                Lib "kernel32" (ByVal hThread As Long) As Long
'挂起线程API
Private Declare Function SuspendThread _
                Lib "kernel32" (ByVal hThread As Long) As Long
Private Const CREATE_SUSPENDED = &H4    '线程挂起常量
'自定义线程结构类型
Private Type udtThread
        Handle As Long
        Enabled As Boolean
End Type
Private meTheard As udtThread
'初始化线程
Public Sub Initialize(ByVal LongPointFunction As Long)
        Dim LongStackSize As Long, LongCreationFlags As Long, LpthreadId As Long, _
                LongNull As Long
        On Error Resume Next
        LongNull = 0
        LongStackSize = 0
        LongCreationFlags = CREATE_SUSPENDED         '创建线程后先挂起，由程序激活线程
        '创建线程并返线程句柄
        meTheard.Handle = CreateThread(LongNull, LongStackSize, ByVal _
                LongPointFunction, LongNull, LongCreationFlags, LpthreadId)
        If meTheard.Handle = LongNull Then
                MsgBox "线程创建失败！", 48, "错误"
        End If
End Sub

'获取线程是否激活属性
Public Property Get ThreadEnabled() As Boolean
        On Error Resume Next
        ThreadEnabled = meTheard.Enabled
End Property
'设置线程是否激活属性
Public Property Let ThreadEnabled(ByVal Newvalue As Boolean)
        On Error Resume Next
        '若激活线程（Newvalue为真）设为TRUE且此线程原来没有激活时激活此线程
        If Newvalue And (Not meTheard.Enabled) Then
                ResumeThread meTheard.Handle
                meTheard.Enabled = True
        Else          '若激活线程（Newvalue为真）且此线程原来已激活则挂起此线程
                If meTheard.Enabled Then
                        SuspendThread meTheard.Handle
                        meTheard.Enabled = False
                End If
        End If
End Property
Public Sub Terminate()
        Class_Terminate
End Sub
'终止线程事件
Private Sub Class_Terminate()
        On Error Resume Next
        Dim ret&
        ret = TerminateThread(meTheard.Handle, 0)
End Sub
cls_PipeAccess.cls: 引用:
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cls_PipeAccess"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'=========================E N G L I S H  V E R S I O N=========================
'
'******************************************************************************
'* Created By 炉子[0GiNr] @ 8:03 2007-2-25                                    *
'* http://atleast.blog.cfan.com.cn [BLOG] | http://0ginr.com [0GiNr Team]     *
'******************************************************************************
'* Usage:                                                                     *
'* create instance: Dim myPipe As New cls_PipeAccess                          *
'* at first, u need to call [CreateProcessWithPipe] to create a process with  *
'* a redirect handle                                                          *
'* then, u can call [PutStringToPipe] to put string to process                *
'* or call [GetStringFromPipe] to get string that process has output          *
'* at last, u need to call [TerminateProcessAndClosePipe] to end the pipe call*
'******************************************************************************
'* enjoy it~                                                                  *
'******************************************************************************
'* under premise of non-bussines, u can copy or use this code freely, but if  *
'* u want to use this code for bussiness, u need to get author's permission   *
'******************************************************************************
'* no matter what situation u use this code, u must keep this announce full   *
'******************************************************************************
'
'=========================C H I N E S E  V E R S I O N=========================
'
'******************************************************************************
'* 本代码由 炉子[0GiNr] 创建于 8:03 2007-2-25                                 *
'* http://atleast.blog.cfan.com.cn [博客] | http://0ginr.com [0GiNr 团队]     *
'******************************************************************************
'* 使用方法:                                                                  *
'* 创建实例: Dim myPipe As New cls_PipeAccess                                 *
'* 在开始进行管道访问之前, 你需要调用 [CreateProcessWithPipe] 来创建一个有管道*
'* 重定向的程序                                                               *
'* 创建了具有管道重定向的程序之后, 你可以调用 [PutStringToPipe] 向程序发送信息*
'* 或者调用 [GetStringFromPipe] 来获取程序的输出信息                          *
'* 当你不再使用管道或是程序中止的时候, 你应调用 [TerminateProcessAndClosePipe]*
'* 来关闭管道并中止 [CreateProcessWithPipe] 所创建的进程                      *
'******************************************************************************
'* 玩的开心~                                                                  *
'******************************************************************************
'* 在非商业使用的前提下, 你可以随意的复制以及使用本代码,  但是当您想要将此代码*
'* 用于盈利, 您必须首先取得代码作者的同意                                     *
'******************************************************************************
'* 在任何情况下, 您都必须保持本声明完整                                       *
'******************************************************************************
'
'========================================C O D E  S T A R T  H E R E========================================
'=============================================代   码   开   始=============================================
'
Option Explicit
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 CreateProcess _
                Lib "kernel32" _
                Alias "CreateProcessA" (ByVal lpApplicationName As String, _
                                        ByVal lpCommandLine As String, _
                                        lpProcessAttributes As SECURITY_ATTRIBUTES, _
                                        lpThreadAttributes As SECURITY_ATTRIBUTES, _
                                        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 TerminateProcess _
                Lib "kernel32" (ByVal hProcess As Long, _

                                ByVal uExitCode As Long) As Long
Private Declare Function ReadFile _
                Lib "kernel32" (ByVal hFile As Long, _
                                ByVal lpBuffer As String, _
                                ByVal nNumberOfBytesToRead As Long, _
                                lpNumberOfBytesRead As Long, _
                                lpOverlapped As Any) As Long
Private Declare Function WriteFile _
                Lib "kernel32" (ByVal hFile As Long, _
                                ByVal lpBuffer As String, _
                                ByVal nNumberOfBytesToWrite As Long, _
                                lpNumberOfBytesWritten As Long, _
                                lpOverlapped As Any) As Long
Private Declare Function CloseHandle _
                Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetLastError _
                Lib "kernel32" () As Long
Private Declare Sub CopyMemory _
                Lib "kernel32" _
                Alias "RtlMoveMemory" (ByVal Destination As String, _
                                       ByVal Source As String, _
                                       ByVal Length As Long)
Private Declare Function lstrLen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type
Private Type PROCESS_INFORMATION
        hProcess As Long
        hThread As Long
        dwProcessId As Long
        dwThreadId 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 Const STARTF_USESTDHANDLES = &H100
Private Const STARTF_USESHOWWINDOW = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20
Dim hReadPipe As Long
Dim hWritePipe As Long
Dim hReadFile As Long
Dim hWriteFile As Long
Dim pi As PROCESS_INFORMATION
Public Function CreateProcessWithPipe(Optional ByVal FileName As String = "cmd.exe") As _
        Boolean
        On Error GoTo ErrHdl
        Dim ret&
        Dim sa As SECURITY_ATTRIBUTES
        With sa
                .nLength = Len(sa)
                .bInheritHandle = True
                .lpSecurityDescriptor = 0
        End With
        'create two pipe->one for input & output and another for err handle
        ret = CreatePipe(hReadPipe, hWriteFile, sa, 0&): If ret = 0 Then Call RaiseErr
        ret = CreatePipe(hReadFile, hWritePipe, sa, 0&): If ret = 0 Then Call RaiseErr
        'since now , we had create two pipes.
        Dim si As STARTUPINFO
        'fill start info
        With si
                .cb = Len(si)
                .hStdInput = hReadPipe
                .hStdOutput = hWritePipe
                .hStdError = hWritePipe
                'in fact. both error msg and normal msg r msg, so we can let then in a same handle
                .wShowWindow = 0 'hide it
                .dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW 'use handles, to make our hstd*** avable. use showwindow, to make our wShowWindow setting avable
        End With
        'createprocess----normally,it should be cmd.
        ret = CreateProcess(vbNullString, FileName, sa, sa, True, _
                NORMAL_PRIORITY_CLASS, 0&, App.Path, si, pi): If ret = 0 Then Call _
                RaiseErr
        CreateProcessWithPipe = True
        Exit Function
ErrHdl:
        CreateProcessWithPipe = False
End Function
Public Function PutStringToPipe(ByVal StrToPut As String) As Boolean
        On Error GoTo ErrHdl
        'most of time, u need to append a vbCrLf after the string u want to put.
        Dim ret&
        Dim lWrittenBytes As Long
        ret = WriteFile(hWriteFile, StrToPut, lstrLen(StrToPut), lWrittenBytes, ByVal 0&): If ret = 0 Then Call RaiseErr
        PutStringToPipe = (lWrittenBytes = Len(StrToPut))
        Debug.Print hWriteFile
        Exit Function
ErrHdl:
        PutStringToPipe = False
End Function
Public Function GetStringFromPipe() As String
        On Error GoTo ErrHdl
        Dim ret&
        Dim sBuffer As String
        Dim lRead As Long
        Dim sReturn As String
        sBuffer = Space$(4096)
        ret = ReadFile(hReadFile, sBuffer, Len(sBuffer), lRead, ByVal 0&)    'lRead is bytes that had read actully
        sReturn = Space$(lRead)
        CopyMemory sReturn, sBuffer, lRead
        GetStringFromPipe = sReturn
        Exit Function
ErrHdl:
        GetStringFromPipe = ""
End Function
Public Function TerminateProcessAndClosePipe() As Boolean
        On Error GoTo ErrHdl
        Dim ret&
        ret = TerminateProcess(pi.hProcess, 0): If ret = 0 Then Call RaiseErr
        ret = CloseHandle(hReadPipe): If ret = 0 Then Call RaiseErr
        ret = CloseHandle(hReadFile): If ret = 0 Then Call RaiseErr
        ret = CloseHandle(hWritePipe): If ret = 0 Then Call RaiseErr
        ret = CloseHandle(hWriteFile): If ret = 0 Then Call RaiseErr
        TerminateProcessAndClosePipe = True
        Exit Function
ErrHdl:
        TerminateProcessAndClosePipe = False
End Function
Private Sub RaiseErr()
        On Error Resume Next
        Err.Raise vbObjectError + 1 'raise an error so that to be caught by errhdl
End Sub
'
'=========================================C O D E   E N D   H E R E=========================================
'=============================================代   码   结   束=============================================
'

メ阿ǒ瑞メ

@,@..是什么意思呀？

timmy

看了楼主的帖子，我陷入了严肃的思考中。我认为，如果不把楼主的帖子顶上去，就是对真理的一种背叛，就是对谬论的极大妥协。因此，我决定义无返顾地顶了！

伟哥

那个贴子 让它沉下去吧！ 不要啦