高分求教：如何做一个命令行程序壳？

'上面是公共部分.



Private Sub Form_Load()

    txtCommand.Text = ""

    txtMessage.Text = ""

    txtMessage.Locked = True

    

    ' 创建管道

    CreatePipe hReadPipe, hWritePipe, ByVal 0, ByVal 0

    CreatePipe hChildReadPipe, hChildWritePipe, ByVal 0, ByVal 0

    SetHandleInformation hWritePipe, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT

    SetHandleInformation hChildReadPipe, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT

    Dim dwMode As Long

    dwMode = PIPE_NOWAIT

    SetNamedPipeHandleState hReadPipe, dwMode, ByVal 0, ByVal 0

    

    ' 创建CMD进程

    Dim stProcessInfo As PROCESS_INFORMATION

    Dim stStartInfo As STARTUPINFO

    stStartInfo.cb = LenB(stStartInfo)

    stStartInfo.dwFlags = STARTF_USESTDHANDLES

    stStartInfo.hStdError = hWritePipe

    stStartInfo.hStdOutput = hWritePipe

    stStartInfo.hStdInput = hChildReadPipe

    

    Dim strExe As String

    strExe = "cmd"

    If False = CreateProcess(ByVal vbNullString, ByVal strExe, ByVal 0, ByVal 0, ByVal True, ByVal DETACHED_PROCESS, ByVal 0, ByVal vbNullString, stStartInfo, stProcessInfo) Then

        MsgBox "启动进程失败!"

        Exit Sub

    Else

        CloseHandle stProcessInfo.hThread

        CloseHandle stProcessInfo.hProcess

    End If

    ReadFromChildPipe

End Sub



Private Sub Form_Unload(Cancel As Integer)

    CloseHandle hReadPipe

    CloseHandle hWritePipe

    CloseHandle hChildReadPipe

    CloseHandle hChildWritePipe

End Sub



Private Sub txtCommand_KeyPress(KeyAscii As Integer)

    If KeyAscii = vbKeyReturn Then

        Dim nWrite As Long

        Dim strBuffer As String

        strBuffer = txtCommand.Text & vbCrLf

        Dim bResult As Boolean

        bResult = WriteFile(ByVal hChildWritePipe, ByVal strBuffer, ByVal Len(strBuffer), nWrite, ByVal 0)

        If bResult = True Then

            ReadFromChildPipe

        Else

            MsgBox "写入失败."

        End If

        txtCommand.Text = ""

    End If

End Sub



Private Sub ReadFromChildPipe()

    Dim nRead As Long

    Dim strBuffer As String

    Dim nBufferLen As Long

    nRead = -1

    Do While nRead <> 0

        nBufferLen = 65536

        strBuffer = String(nBufferLen, Chr(0))

        Sleep 10

        ReadFile hReadPipe, ByVal strBuffer, ByVal nBufferLen, nRead, ByVal 0

        Sleep 10

        If nRead <> 0 Then

            strBuffer = Left(strBuffer, nRead)

            txtMessage.Text = txtMessage.Text & strBuffer

            txtMessage.SelStart = Len(txtMessage.Text)

        End If

    Loop

End Sub

'新建工程,添加两个文本框txtMessage与txtCommand.

'前者的MultLine=True,用于显示命令行程序的回显;

'后者用于输入命令.

Option Explicit



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 CloseHandle Lib "kernel32" (ByVal hObject 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 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 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 SetHandleInformation Lib "kernel32" (ByVal hObject As Long, ByVal dwMask As Long, ByVal dwFlags As Long) As Long

Private Declare Function SetNamedPipeHandleState Lib "kernel32" (ByVal hNamedPipe As Long, lpMode As Long, lpMaxCollectionCount As Long, lpCollectDataTimeout As Long) As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)



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 Const STARTF_USESTDHANDLES = &H100

Private Const HANDLE_FLAG_INHERIT = 1

Private Const DETACHED_PROCESS = &H8

Private Const PIPE_NOWAIT = &H1



Dim hReadPipe As Long

Dim hWritePipe As Long

Dim hChildReadPipe As Long

Dim hChildWritePipe As Long

Option Explicit



Private Sub Command1_Click()



    Call GetMacAddress



End Sub



Function GetMacAddress() As String



    Dim i&, j&, OutChar$

    Dim fn As Byte, pos1&, pos2&, ArrayChar$(1)



    '输出IP信息

    Shell "cmd  /c  ipconfig/all >  C:\Ping", vbHide

    fn = FreeFile



RETRY:



    Open "c:\ping" For Binary Access Read As #fn

    

    OutChar$ = Space$(FileLen("c:\ping"))

    '读取IP信息

    Get #fn, , OutChar$



    Close #fn



    If Len(OutChar$) = 0 Then GoTo RETRY

    

    '搜索Physical Address

    pos1 = InStr(OutChar$, "Physical Address")



    Do While pos1 <> 0

        

        '搜索:标志

        pos2 = InStr(pos1, OutChar$, ":")

        '取MAC Address, 长度18

        ArrayChar(j) = Mid$(OutChar$, pos2 + 1, 18)

        '判断是否有多个网卡

        pos1 = InStr(pos2, OutChar$, "Physical Address")

        If pos1 <> 0 Then j = j + 1



    Loop



    For i = 1 To j + 1



        MsgBox "第" & i & "个网卡的MAC ADDRESS 是" & ArrayChar(i - 1)



    Next



    Kill "C:\Ping"



End Function