Reading Console Window StdOut With Real Time in VBA

    Yaklaşık 8 yıl önce kaynağını nereden aldığımı hatırlayamadığım kodu paylaşmak istiyorum. Bu kod, DOS ekranındaki çıktıları gerçek/eş zamanlı olarak okuyabilmenizi sağlar. DOS ekranından alınabilecek çıktılar için DIR veya PING komutları gibi sığ düşünmeyin. Bu, herhangi bir Console uygulaması olabilir. Örneğin 7zip veya bir Sql Server veritabanının yedekleme için kullanılan Console uygulaması olabilir.

    Kaynak kod üzerinde biraz oynayarak nesneye çevirdim. Daha önemlisi hem 32, hem de 64 bit Office için Win32 API deklarasyonlarını uyumlu hale getirdim. Örnek kullanım ve kaynak kod aşağıdadır. Ayrıca yazının sonunda örnek dosyayı da indirebileceğiniz bir bağlantı bulacaksınız.

 Örnek dosyadan bir görüntü:

 

 Nesnenin kullanım örneği (UserForm):

 

Private WithEvents cReader As ConsoleReader

Private Sub CommandButton1_Click()
    'Just Commanline example.
    'ApplicationName parameter is null in CreateProcess API
    
    CommandButton1.Enabled = False
    CommandButton1.Caption = "Executing..."
    
    txtLog.SetFocus
    
    txtLog.Text = ""
    
    Dim batchReturn As String 'this is in comment in source code of the GetConsole function
    
    Set cReader = New ConsoleReader
    
    batchReturn = cReader.GetConsole("", txtJustCommandline.Text)
    
    CommandButton1.Caption = "Execute"
    CommandButton1.Enabled = True
End Sub

Private Sub CommandButton2_Click()
    'With Application Name example
    'ApplicationName parameter isn't null in CreateProcess API(Path & Name required)
    
    CommandButton2.Enabled = False
    CommandButton2.Caption = "Executing..."
    
    txtLog.SetFocus
    
    txtLog.Text = ""
    
    Dim batchReturn As String 'this is in comment in source code of the GetConsole function
    
    Set cReader = New ConsoleReader
    
    batchReturn = cReader.GetConsole("C:\Windows\System32\cmd.exe", txtWithAppName.Text)
    
    CommandButton2.Caption = "Execute"
    CommandButton2.Enabled = True
End Sub

Private Sub cReader_ConsoleMessage(ByVal message As String)
    DoEvents
    txtLog.Text = txtLog.Text & message
End Sub

 

 ConsoleReader.cls:

 

Option Explicit

#If Win64 Then
    Private Declare PtrSafe Function CreatePipe Lib "kernel32" (phReadPipe As LongLong, phWritePipe As LongLong, _
        lpPipeAttributes As Any, ByVal nSize As Long) As Long
                                                                
    Private Declare PtrSafe Function ReadFile Lib "kernel32" (ByVal hFile As LongLong, ByVal lpBuffer As String, _
        ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
        
    Private Declare PtrSafe Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As Any, _
        ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, _
        ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As Any, _
        lpProcessInformation As Any) As Long
    
    Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongLong) As Long
    
    Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As LongLong
        bInheritHandle As Long
    End Type
    
    Private Type STARTUPINFO
        cb As Long
        lpReserved As LongLong
        lpDesktop As LongLong
        lpTitle As LongLong
        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 LongLong
        hStdInput As LongLong
        hStdOutput As LongLong
        hStdError As LongLong
    End Type
    
    Private Type PROCESS_INFORMATION
        hProcess As LongLong
        hThread As LongLong
        dwProcessId As Long
        dwThreadID As Long
    End Type
    
#Else

    Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, _
        lpPipeAttributes As Any, ByVal nSize 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, ByVal lpOverlapped As Any) As Long
        
    Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As Any, _
        ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, _
        ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As Any, _
        lpProcessInformation As Any) As Long
    
    Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    
    Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
    End Type
    
    Private Type STARTUPINFO
        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 Type PROCESS_INFORMATION
        hProcess As Long
        hThread As Long
        dwProcessId As Long
        dwThreadID As Long
    End Type
    
#End If

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Const STARTF_USESHOWWINDOW = &H1
Private Const SW_HIDE = 0

Public Event ConsoleMessage(ByVal message As String)

Public Function GetConsole(Optional ByVal appFullPath As String = "", Optional ByVal strCommand As String = "", _
                           Optional ByVal nBytesRead As Long = 1048576) As String  ' 1048576 => 1 MB
                    
    Dim sa           As SECURITY_ATTRIBUTES
    Dim startInfo    As STARTUPINFO
    Dim procInfo     As PROCESS_INFORMATION
    Dim strRet       As String
    Dim bytesRead    As Long
    Dim readBuffer   As String
    Dim retVal       As Long
    
#If Win64 Then
    Dim OurReadPipe  As LongLong
    Dim AppWritePipe As LongLong
#Else
    Dim OurReadPipe  As Long
    Dim AppWritePipe As Long
#End If
    
    sa.bInheritHandle = True
    sa.nLength = Len(sa)
    
    retVal = CreatePipe(OurReadPipe, AppWritePipe, sa, 0)
    
    If retVal = 0 Then
        MsgBox "Could not create pipe!"
        End
    End If
    
    startInfo.cb = Len(startInfo)
    startInfo.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    startInfo.wShowWindow = SW_HIDE
    
    startInfo.hStdOutput = AppWritePipe
    startInfo.hStdError = AppWritePipe
                                            
    If appFullPath = "" Then
        retVal = CreateProcess(0&, strCommand, sa, sa, True, NORMAL_PRIORITY_CLASS, 0&, 0&, startInfo, procInfo)
    Else
        retVal = CreateProcess(appFullPath, strCommand, sa, sa, True, NORMAL_PRIORITY_CLASS, 0&, 0&, startInfo, procInfo)
    End If
    
    If retVal = 0 Then MsgBox "Could not start the ping program!"
    
    CloseHandle AppWritePipe
    
    readBuffer = Space(nBytesRead * 10)
    
    Do
        retVal = ReadFile(OurReadPipe, readBuffer, nBytesRead, bytesRead, 0&)
        If retVal = 0 Then Exit Do
        
        strRet = Left$(readBuffer, bytesRead)
        
        RaiseEvent ConsoleMessage(strRet)
        
        'Debug.Print strRet
        'RaiseEvent Myvent(Byval msg As String)
        'GetConsole = GetConsole & strRet
    Loop
    
    CloseHandle procInfo.hProcess
    CloseHandle procInfo.dwThreadID
    CloseHandle OurReadPipe
End Function

Private Function GetConsoleTR(txt As String) As String
    ' Zeki Gürsoy
    '
    ' ı ğ ü ş ç ö Ğ Ü İ Ş Ç Ö => cp857 or ibm857 => Turkish DOS
    
    Dim bytes() As Byte, i As Integer
    
    bytes = txt

    For i = 0 To UBound(bytes) Step 2
        Select Case bytes(i)
            Case 141 And bytes(i + 1) = 0 '"ı"
                bytes(i) = 49: bytes(i + 1) = 1
            Case 167 And bytes(i + 1) = 0 '"ğ"
                bytes(i) = 31: bytes(i + 1) = 1
            Case 129 And bytes(i + 1) = 0 '"ü"
                bytes(i) = 252: bytes(i + 1) = 0
            Case 120 And bytes(i + 1) = 1 '"ş"
                bytes(i) = 95: bytes(i + 1) = 1
            Case 33 And bytes(i + 1) = 32 '"ç"
                bytes(i) = 231: bytes(i + 1) = 0
            Case 29 And bytes(i + 1) = 32 '"ö"
                bytes(i) = 246: bytes(i + 1) = 0
            Case 166 And bytes(i + 1) = 1 '"Ğ"
                bytes(i) = 30: bytes(i + 1) = 1
            Case 97 And bytes(i + 1) = 1 '"Ü"
                bytes(i) = 220: bytes(i + 1) = 0
            Case 220 And bytes(i + 1) = 2 '"İ"
                bytes(i) = 48: bytes(i + 1) = 1
            Case 158 And bytes(i + 1) = 0 '"Ş"
                bytes(i) = 94: bytes(i + 1) = 1
            Case 172 And bytes(i + 1) = 32 '"Ç"
                bytes(i) = 199: bytes(i + 1) = 0
            Case 34 And bytes(i + 1) = 33 '"Ö"
                bytes(i) = 214: bytes(i + 1) = 0
        End Select
    Next
    
    GetConsoleTR = bytes
End Function

 

Örnek dosya (30,8 KB) : ReadConsole(32&64).xlsm