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 cReaderAs ConsoleReaderPrivate Sub CommandButton1_Click()'Just Commanline example. 'ApplicationName parameter is null in CreateProcess API CommandButton1.Enabled =False CommandButton1.Caption ="Executing..." txtLog.SetFocus txtLog.Text ="" Dim batchReturnAs 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 batchReturnAs 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 messageAs String ) DoEvents txtLog.Text = txtLog.Text & messageEnd Sub
ConsoleReader.cls:
Option Explicit #If Win64Then Private Declare PtrSafe Function CreatePipeLib "kernel32" (phReadPipeAs LongLong , phWritePipeAs LongLong , _ lpPipeAttributesAs Any ,ByVal nSizeAs Long )As Long Private Declare PtrSafe Function ReadFileLib "kernel32" (ByVal hFileAs LongLong ,ByVal lpBufferAs String , _ByVal nNumberOfBytesToReadAs Long , lpNumberOfBytesReadAs Long ,ByVal lpOverlappedAs Any )As Long Private Declare PtrSafe Function CreateProcessLib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationNameAs Any , _ByVal lpCommandLineAs String , lpProcessAttributesAs Any , lpThreadAttributesAs Any ,ByVal bInheritHandlesAs Long , _ByVal dwCreationFlagsAs Long ,ByVal lpEnvironmentAs Long ,ByVal lpCurrentDirectoryAs Long , lpStartupInfoAs Any , _ lpProcessInformationAs Any )As Long Private Declare PtrSafe Function CloseHandleLib "kernel32" (ByVal hObjectAs LongLong )As Long Private Type SECURITY_ATTRIBUTES nLengthAs Long lpSecurityDescriptorAs LongLong bInheritHandleAs Long End Type Private Type STARTUPINFO cbAs Long lpReservedAs LongLong lpDesktopAs LongLong lpTitleAs LongLong dwXAs Long dwYAs Long dwXSizeAs Long dwYSizeAs Long dwXCountCharsAs Long dwYCountCharsAs Long dwFillAttributeAs Long dwFlagsAs Long wShowWindowAs Integer cbReserved2As Integer lpReserved2As LongLong hStdInputAs LongLong hStdOutputAs LongLong hStdErrorAs LongLong End Type Private Type PROCESS_INFORMATION hProcessAs LongLong hThreadAs LongLong dwProcessIdAs Long dwThreadIDAs Long End Type #Else Private Declare Function CreatePipeLib "kernel32" (phReadPipeAs Long , phWritePipeAs Long , _ lpPipeAttributesAs Any ,ByVal nSizeAs Long )As Long Private Declare Function ReadFileLib "kernel32" (ByVal hFileAs Long ,ByVal lpBufferAs String , _ByVal nNumberOfBytesToReadAs Long , lpNumberOfBytesReadAs Long ,ByVal lpOverlappedAs Any )As Long Private Declare Function CreateProcessLib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationNameAs Any , _ByVal lpCommandLineAs String , lpProcessAttributesAs Any , lpThreadAttributesAs Any ,ByVal bInheritHandlesAs Long , _ByVal dwCreationFlagsAs Long ,ByVal lpEnvironmentAs Long ,ByVal lpCurrentDirectoryAs Long , lpStartupInfoAs Any , _ lpProcessInformationAs Any )As Long Private Declare Function CloseHandleLib "kernel32" (ByVal hObjectAs Long )As Long Private Type SECURITY_ATTRIBUTES nLengthAs Long lpSecurityDescriptorAs Long bInheritHandleAs Long End Type Private Type STARTUPINFO cbAs Long lpReservedAs Long lpDesktopAs Long lpTitleAs Long dwXAs Long dwYAs Long dwXSizeAs Long dwYSizeAs Long dwXCountCharsAs Long dwYCountCharsAs Long dwFillAttributeAs Long dwFlagsAs Long wShowWindowAs Integer cbReserved2As Integer lpReserved2As Long hStdInputAs Long hStdOutputAs Long hStdErrorAs Long End Type Private Type PROCESS_INFORMATION hProcessAs Long hThreadAs Long dwProcessIdAs Long dwThreadIDAs Long End Type #End If Private Const NORMAL_PRIORITY_CLASS = &H20&Private Const STARTF_USESTDHANDLES = &H100&Private Const STARTF_USESHOWWINDOW = &H1Private Const SW_HIDE = 0Public Event ConsoleMessage(ByVal messageAs String )Public Function GetConsole(Optional ByVal appFullPathAs String ="" ,Optional ByVal strCommandAs String ="" , _Optional ByVal nBytesReadAs Long = 1048576)As String ' 1048576 => 1 MB Dim saAs SECURITY_ATTRIBUTESDim startInfoAs STARTUPINFODim procInfoAs PROCESS_INFORMATIONDim strRetAs String Dim bytesReadAs Long Dim readBufferAs String Dim retValAs Long #If Win64Then Dim OurReadPipeAs LongLong Dim AppWritePipeAs LongLong #Else Dim OurReadPipeAs Long Dim AppWritePipeAs Long #End If sa.bInheritHandle =True sa.nLength = Len(sa) retVal = CreatePipe(OurReadPipe, AppWritePipe, sa, 0)If retVal = 0Then MsgBox"Could not create pipe!"End End If startInfo.cb = Len(startInfo) startInfo.dwFlags = STARTF_USESTDHANDLESOr STARTF_USESHOWWINDOW startInfo.wShowWindow = SW_HIDE startInfo.hStdOutput = AppWritePipe startInfo.hStdError = AppWritePipeIf 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 = 0Then MsgBox"Could CloseHandle AppWritePipe readBuffer = Space(nBytesRead * 10)not start the ping program!"Do retVal = ReadFile(OurReadPipe, readBuffer, nBytesRead, bytesRead, 0&)If retVal = 0Then 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 OurReadPipeEnd Function Private Function GetConsoleTR(txtAs String )As String ' Zeki Gürsoy ' ' ı ğ ü ş ç ö Ğ Ü İ Ş Ç Ö => cp857 or ibm857 => Turkish DOS Dim bytes()As Byte , iAs Integer bytes = txtFor i = 0To UBound (bytes) Step 2Select Case bytes(i)Case 141And bytes(i + 1) = 0 '"ı" bytes(i) = 49: bytes(i + 1) = 1Case 167And bytes(i + 1) = 0 '"ğ" bytes(i) = 31: bytes(i + 1) = 1Case 129And bytes(i + 1) = 0 '"ü" bytes(i) = 252: bytes(i + 1) = 0Case 120And bytes(i + 1) = 1 '"ş" bytes(i) = 95: bytes(i + 1) = 1Case 33And bytes(i + 1) = 32 '"ç" bytes(i) = 231: bytes(i + 1) = 0Case 29And bytes(i + 1) = 32 '"ö" bytes(i) = 246: bytes(i + 1) = 0Case 166And bytes(i + 1) = 1 '"Ğ" bytes(i) = 30: bytes(i + 1) = 1Case 97And bytes(i + 1) = 1 '"Ü" bytes(i) = 220: bytes(i + 1) = 0Case 220And bytes(i + 1) = 2 '"İ" bytes(i) = 48: bytes(i + 1) = 1Case 158And bytes(i + 1) = 0 '"Ş" bytes(i) = 94: bytes(i + 1) = 1Case 172And bytes(i + 1) = 32 '"Ç" bytes(i) = 199: bytes(i + 1) = 0Case 34And bytes(i + 1) = 33 '"Ö" bytes(i) = 214: bytes(i + 1) = 0End Select Next GetConsoleTR = bytesEnd Function
Örnek dosya (30,8 KB) : ReadConsole(32&64).xlsm
Eline sağlık dostum, bende de bu iş için bir kod vardı .... bulursam onu da paylaşayım, alternatif olsun.
YanıtlaSil