综合

img limitworld

如何把用VB进行控制台命令的输入和输出.

发表于2004/11/1 18:06:00  3378人阅读

分类: VB

以下是我做的代码,
-----------------------------------------------------模块代码----------------------------------------------

Attribute VB_Name = "DosIo"
'私有的数据结构申明
Private Type STARTUPINFO '(createprocess)
    cb As Long
    lpReserved As Long
    lpDesktop As Long
    lpTitle As Long
    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 Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Private Type PROCESS_INFORMATION '(creteprocess)
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadID As Long
End Type
Private Type SECURITY_ATTRIBUTES '(createprocess)
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
'常数声明
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Const STARTF_USESHOWWINDOW = &H1
Private Const PROCESS_TERMINATE = &H1
Private Const PROCESS_QUERY_INFORMATION = &H400
'函数声明
Private Declare Function CreateProcessA Lib "kernel32" ( _
    ByVal lpApplicationName As Long, _
    ByVal lpCommandLine As String, _
    lpProcessAttributes As SECURITY_ATTRIBUTES, _
    lpThreadAttributes As SECURITY_ATTRIBUTES, _
    ByVal bInheritHandles As Long, _
    ByVal dwCreationFlags As Long, _
    ByVal lpEnvironment As Long, _
    ByVal lpCurrentDirectory As Long, _
    lpStartupInfo As STARTUPINFO, _
    lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function PeekNamedPipe Lib "kernel32" _
                          (ByVal hNamedPipe As Long, _
                           ByVal lpBuffer As Long, _
                           ByVal nBufferSize As Long, _
                           ByRef lpBytesRead As Long, _
                           ByRef lpTotalBytesAvail As Long, _
                           ByRef lpBytesLeftThisMessage As Long _
                           ) As Long

Private Declare Function CreatePipe Lib "kernel32" ( _
    phReadPipe As Long, _
    phWritePipe As Long, _
    lpPipeAttributes As Any, _
    ByVal nSize As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function ReadFile Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lpBuffer As Long, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    ByVal lpOverlapped As Any) As Long

Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hHandle As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, _
                                                   ByVal lpBuffer As Long, _
                                                   ByVal nNumberOfBytesToWrite As Long, _
                                                   ByRef lpNumberOfBytesWritten As Long, _
                                                   lpOverlapped As Any) 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 Const DUPLICATE_SAME_ACCESS = &H2
Private PipeR4InputChannel As Long, PipeW4InputChannel As Long, hInputHandle As Long
Private PipeR4OutputChannel As Long, PipeW4OutputChannel As Long, hOutputHandle As Long
Private Proc As PROCESS_INFORMATION
Public Enum InitResult
  ERROR_OK = 0
  ERROR_INIT_INPUT_HANDLE = 1
  ERROR_INIT_OUTPUT_HANDLE = 2
  ERROR_DUP_READ_HANDLE = 3
  ERROR_DUP_WRITE_HANDLE = 4
  ERROR_CREATE_CHILD_PROCESS = 5
End Enum

Public Enum TermResult
 ERROR_OK = 0
End Enum
Public Enum InputResult
 ERROR_OK = 0
 ERROR_QUERY_WRITE_INFO_SIZE = 1
 ERROR_DATA_TO_LARGE = 2
 ERROR_WRITE_INFO = 3
 ERROR_WRITE_UNEXPECTED = 5
End Enum
Public Enum OutputResult
 ERROR_OK = 0
 ERROR_QUERY_READ_INFO_SIZE = 1
 ERROR_ZERO_INFO_SIZE = 2
 ERROR_READ_INFO = 3
 ERROR_UNEQUAL_INFO_SIZE = 4
 ERROR_READ_UNEXPECTED = 5
End Enum
Public Function InitDosIO() As InitResult
   Dim Sa As SECURITY_ATTRIBUTES, Ret As Long
  
   With Sa
      .nLength = Len(Sa)
      .bInheritHandle = 1&
      .lpSecurityDescriptor = 0&
   End With
   
    Ret = CreatePipe(PipeR4InputChannel, PipeW4InputChannel, Sa, 1024&)
    If Ret = 0 Then '建立进程输入管道
        InitDosIO = ERROR_INIT_INPUT_HANDLE
        Exit Function
    End If
   
    Ret = CreatePipe(PipeR4OutputChannel, PipeW4OutputChannel, Sa, 4096&) '建立输出通道,若建立失败,则关闭管道,退出
    If Ret = 0 Then '建立进程的输出管道
        CloseHandle PipeR4InputChannel
        CloseHandle PipeW4InputChannel
        InitDosIO = ERROR_INIT_OUTPUT_HANDLE
        Exit Function
    End If
  

   Ret = DuplicateHandle(GetCurrentProcess(), PipeW4InputChannel, GetCurrentProcess(), hInputHandle, 0, True, DUPLICATE_SAME_ACCESS)
   If Ret = 0 Then '转换写句柄
     CloseHandle PipeR4InputChannel
     CloseHandle PipeW4InputChannel
     CloseHandle PipeR4OutputChannel
     CloseHandle PipeW4OutputChannel
     InitDosIO = ERROR_DUP_WRITE_HANDLE
     Exit Function
   End If
   Ret = CloseHandle(PipeW4InputChannel)
   If Ret = 0 Then
    MsgBox "close handle eerr"
   End If
  Ret = DuplicateHandle(GetCurrentProcess(), PipeR4OutputChannel, GetCurrentProcess(), hOutputHandle, 0, True, DUPLICATE_SAME_ACCESS)
   If Ret = 0 Then '转换读句柄
     CloseHandle PipeR4InputChannel
     CloseHandle PipeW4InputChannel
     CloseHandle PipeR4OutputChannel
     CloseHandle PipeW4OutputChannel
     InitDosIO = ERROR_DUP_READ_HANDLE
     Exit Function
   End If
 Ret = CloseHandle(PipeR4OutputChannel)
 If Ret = 0 Then
  MsgBox "close handle 2 er"
 End If
  
   
    Dim Start As STARTUPINFO, CmdStr As String
    Start.cb = Len(Start)
    Start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    Start.hStdOutput = PipeW4OutputChannel
    Start.hStdError = PipeW4OutputChannel
    Start.hStdInput = PipeR4InputChannel
    CmdStr = "CMD"
    Ret& = CreateProcessA(0&, CmdStr, Sa, Sa, True, NORMAL_PRIORITY_CLASS, 0&, 0&, Start, Proc)
   
    If Ret <> 1 Then '建立控制进程
        CloseHandle PipeR4InputChannel
        CloseHandle PipeW4InputChannel
        CloseHandle PipeR4OutputChannel
        CloseHandle PipeW4OutputChannel
        InitDosIO = ERROR_CREATE_CHILD_PROCESS
        Exit Function
    End If
   
End Function
Public Function DosInput(ByVal Str As String) As InputResult
 Dim Btarray  As String, Buflen As Long, BtWritten As Long, Rtn As Long
 Dim BtTest() As Byte
 Btarray = StrConv(Str + vbCrLf, vbFromUnicode)
 BtTest = StrConv(Str + vbCrLf, vbFromUnicode)
 Buflen = LenB(Btarray)
 Rtn = WriteFile(hInputHandle, StrPtr(BtTest), Buflen, BtWritten, ByVal 0&)
 
 If BtWritten = 0 Then
   DosInput = ERROR_WRITE_INFO
   Exit Function
 End If
 DosInput = 0
End Function

Public Function DosOutput(ByRef StrOutput As String) As OutputResult
  Dim Ret As Long, TmpBuf As String * 128, BtRead As Long, BtTotal As Long, BtLeft As Long
  Rtn = PeekNamedPipe(hOutputHandle, StrPtr(TmpBuf), 128, BtRead, BtTotal, BtLeft)
  If Rtn = 0 Then '查询信息量
    DosOutput = ERROR_QUERY_INFO_SIZE
    Exit Function
  End If
 
  If BtTotal = 0 Then '若信息为空,则退出
    DosOutput = ERROR_ZERO_INFO_SIZE
    Exit Function
  End If
 
  Dim Btbuf() As Byte, BtReaded As Long
  ReDim Btbuf(BtTotal)
  Ret = ReadFile(hOutputHandle, VarPtr(Btbuf(0)), BtTotal, lngbytesread, 0&)
 
  If Ret = 0 Then
    DosOutput = ERROR_READ_INFO
    Exit Function
  End If
  If BtTotal <> lngbytesread Then
   DosOutput = ERROR_UNEQUAL_INFO_SIZE
  End If
    
 Dim strBuf As String
 strBuf = StrConv(Btbuf, vbUnicode)
 Debug.Print strBuf
 StrOutput = strBuf
End Function
Public Function EndDosIo() As Long
 Dim Ret As Long
 CloseHandle PipeR4InputChannel
 CloseHandle PipeW4InputChannel
 CloseHandle PipeR4OutputChannel
 CloseHandle PipeW4OutputChannel
 CloseHandle Proc.hThread
 CloseHandle Proc.hProcess
If EndProcess(Proc.dwProcessId) = False Then
   MsgBox "主服务程序[CMD.EXE]没有关闭,请您手动关闭 ", vbInformation, "不好意思"
End If
End Function

Public Function EndProcess(ByVal ProcessID As Long) As Boolean
  Dim hProcess As Long, ExitCode As Long, Rst As Long
  hProcess = OpenProcess(PROCESS_TERMINATE Or PROCESS_QUERY_INFORMATION, True, ProcessID)
   If hProcess <> 0 Then
     GetExitCodeProcess hProcess, ExitCode
     If ExitCode <> 0 Then
       Rst = TerminateProcess(hProcess, ExitCode)
       CloseHandle hProcess
        If Rst = 0 Then

         EndProcess = False
        Else
         EndProcess = True
        End If
     Else
       EndProcess = False
     End If
   Else
     EndProcess = False
   End If
 
End Function
------------------------------------------------------窗体代码---------------------------------------
VERSION 5.00
Begin VB.Form Form1
   BorderStyle     =   1  'Fixed Single
   Caption         =   "控制台管道重定向 "
   ClientHeight    =   4620
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   8820
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   4620
   ScaleWidth      =   8820
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdget
      Caption         =   "获取控制台输出字符 "
      BeginProperty Font
         Name            =   "宋体"
         Size            =   9.75
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   360
      Left            =   1830
      TabIndex        =   4
      Top             =   4245
      Width           =   4575
   End
   Begin VB.CommandButton cmdExe
      Caption         =   "命令写入控制台"
      BeginProperty Font
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   6720
      TabIndex        =   3
      Top             =   105
      Width           =   1800
   End
   Begin VB.TextBox TxtOutput
      BackColor       =   &H00404040&
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000005&
      Height          =   3615
      Left            =   0
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   2
      Top             =   540
      Width           =   8775
   End
   Begin VB.TextBox TxtExecute
      BackColor       =   &H00404040&
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   375
      Left            =   1320
      TabIndex        =   0
      Top             =   120
      Width           =   5295
   End
   Begin VB.Label Label1
      Caption         =   "命令输入:"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   120
      TabIndex        =   1
      Top             =   120
      Width           =   855
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False


Private Sub Cmdexe_Click()
 Dim Ret As Long, StrExe As String
 
 StrExe = TxtExecute.Text
 If Len(StrExe) = 0 Then
  MsgBox "命令怎么为空呢?", vbInformation, "奇怪?"
  Exit Sub
 End If
 
 Ret = DosInput(StrExe)
 
 If Ret <> 0 Then
  
   'MsgBox "在写入控制台管道的时候出现错误", vbInformation, "错误"
   Exit Sub
 End If
 sw False
End Sub

Private Sub Cmdget_Click()
  Dim strR As String
 Ret = DosOutput(strR)
 If Ret = 0 Then
  TxtOutput.Text = strR
 Else
  MsgBox "读取控制台输出错误", vbInformation, "错误"
 End If
 sw True
End Sub

Private Sub Form_Load()
 Dim Ret As Long
 Ret = InitDosIO()
 If Ret <> 0 Then
   MsgBox "控制台输入输出管道重定向初始化失败"
   End
 End If
 sw True
End Sub

Private Sub Form_Unload(Cancel As Integer)
 EndDosIo
End Sub
Private Sub sw(ByVal s As Boolean)
  cmdExe.Enabled = s
  cmdget.Enabled = Not s
End Sub
运行平台:2000/XP/稍微修改可用于98

阅读全文
0 0

相关文章推荐

img
取 消
img