title image


Smiley Oder ein anderer Ansatz...
Dieses Program macht mit Timer Pings und stellt die Ergebnisse in einer Textbox dar. Tex1 = Ergebnisse, Text2 = IP Addresse und Text3 = Interval (Minuten, denke ich). Die Ergebnisse werden nicht mit einer Datei sondern mit Pipe abgefangen.



Option Explicit

 

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 CreateProcessA Lib "kernel32" (ByVal _

        lpApplicationName As Long, 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 Declare Function WaitForSingleObject _

        Lib "kernel32" _

        (ByVal hHandle As Long, _

        ByVal dwMilliseconds As Long) As Long

 

Private Declare Sub Sleep _

        Lib "kernel32" _

        (ByVal dwMilliseconds As Long)

 

Private Declare Function OemToChar _

        Lib "user32" _

        Alias "OemToCharA" _

        (ByVal lpszSrc As String, _

        ByVal lpszDst As String) 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

 

Private Const NORMAL_PRIORITY_CLASS = &H20&

Private Const STARTF_USESTDHANDLES = &H100&

Private Const SYNCHRONIZE = &H100000

Private Const DETACHED_PROCESS = &H8

 

Private bEnd As Boolean

Private bUnload As Boolean

Private bRunning As Boolean

Private iCnt As Long

Private iCnts As Long

Private iPings As Long

 

Private Sub Command1_Click()

    Timer1.Interval = 0

    iPings = 0

    If Text2.Text <> "" Then

        If Text3.Text <> "" Then

            If IsNumeric(Text3.Text) Then

                If CLng(Text3.Text) >= 1 And CLng(Text3.Text) <= 60 Then

                    iCnt = 0

                    iCnts = Text3.Text * 10

                    Timer1.Interval = CLng(Text3.Text) * 6000

                    doPing

                Else

                    MsgBox "Interval must be numeric 1-60"

                End If

            Else

                MsgBox "Interval must be numeric 1-60"

            End If

        Else

            doPing

        End If

    End If

End Sub

 

Private Sub doPing()

    Debug.Print "Ping " & Text2.Text & " at " & Now

    If iPings = 20 Then

        Text1.Text = ""

        iPings = 0

    End If

    addText "Ping " & Text2.Text & " at " & Now & vbCrLf

    ExecCmd ("ping -a " & Text2.Text)

    iPings = iPings + 1

End Sub

 

Private Sub Form_Load()

    bEnd = False

    bRunning = False

    bUnload = False

End Sub

 

Private Sub Form_Unload(Cancel As Integer)

    If bRunning Then

        Cancel = True

        bUnload = True

    End If

End Sub

 

Private Sub Timer1_Timer()

    iCnt = iCnt + 1

    Debug.Print "count is:" & iCnt

    If iCnt = iCnts Then

        iCnt = 0

        doPing

    End If

End Sub

 

Private Sub addText(t As String)

    Text1.SelStart = Len(Text1.Text)

    Text1.SelText = t

End Sub

 

Private Sub ExecCmd(cmdline$)

    Dim proc As PROCESS_INFORMATION

    Dim Result  As Long

    Dim bSuccess As Long

    Dim start As STARTUPINFO

    Dim sa As SECURITY_ATTRIBUTES

    Dim hReadPipe As Long

    Dim hWritePipe As Long

    Dim Buffer As String

    Dim L As Long

    Dim Buffer1 As String

 

    sa.nLength = Len(sa)

    sa.bInheritHandle = 1&

    sa.lpSecurityDescriptor = 0&

    Result = CreatePipe(hReadPipe, hWritePipe, sa, 0)

 

    If Result = 0 Then

        MsgBox "CreatePipe failed Error!"

        Exit Sub

    End If

 

    start.cb = Len(start)

    start.dwFlags = STARTF_USESTDHANDLES

    start.hStdOutput = hWritePipe

    bRunning = True

    Result = CreateProcessA(0&, _

                            cmdline$, _

                            sa, _

                            sa, _

                            1&, _

                            NORMAL_PRIORITY_CLASS + DETACHED_PROCESS, _

                            0&, _

                            0&, _

                            start, _

                            proc)

 

    If Result <> 1 Then

        MsgBox "CreateProcess failed!"

    Else

        If proc.hProcess Then

            Do

                DoEvents

                Sleep 50

            Loop While WaitForSingleObject(proc.hProcess, 0&)

            Call CloseHandle(proc.hProcess)

        End If

        Buffer = String(2000, Chr$(0))

        Buffer1 = String(2000, Chr$(0))

        bSuccess = ReadFile(hReadPipe, Buffer, Len(Buffer), L, 0&)

        If bSuccess = 1 Then

            Result = OemToChar(Left(Buffer, InStr(Buffer, vbNullChar) - 1), Buffer1)

            addText Buffer1

            addText vbCrLf

        Else

            MsgBox "ReadFile failed!"

        End If

    End If

 

    Call CloseHandle(proc.hProcess)

    Call CloseHandle(proc.hThread)

    Call CloseHandle(hReadPipe)

    Call CloseHandle(hWritePipe)

    bRunning = False

    If bUnload Then Unload Me

End Sub





Code eingefügt mit Syntaxhighlighter 1.9
Moderation is OK, but not to excess...



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: