Option Explicit

' Модуль написан
'********************************************************************
'*            Написано 10.08.2003 году (Team HomeWork)              *
'*                   e-mail: sne_pro@mail.ru                        *
'********************************************************************
' Пример написан
'********************************************************************
'*            Написано 20.06.2004 году (Team HomeWork)              *
'*                   e-mail: sne_pro@mail.ru                        *
'********************************************************************

Private Declare Function RasGetConnectionStatistics Lib "rasapi32.dll" (ByVal hRasConn As Long, lpStatistics As RASSTATS2000) As Long
Private Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (lpRasconn As Any, lpcb As Long, lpcConnections As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Type OSVERSIONINFO             ' Версия виндовоськи
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformId        As Long
    szCSDVersion        As String * 128
End Type

Public Type RASSTATS2000
    dwSize                  As Long
    dwBytesXmited           As Long ' The number of bytes transmitted through this connection or link.
    dwBytesRcved            As Long ' The number of bytes received through this connection or link.
    dwFramesXmited          As Long ' The number frames transmitted through this connection or link.
    dwFramesRcved           As Long ' The number of frames received through this connection or link.
    dwCrcErr                As Long ' The number of cyclic redundancy check (CRC) errors on this connection or link.
    dwTimeoutErr            As Long ' The number of timeout errors on this connection or link.
    dwAlignmentErr          As Long ' The number of alignment errors on this connection or link.
    dwHardwareOverrunErr    As Long ' The number of hardware overrun errors on this connection or link.
    dwFramingErr            As Long ' The number of framing errors on this connection or link.
    dwBufferOverrunErr      As Long ' The number of buffer overrun errors on this connection or link.
    dwCompressionRatioIn    As Long ' The compression ratio for the data being received on this connection or link.
    dwCompressionRatioOut   As Long ' The compression ratio for the data being transmitted on this connection or link.
    dwBps                   As Long ' The speed of the connection or link, in bits per second.
    dwConnectDuration       As Long ' The amount of time, in milliseconds, that the connection or link has been connected.
End Type
'Public Type VBRasStats95           ' для 95/98/Me, если понадобится...
'   BytesXmited As Long
'   BytesRcved As Long
'   FramesXmited As Long
'   FramesRcved As Long
'   CrcErr As Long
'   TimeoutErr As Long
'   AlignmentErr As Long
'   HardwareOverrunErr  As Long
'   FramingErr As Long
'   BufferOverrunErr As Long
'   Runts As Long
'   TotalBytesXmited As Long
'   TotalBytesRcved As Long
'   ConnectSpeed As Long
'End Type

Private Const HKEY_DYN_DATA As Long = &H80000006

Private Function VBRasGetStat2000(ByVal hRasConn As Long, _
                         Optional ByRef dwError As Long) As RASSTATS2000

    VBRasGetStat2000.dwSize = Len(VBRasGetStat2000)
    dwError = RasGetConnectionStatistics(hRasConn, VBRasGetStat2000)
End Function

Private Function VBRasGetStat9x(Optional ByRef dwError As Long) As RASSTATS2000
    Dim hKey As Long
    Const dUp As String = "ial-Up Adapter\"

    Call RegOpenKeyEx(HKEY_DYN_DATA, "PerfStats\StatData", 0&, &H7, hKey)
    dwError = IIf(hKey = 0&, False, True)

    With VBRasGetStat9x
        Call RegQueryValueEx(hKey, dUp & "BytesRecvd", 0&, ByVal 0&, .dwBytesXmited, &H4)
        Call RegQueryValueEx(hKey, dUp & "BytesXmit", 0&, ByVal 0&, .dwBytesRcved, &H4)
        Call RegQueryValueEx(hKey, dUp & "FramesXmit", 0&, ByVal 0&, .dwFramesXmited, &H4)
        Call RegQueryValueEx(hKey, dUp & "FramesRecvd", 0&, ByVal 0&, .dwFramesRcved, &H4)
        Call RegQueryValueEx(hKey, dUp & "CRC", 0&, ByVal 0&, .dwCrcErr, &H4)
        Call RegQueryValueEx(hKey, dUp & "Timeout", 0&, ByVal 0&, .dwTimeoutErr, &H4)
        Call RegQueryValueEx(hKey, dUp & "Alignment", 0&, ByVal 0&, .dwAlignmentErr, &H4)
        Call RegQueryValueEx(hKey, dUp & "Overrun", 0&, ByVal 0&, .dwHardwareOverrunErr, &H4)
        Call RegQueryValueEx(hKey, dUp & "Framing", 0&, ByVal 0&, .dwFramingErr, &H4)
        Call RegQueryValueEx(hKey, dUp & "Buffer", 0&, ByVal 0&, .dwBufferOverrunErr, &H4)
        Call RegQueryValueEx(hKey, dUp & "ConnectSpeed", 0&, ByVal 0&, .dwBps, &H4)
        
'        Call RegQueryValueEx(hKey, dUp & "TotalBytesXmit", 0&, ByVal 0&, .BytesRcved, &H4)     ' Не поддерживается 2000/XP...
'        Call RegQueryValueEx(hKey, dUp & "TotalBytesRecvd", 0&, ByVal 0&, .BytesXmited, &H4)   ' Если понадобится, можно использовать
'        Call RegQueryValueEx(hKey, dUp & "Runts", 0&, ByVal 0&, .Runts, &H4)                   ' два разных UDT (VBRasStats95), я предпочел - одну (RASSTATS2000)

        .dwCompressionRatioIn = &HFFFF              ' Не поддерживается 95/98/Me
        .dwCompressionRatioOut = &HFFFF             ' Не поддерживается 95/98/Me
        .dwConnectDuration = &HFFFF                 ' connection duration can be calculated if you use a connection notification event or enumerate connections on a regular basis, providing your app starts before the connection starts.
   End With
End Function

Private Function OS_Version() As OSVERSIONINFO                ' dwPlatformId 0-Unknown; 1-9x; 2-NT
    OS_Version.dwOSVersionInfoSize = Len(OS_Version)
    Call GetVersionEx(OS_Version)
End Function

Public Function VBGetDUPStat(Optional ByRef dwIsError As Long) As RASSTATS2000
    Dim btRasConn() As Byte, lng As Long, dwConnNum As Long

    lng = 32&
    ReDim btRasConn(lng - vbNull)                                       ' Массив с будующими данными

    Call CopyMemory(btRasConn(0), lng, 4&                              ' Ставим у структуры dwSize = lng
    Call RasEnumConnections(btRasConn(0), lng, dwConnNum)               ' Вызов функции
    Call CopyMemory(lng, btRasConn(4), 4&                              ' Берем хэндл соединения

    If OS_Version.dwPlatformId = &H2 Then                            ' В зависимости от типа OS берем данные
        VBGetDUPStat = VBRasGetStat2000(lng, dwIsError)                 ' Из реестра или RAS

    ElseIf OS_Version.dwPlatformId = &H1 Then
        VBGetDUPStat = VBRasGetStat9x(dwIsError)
    End If
End Function

Dim prevStat As RASSTATS2000
Sub TrafInfo()
 Dim st As RASSTATS2000
 st = Модуль1.VBGetDUPStat()
 MsgBox st.dwBps
 MsgBox st.dwConnectDuration
 MsgBox st.dwBytesXmited
 MsgBox st.dwBytesRcved
 prevStat = st
End Sub
Private Sub Timer1_Timer()
  Call TrafInfo
End Sub