VBNet - Форум - Проблема работы кода в Windows Vista

Вопрос: Проблема работы кода в Windows Vista Добавлено: 14.06.08 07:53

Автор вопроса: Антон

Увожаемые программисты помогите новичку.
Имеиться код программы которая отображает данные входящего трафика и другие данные из интернета
была написанна программа под WinXP но с переходом на висту исходный код отказывается работать. модуль был написан не мной и в языке программирования я не селен, поэтому прошу помощи.

Код модуля:

ttribute VB_Name = "mConnections"
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 Declare Function GetIfTable Lib "iphlpapi" (ByRef pIfRowTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) 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 = "Dial-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

Код формы:

Option Explicit

Dim prevStat As RASSTATS2000

Private Sub Form_Load()
    Dim st As RASSTATS2000

    st = mConnections.VBGetDUPStat()

    Print
    Me.ForeColor = vbGreen
    Print "dwAlignmentErr ", , st.dwAlignmentErr
    Print "dwBps", , , st.dwBps
    Print "dwBufferOverrunErr", , st.dwBufferOverrunErr
    Print "dwBytesRcved", , st.dwBytesRcved
    Print "dwBytesXmited", , st.dwBytesXmited
    Print "dwCompressionRatioIn", , st.dwCompressionRatioIn
    Print "dwCompressionRatioOut", , st.dwCompressionRatioOut
    Print "dwConnectDuration", , st.dwConnectDuration
    Print "dwCrcErr", , , st.dwCrcErr
    Print "dwFramesRcved", , st.dwFramesRcved
    Print "dwFramesXmited", , st.dwFramesXmited
    Print "dwFramingErr", , , st.dwFramingErr
    Print "dwHardwareOverrunErr", , st.dwHardwareOverrunErr
    Print "dwTimeoutErr", , , st.dwTimeoutErr

    Print
    Me.ForeColor = vbCyan
    Print "Скорость закачки (download) :", st.dwBytesRcved - prevStat.dwBytesRcved
    Print "Скорость выгрузки (upload) :", st.dwBytesXmited - prevStat.dwBytesXmited
    Print

    Me.ForeColor = vbYellow
    Print "На 9x именно этот пример не проверял, но,"; vbCrLf; "по идее, код рабочий!"

    prevStat = st
End Sub

Private Sub Timer1_Timer()
    Call Me.Cls
    Call Form_Load
End Sub

Ответить

Ответы Всего ответов: 33

Номер ответа: 1 Автор ответа: Администратор ICQ: 278109632 Вопросов: 42 Ответов: 3949	Web-сайт: domkratt.com Профиль \| \| #1	Добавлено: 14.06.08 11:24
	(Team HomeWork) респект Стасу If OS_Version.dwPlatformId = &H2 Then ' В зависимости от типа OS берем данные VBGetDUPStat = VBRasGetStat2000(lng, dwIsError) ' Из реестра или RAS ElseIf OS_Version.dwPlatformId = &H1 Then VBGetDUPStat = VBRasGetStat9x(dwIsError) End If вот тут собака порылась, имхо dwPlatformId другое у висты. Да и не известно, есть ли у висты апишка RasGetConnectionStatistics. Проверьте, у кого виста есть. Ответить

Номер ответа: 2 Автор ответа: Holsten Вопросов: 5 Ответов: 100	Профиль \| \| #2	Добавлено: 14.06.08 16:56
	http://msdn.microsoft.com/en-us/library/aa377499(VS.85).aspx Client Requires Windows Vista, Windows XP, or Windows 2000 Professional. Server Requires Windows Server 2008, Windows Server 2003, or Windows 2000 Server. Header Declared in Ras.h. Library Use Rasapi32.lib. DLL Requires Rasapi32.dll. сижу на хп, не проверить, вдруг билл соврал Ответить

Номер ответа: 3 Автор ответа: Winand Вопросов: 87 Ответов: 2795	Web-сайт: winandfx.narod.ru Профиль \| \| #3	Добавлено: 14.06.08 19:56
	Ваша проблема заключается не в неправильном коде, а в неправильной ОС. Ответить

Номер ответа: 4 Автор ответа: s12 Вопросов: 24 Ответов: 363	Профиль \| \| #4	Добавлено: 15.06.08 00:07
	И жутко недоделаной. Ответить

Номер ответа: 5 Автор ответа: Администратор ICQ: 278109632 Вопросов: 42 Ответов: 3949	Web-сайт: domkratt.com Профиль \| \| #5	Добавлено: 15.06.08 01:17
	Пля, сцукофлудеры Топик видите? Вот по теме и говорим... Ответить

Номер ответа: 6 Автор ответа: gvozd Разработчик Offline Client Вопросов: 164 Ответов: 1317	Web-сайт: www.gvozdsoft.com Профиль \| \| #6	Добавлено: 15.06.08 09:19
	С чего это вдруг, Vista недоделанная? Ответить

Номер ответа: 7 Автор ответа: AleXProg Вопросов: 10 Ответов: 29	Профиль \| \| #7	Добавлено: 15.06.08 10:27
	С того, что Vista - тупость Мелкософта! Не пользуйтесь Вистой - это то, что лежит в туалете! Ответить

Номер ответа: 8 Автор ответа: gvozd Разработчик Offline Client Вопросов: 164 Ответов: 1317	Web-сайт: www.gvozdsoft.com Профиль \| \| #8	Добавлено: 15.06.08 15:00
	Кто это сказал? Ответить

Номер ответа: 9 Автор ответа: Winand Вопросов: 87 Ответов: 2795	Web-сайт: winandfx.narod.ru Профиль \| \| #9	Добавлено: 15.06.08 17:30
	gvozd, а что ники не отображаются?)) З.Ы. Вот жеж блин! Хуже только лоровцы, которые тему про несуществование линукса восприняли очень серьезно, и бросились доказывать обратное. з.з.ы. у висты есть преимущества (перевешивающие недостатки) перед другими ОС (хотя бы XP) из-за которых стоит к ней присмотреться? Ответить

Номер ответа: 10 Автор ответа: User Unknown Вечный Юзер! ICQ: uu@jabber.cz Вопросов: 120 Ответов: 3302	Профиль \| \| #10	Добавлено: 15.06.08 19:21
	Хуже только лоровцы Но но! Попрошу тут без этого ацетона. Иначе не видать тебе Небесной Дискеты и Патрег тебя покарает. Ответить

Номер ответа: 11 Автор ответа: gvozd Разработчик Offline Client Вопросов: 164 Ответов: 1317	Web-сайт: www.gvozdsoft.com Профиль \| \| #11	Добавлено: 15.06.08 19:49
	з.з.ы. у висты есть преимущества (перевешивающие недостатки) перед другими ОС (хотя бы XP) из-за которых стоит к ней присмотреться? Конечно есть. Ответить

Номер ответа: 12 Автор ответа: Winand Вопросов: 87 Ответов: 2795	Web-сайт: winandfx.narod.ru Профиль \| \| #12	Добавлено: 15.06.08 22:11
	User Unknown, я имел в виду не то что лоровцы хуже как человеки, а то что они всё воспринимают еще более серьезно. Ответить

Номер ответа: 13 Автор ответа: Winand Вопросов: 87 Ответов: 2795	Web-сайт: winandfx.narod.ru Профиль \| \| #13	Добавлено: 15.06.08 22:12
	gvozd, а вот и не угодал - нету Ответить

Номер ответа: 14 Автор ответа: Администратор ICQ: 278109632 Вопросов: 42 Ответов: 3949	Web-сайт: domkratt.com Профиль \| \| #14	Добавлено: 16.06.08 01:19
	Есть Но я даже из-за них на нее, как на основную систему, не перейду в ближайший год. Ответить

Номер ответа: 15 Автор ответа: gvozd Разработчик Offline Client Вопросов: 164 Ответов: 1317	Web-сайт: www.gvozdsoft.com Профиль \| \| #15	Добавлено: 16.06.08 09:18
	Я на висте уже больше года сижу, и ничего, жив-здоров, чего и вам желаю. Ответить

Страница: 1 | 2 | 3 |