title image


Smiley Re: Abfangen von Ausgaben anderer Programme
Anleitung:Erstelle ein leeres ProjektFüge zwei Bezeichnungsfelder (Label1 und Label2) hinzu.Füge zwei Textflder (Text1 und Text2) hinzu.Füge eine Befehlsschaltfläche (Command1) hinzu.Wenn Du Netscape verwendest, kannst Du folgenden Code über die Zwischenablage in Dein Projekt kopieren:Option Explicit' Dual Mode API below this line. Dual Mode Types also included. Private Const STARTF_USESHOWWINDOW = &H1Private Const STARTF_USESIZE = &H2Private Const STARTF_USEPOSITION = &H4Private Const STARTF_USECOUNTCHARS = &H8Private Const STARTF_USEFILLATTRIBUTE = &H10Private Const STARTF_RUNFULLSCREEN = &H20 ' ignored for non-x86 platformsPrivate Const STARTF_FORCEONFEEDBACK = &H40Private Const STARTF_FORCEOFFFEEDBACK = &H80Private Const STARTF_USESTDHANDLES = &H100 ' ShowWindow() CommandsPrivate Const SW_HIDE = 0Private Const SW_SHOWNORMAL = 1Private Const SW_NORMAL = 1Private Const SW_SHOWMINIMIZED = 2Private Const SW_SHOWMAXIMIZED = 3Private Const SW_MAXIMIZE = 3Private Const SW_SHOWNOACTIVATE = 4Private Const SW_SHOW = 5Private Const SW_MINIMIZE = 6Private Const SW_SHOWMINNOACTIVE = 7Private Const SW_SHOWNA = 8Private Const SW_RESTORE = 9Private Const SW_SHOWDEFAULT = 10Private Const SW_MAX = 10 Private Const DETACHED_PROCESS = &H8 Private Const NORMAL_PRIORITY_CLASS = &H20&Private Const IDLE_PRIORITY_CLASS = &H40&Private Const HIGH_PRIORITY_CLASS = &H80&Private Const REALTIME_PRIORITY_CLASS = &H100& 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 ReadFile Lib "kernel32" ( _ ByVal hFile As Long, _ lpBuffer As Byte, _ ByVal nNumberOfBytesToRead As Long, _ lpNumberOfBytesRead As Long, _ ByVal lpOverlapped As Long) As Long Private Declare Function PeekNamedPipe Lib "kernel32" (ByVal hNamedPipe As Long, lpBuffer As Any, ByVal nBufferSize As Long, lpBytesRead As Long, lpTotalBytesAvail As Long, lpBytesLeftThisMessage As Long) As Long Private Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As LongEnd 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 LongEnd Type Private Type PROCESS_INFORMATION hProcess As Long hThread As Long dwProcessID As Long dwThreadID As LongEnd Type Private Declare Function API_CreateProcess Lib "kernel32" Alias "CreateProcessA" _( _ ByVal lpApplicationName As Long, _ ByVal lpCommandLine As String, _ ByVal lpProcessAttributes As Long, _ ByVal lpThreadAttributes As Long, _ 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 CloseHandle Lib "kernel32" (ByVal _ hObject As Long) 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 Declare Function GetInputState Lib "user32" () As Long Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As LongPrivate Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long Private Const WAIT_FAILED = -1&Private Const WAIT_OBJECT_0 = 0Private Const WAIT_ABANDONED = &H80&Private Const WAIT_ABANDONED_0 = &H80&Private Const WAIT_TIMEOUT = &H102&Private Const WAIT_IO_COMPLETION = &HC0&Private Const STILL_ACTIVE = &H103&Private Const INFINITE = -1& Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Sub Command1_Click()On Error GoTo Err_Sub Screen.MousePointer = vbHourglass Text2.Text = vbNullString Text2.Text = RunDosCommand(Text1.Text) Exit_Sub: Screen.MousePointer = vbDefault Exit Sub Err_Sub: Text2.Text = Text2.Text & vbCrLf & "--> Fehler: " & Err.Description Resume Exit_SubEnd Sub Private Function RunDosCommand(CommandLine As String) As String Dim RetVal As Long Dim hPipeReadStdout As Long, hPipeWriteStdout As Long ' Handles to standard output pipe. Dim hPipeReadStderr As Long, hPipeWriteStderr As Long ' Handles to standard error pipe.  Dim si As STARTUPINFO Dim pi As PROCESS_INFORMATION Dim sa As SECURITY_ATTRIBUTES  Dim bBuffer() As Byte Dim sBuffer As String Dim sOemBuffer As String Dim sMessageBuffer As String  Dim sCommandLine As String  sCommandLine = "Command.com /C " & CommandLine On Error GoTo Err_Sub  sa.nLength = Len(sa) sa.lpSecurityDescriptor = 0& ' ignored under Win9x sa.bInheritHandle = True  si.cb = Len(si) si.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW si.wShowWindow = SW_HIDE ' or SW_SHOWNOACTIVATE  RetVal = CreatePipe(hPipeReadStdout, hPipeWriteStdout, sa, 0) If RetVal = 0 Then Err.Raise vbObjectError + 1, "Can't create the standard output pipe"  si.hStdOutput = hPipeWriteStdout  RetVal = CreatePipe(hPipeReadStderr, hPipeWriteStderr, sa, 0) If RetVal = 0 Then Err.Raise vbObjectError + 1, "Can't create the standard error pipe"  si.hStdError = hPipeWriteStderr  RetVal = API_CreateProcess(lpApplicationName:=0&, _ lpCommandLine:=sCommandLine, _ lpProcessAttributes:=0&, _ lpThreadAttributes:=0&, _ bInheritHandles:=1&, _ dwCreationFlags:=0&, _ lpEnvironment:=0&, _ lpCurrentDirectory:=0&, _ lpStartupInfo:=si, _ lpProcessInformation:=pi)' dwCreationFlags:= NORMAL_PRIORITY_CLASS Or DETACHED_PROCESS, _  Dim e As Long e = Err.LastDllError If RetVal = 0 Then Err.Raise vbObjectError + 1, "Can't create process. Erroc code is: " & e  Do ' Loop until RC.exe has finished If GetInputState Then DoEvents End If  Dim lread&, lavail&, lmessage&  RetVal = PeekNamedPipe(hNamedPipe:=hPipeReadStdout, _ lpBuffer:=ByVal 0&, _ nBufferSize:=0&, _ lpBytesRead:=lread, _ lpTotalBytesAvail:=lavail, _ lpBytesLeftThisMessage:=lmessage) 'MsgBox RetVal & lread & lavail & lmessage & " E: " & Hex$(Err.LastDllError) If RetVal 0 And lavail > 0 Then ReDim bBuffer(lavail) As Byte RetVal = ReadFile(hPipeReadStdout, bBuffer(0), lavail, lread, 0&) ' MsgBox "read: " & lavail, lread ' We need to convert into Unicode and from OEM to ANSI here. sOemBuffer = StrConv(bBuffer(), vbUnicode) ' Noch Konvertierung OEM to ANSI nötig sBuffer = String$(Len(sOemBuffer), " ") Call OemToChar(sOemBuffer, sBuffer) sMessageBuffer = sMessageBuffer & TrimNullTerminated(sBuffer) End If  RetVal = PeekNamedPipe(hNamedPipe:=hPipeReadStderr, _ lpBuffer:=ByVal 0&, _ nBufferSize:=0&, _ lpBytesRead:=lread, _ lpTotalBytesAvail:=lavail, _ lpBytesLeftThisMessage:=lmessage) 'MsgBox RetVal & lread & lavail & lmessage & " E: " & Hex$(Err.LastDllError) If RetVal 0 And lavail > 0 Then ReDim bBuffer(lavail) As Byte RetVal = ReadFile(hPipeReadStderr, bBuffer(0), lavail, lread, 0&) ' MsgBox "read: " & lavail, lread ' We need to convert into Unicode here. sOemBuffer = StrConv(bBuffer(), vbUnicode) ' Noch Konvertierung OEM to ANSI nötig sBuffer = String$(Len(sOemBuffer), " ") Call OemToChar(sOemBuffer, sBuffer) sMessageBuffer = sMessageBuffer & TrimNullTerminated(sBuffer) End If  RetVal = WaitForSingleObject(pi.hProcess, 1&) Loop While RetVal = WAIT_TIMEOUT Or RetVal = STILL_ACTIVE  If Len(sMessageBuffer) Then RunDosCommand = sMessageBuffer End If  Exit_Sub: ' always close handles Call CloseHandle(pi.hThread) Call CloseHandle(pi.hProcess)  Call CloseHandle(hPipeReadStdout) Call CloseHandle(hPipeReadStderr)  Call CloseHandle(hPipeWriteStdout) Call CloseHandle(hPipeWriteStderr)  Exit Function Err_Sub: MsgBox Err.Description, vbCritical Resume Exit_SubEnd Function Private Function TrimNullTerminated(sString As String) As String Dim i As Long i = InStr(sString, vbNullChar) If i Then TrimNullTerminated = Left$(sString, i - 1) Else TrimNullTerminated = sString End IfEnd Function Private Sub Form_Load() Label1.Caption = "Dos-Anweisung: " Label1.AutoSize = True Text1.Text = vbNullString Text1.Height = 285  Command1.Caption = "Ausführen!" Command1.Height = 375 Command1.Width = 1170  Label2.Caption = "Ergebnis: " Label2.AutoSize = True  Text2.Locked = True Text2.Enabled = True Text2.Text = vbNullString Text2.Font.Name = "Courier New" Text2.Font.Size = 10 If Text2.MultiLine = False Then MsgBox "Bitte die Eigneschaft MultiLine von Text2 auf True einstellen", vbCritical If Text2.ScrollBars vbBoth Then MsgBox "Bitte die Eigenschaft ScrollBars von Text2 auf 3 - Beide einstellen", vbCriticalEnd Sub Private Sub Form_Resize()On Error Resume Next Command1.Move Me.ScaleWidth - Command1.Width - 60, Me.ScaleHeight - Command1.Height - 60 Label1.Move 60, Command1.Top + 75 Text1.Move Label1.Left + Label1.Width + 60, Command1.Top + 45, Command1.Left - Label1.Width - 300  Label2.Move 60, 60 Text2.Move 0, Label2.Top + Label2.Height + 60, Me.ScaleWidth, Command1.Top - Label2.Height - 300End SubProjekt starten."Dir" eingeben und auf "Ausführen" klicken.Viel Erfolg!Thomas Prötzschcu
Thomas Prötzsch

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: