Startseite / Tipps / VB 5/6-Tipp 0608: Gesendete und Empfangene Bytes aller Adapter auslesen

VB 5/6-Tipp 0608: Gesendete und Empfangene Bytes aller Adapter auslesen

 von NoOne

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Listen-Steuerelement "lstSend"
' Steuerelement: Listen-Steuerelement "lstReceived"
' Steuerelement: Listen-Steuerelement "lstNic"
' Steuerelement: Timersteuerelement "Timer1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"

Option Explicit

Private Declare Function GetIfTable Lib "iphlpapi.dll" ( _
                         ByRef pIfTable As Any, _
                         ByRef pdwSize As Long, _
                         ByVal bOrder As Long) As Long
                         
Private Declare Sub CopyMemory Lib "kernel32" _
                    Alias "RtlMoveMemory" ( _
                    dst As Any, _
                    src As Any, _
                    ByVal bcount As Long)

Private Const MAX_INTERFACE_NAME_LEN  As Long = 256&
Private Const ERROR_SUCCESS           As Long = 0&
Private Const MAXLEN_IFDESCR          As Long = 256&
Private Const MAXLEN_PHYSADDR         As Long = 8&

Private Const MIB_IF_TYPE_OTHER       As Long = 1&
Private Const MIB_IF_TYPE_ETHERNET    As Long = 6&
Private Const MIB_IF_TYPE_TOKENRING   As Long = 9&
Private Const MIB_IF_TYPE_FDDI        As Long = 15&
Private Const MIB_IF_TYPE_PPP         As Long = 23&
Private Const MIB_IF_TYPE_LOOPBACK    As Long = 24&
Private Const MIB_IF_TYPE_SLIP        As Long = 28&

Private Type MIB_IFROW
   wszName(0 To (MAX_INTERFACE_NAME_LEN - 1) * 2) As Byte
   dwIndex              As Long
   dwType               As Long
   dwMtu                As Long
   dwSpeed              As Long
   dwPhysAddrLen        As Long
   bPhysAddr(0 To MAXLEN_PHYSADDR - 1) As Byte
   dwAdminStatus        As Long
   dwOperStatus         As Long
   dwLastChange         As Long
   dwInOctets           As Long
   dwInUcastPkts        As Long
   dwInNUcastPkts       As Long
   dwInDiscards         As Long
   dwInErrors           As Long
   dwInUnknownProtos    As Long
   dwOutOctets          As Long
   dwOutUcastPkts       As Long
   dwOutNUcastPkts      As Long
   dwOutDiscards        As Long
   dwOutErrors          As Long
   dwOutQLen            As Long
   dwDescrLen           As Long
   bDescr(0 To MAXLEN_IFDESCR - 1) As Byte
End Type

Private Sub Command1_Click()
    'Beenden
    Unload Me
End Sub

Private Sub Form_Load()
    Timer1_Timer
End Sub

Private Sub Timer1_Timer()
    'Die Informationen auslesen
    GetEthernetInfo
End Sub

Private Sub GetEthernetInfo()
    Dim IPInterfaceRow As MIB_IFROW
    Dim buff() As Byte
    Dim cbRequired As Long
    Dim nStructSize As Long
    Dim nRows As Long
    Dim cnt As Long
    
    'Puffergröße auslesen
    Call GetIfTable(ByVal 0&, cbRequired, 1)
    
    If cbRequired > 0 Then
        ReDim buff(0 To cbRequired - 1)
        
        If GetIfTable(buff(0), cbRequired, 1) = ERROR_SUCCESS Then
            nStructSize = LenB(IPInterfaceRow)
            
            'Die Anzahl der Adapter auslesen
            CopyMemory nRows, buff(0), 4
            
            lstNic.Clear
            lstReceived.Clear
            lstSend.Clear
            
            'Für jeden Adapter...
            For cnt = 1 To nRows
                
                '...Informationen in eine Struktur kopieren
                CopyMemory IPInterfaceRow, buff(4 + (cnt - 1) * _
                    nStructSize), nStructSize
                
                If IPInterfaceRow.dwType = MIB_IF_TYPE_ETHERNET Then
                    
                    'Informationen auslesen und anzeigen
                    lstNic.AddItem GetName(IPInterfaceRow.bDescr)
                    
                    lstReceived.AddItem FormatNumber( _
                        SignedToUnsignedLong( _
                        IPInterfaceRow.dwInOctets) _
                        / 1024, 0)
                        
                    lstSend.AddItem FormatNumber( _
                        SignedToUnsignedLong( _
                        IPInterfaceRow.dwOutOctets) _
                        / 1024, 0)
                End If
            Next cnt
        End If
    End If
End Sub

' Wandelt ein (Byte-) Array in einen String um
Private Function GetName(ByRef arr) As String
    Dim i As Integer
    Dim str As String
    
    For i = LBound(arr) To UBound(arr)
        str = str & Chr$(arr(i))
    Next i
    
    GetName = str
End Function

' Danke an K. Langbein für die Funktion!
Private Function SignedToUnsignedLong(ByVal LongIn As Long) As Double
    If LongIn < 0 Then
        SignedToUnsignedLong = LongIn + 4294967296#
    Else
        SignedToUnsignedLong = LongIn
    End If
End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 10 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

lstReceived.AddItem _
Format((IPInterfaceRow.dwInOctets / 1024), "0.0") & " kB"

lstSend.AddItem _
Format((IPInterfaceRow.dwOutOctets / 1024), "0.0") & " kB"