vamos lá para resolver parte do problema que é o tempo de conexão
num form chamado f_webtimer insira um listview1 e um timer
codigo do form:
Private Sub Form_Load()
Dim itmx As ListItem
ListView1.View = lvwReport
ListView1.ColumnHeaders.Add , , "Information"
With ListView1.ListItems
Set itmx = .Add(, "bDescr", "description of interface")
Set itmx = .Add(, , "interface index")
Set itmx = .Add(, , "interface type")
Set itmx = .Add(, , "Maximum Transmission Unit")
Set itmx = .Add(, , "interface speed (bps)")
Set itmx = .Add(, , "physical address (decimal)")
Set itmx = .Add(, , "physical address (hex)")
Set itmx = .Add(, , "admin enabled or disabled")
Set itmx = .Add(, , "interface operational status")
Set itmx = .Add(, , "Max time op status changed")
Set itmx = .Add(, , "data received (octets)")
Set itmx = .Add(, , "packets received (unicast)")
Set itmx = .Add(, , "packets received (non-unicast)")
Set itmx = .Add(, , "packets discarded")
Set itmx = .Add(, , "discarded with errors")
Set itmx = .Add(, , "discarded, unknown protocol")
Set itmx = .Add(, , "data sent (octets)")
Set itmx = .Add(, , "packets sent (unicast)")
Set itmx = .Add(, , "packets sent (non-unicast)")
Set itmx = .Add(, , "packets discarded, no errors")
Set itmx = .Add(, , "packets discarded with errors")
Set itmx = .Add(, , "output queue length")
Set itmx = .Add(, , "Nome Processo")
End With
End Sub
Private Sub Timer1_Timer()
main
End Sub
agora num módulo cole o código
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2008 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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_OPER_STATUS_NON_OPERATIONAL As Long = 0
Private Const MIB_IF_OPER_STATUS_UNREACHABLE As Long = 1
Private Const MIB_IF_OPER_STATUS_DISCONNECTED As Long = 2
Private Const MIB_IF_OPER_STATUS_CONNECTING As Long = 3
Private Const MIB_IF_OPER_STATUS_CONNECTED As Long = 4
Private Const MIB_IF_OPER_STATUS_OPERATIONAL As Long = 5
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 Const MIB_IF_ADMIN_STATUS_UP As Long = 1
Private Const MIB_IF_ADMIN_STATUS_DOWN As Long = 2
Private Const MIB_IF_ADMIN_STATUS_TESTING As Long = 3
Private Type MIB_IFROW
wszName(0 To (MAX_INTERFACE_NAME_LEN - 1) * 2) As Byte '510
dwIndex As Long
dwType As Long
dwMtu As Long
dwSpeed As Long
dwPhysAddrLen As Long
bPhysAddr(0 To MAXLEN_PHYSADDR - 1) As Byte '8
dwAdminStatus As Long
dwOperStatus As Long
dwMaxChange 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 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" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Type ULARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Public ul() As ULARGE_INTEGER
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private st As SYSTEMTIME
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private ft As FILETIME
Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function GetFriendlyIfIndex Lib "iphlpapi" _
(ByVal IfIndex As Long) As Long
Private IfRow As MIB_IFROW
Private Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
Function GuessIfMaxUpdateSystemTime(MaxUpdateTime As Long, Time As SYSTEMTIME)
GetSystemTime Time
SystemTimeToFileTime Time, ft
ft.dwLowDateTime = ft.dwLowDateTime / 100000
If ft.dwLowDateTime < MaxUpdateTime Then ft.dwHighDateTime = ft.dwHighDateTime - 1
ft.dwLowDateTime = MaxUpdateTime ';
End Function
'BOOL GuessIfMaxUpdateLocalTime(DWORD MaxUpdateTime, SYSTEMTIME& Time)
Function GuessIfMaxUpdateLocalTime(MaxUpdateTime As Long, Time As SYSTEMTIME) As Boolean
GuessIfMaxUpdateSystemTime MaxUpdateTime, Time
ret = FileTimeToLocalFileTime(ft, ft)
If ret = 0 Then
GuessIfMaxUpdateLocalTime = False
Else
ret = FileTimeToSystemTime(ft, st)
If ret = 0 Then GuessIfMaxUpdateLocalTime = True
End If
End Function
'sIfType=get
Function GetIfTypeName(IfType As Long) As String
Select Case IfType
Case MIB_IF_TYPE_OTHER:
GetIfTypeName = "Other"
Case MIB_IF_TYPE_ETHERNET:
GetIfTypeName = "Ethernet"
Case MIB_IF_TYPE_TOKENRING:
GetIfTypeName = "TokenRing"
Case MIB_IF_TYPE_FDDI:
GetIfTypeName = "FDDI"
Case MIB_IF_TYPE_PPP:
GetIfTypeName = "PPP"
Case MIB_IF_TYPE_LOOPBACK:
GetIfTypeName = "Loopback"
Case MIB_IF_TYPE_SLIP:
GetIfTypeName = "SLIP"
Case Else
GetIfTypeName = "<Unknown>"
End Select
End Function
Function GetIfOperStatus(OperStatus As Long) As String
Select Case (OperStatus)
Case MIB_IF_OPER_STATUS_NON_OPERATIONAL
GetIfOperStatus = "non-operational"
Case MIB_IF_OPER_STATUS_UNREACHABLE
GetIfOperStatus = "unreachable"
Case MIB_IF_OPER_STATUS_DISCONNECTED
GetIfOperStatus = "disconnected"
Case MIB_IF_OPER_STATUS_CONNECTING
GetIfOperStatus = "connecting"
Case MIB_IF_OPER_STATUS_CONNECTED
GetIfOperStatus = "connected"
Case MIB_IF_OPER_STATUS_OPERATIONAL
GetIfOperStatus = "operational"
Case Else
GetIfOperStatus = "<Unknown>"
End Select
End Function
Sub PrintPhysicalAddress(PhysAddr() As Byte, PhysAddrLen As Long)
Dim strPhyAdd As String
Dim i As Long
If (PhysAddrLen > 0) Then
strPhyAdd = "Physical address"
For i = 0 To PhysAddrLen - 1
strPhyAdd = strPhyAdd & "-" & PhysAddr(i)
Next
End If
End Sub
Function PrintIfrow() As String
Dim strPrintf As String
' WCHAR wszName[MAX_INTERFACE_NAME_LEN]
GuessIfMaxUpdateLocalTime IfRow.dwMaxChange, st
PrintIfrow = st.wDay & "/" & st.wMonth & "/" & st.wYear & _
" " & st.wHour & ":" & st.wMinute & ":" & st.wSecond
End Function
Sub main()
Dim result As Boolean
Dim BufferSize As Long
Dim buff() As Byte
Dim nStructSize As Long
Dim nRows As Long
Dim cnt As Long
Dim n As Long
Dim itmx As ListItem
Dim tmp As String
Dim ft As FILETIME
Dim ret As Long
result = False
BufferSize = 0
ret = GetIfTable(ByVal 0&, BufferSize, 1)
If ret > 0 Then
ReDim buff(0 To BufferSize - 1) As Byte
If GetIfTable(buff(0), BufferSize, 1) = ERROR_SUCCESS Then
'saves using LenB in the CopyMemory calls below
nStructSize = LenB(IfRow)
'Min 4 bytes is a long indicating the
'number of entries in the table
CopyMemory nRows, buff(0), 4
For cnt = 1 To nRows
'moving past the four bytes obtained
'above, get one chunk of data and cast
'into an IFROW type
CopyMemory IfRow, buff(4 + (cnt - 1) * nStructSize), nStructSize
With f_WebTimer.ListView1
' On Error Resume Next
.ColumnHeaders.Add , , "Adapter " & CStr(cnt)
Set itmx = .ListItems(1)
itmx.SubItems(cnt) = TrimNull(StrConv(IfRow.bDescr, vbUnicode))
Set itmx = .ListItems(2)
itmx.SubItems(cnt) = GetFriendlyIfIndex(IfRow.dwIndex)
Select Case IfRow.dwType
Case MIB_IF_TYPE_ETHERNET: tmp = "Ethernet"
Case MIB_IF_TYPE_TOKENRING: tmp = "TokenRing"
Case MIB_IF_TYPE_FDDI: tmp = "FDDI"
Case MIB_IF_TYPE_PPP: tmp = "Point-to-Point"
Case MIB_IF_TYPE_LOOPBACK: tmp = "Loopback"
Case MIB_IF_TYPE_SLIP: tmp = "Slip"
Case MIB_IF_TYPE_OTHER: tmp = "Other"
End Select
Set itmx = .ListItems(3)
itmx.SubItems(cnt) = IfRow.dwType & " " & tmp
tmp = ""
Set itmx = .ListItems(4)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwMtu, 0)
Set itmx = .ListItems(5)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwSpeed, 0)
For n = 0 To IfRow.dwPhysAddrLen - 1
tmp = tmp & IfRow.bPhysAddr(n) & " "
Next
Set itmx = .ListItems(6)
itmx.SubItems(cnt) = tmp
tmp = ""
For n = 0 To IfRow.dwPhysAddrLen - 1
tmp = tmp & Hex(IfRow.bPhysAddr(n)) & " "
Next
Set itmx = .ListItems(7)
itmx.SubItems(cnt) = tmp
tmp = ""
Select Case IfRow.dwAdminStatus
Case MIB_IF_ADMIN_STATUS_UP: tmp = "Enabled"
Case MIB_IF_ADMIN_STATUS_DOWN: tmp = "Disabled"
Case MIB_IF_ADMIN_STATUS_TESTING: tmp = "Testing"
End Select
Set itmx = .ListItems(8)
itmx.SubItems(cnt) = IfRow.dwAdminStatus & " " & tmp
tmp = ""
Select Case IfRow.dwOperStatus
Case MIB_IF_OPER_STATUS_NON_OPERATIONAL: tmp = "Non-operational"
Case MIB_IF_OPER_STATUS_UNREACHABLE: tmp = "Unreachable"
Case MIB_IF_OPER_STATUS_DISCONNECTED: tmp = "Disconnected"
Case MIB_IF_OPER_STATUS_CONNECTING: tmp = "Connecting"
Case MIB_IF_OPER_STATUS_CONNECTED: tmp = "Connected"
Case MIB_IF_OPER_STATUS_OPERATIONAL: tmp = "Operational"
End Select
Set itmx = .ListItems(9)
itmx.SubItems(cnt) = IfRow.dwOperStatus & " " & tmp
tmp = ""
'GuessIfMaxUpdateSystemTime IfRow.dwMaxChange, ft
meutempo = Format$(PrintIfrow, "dd/mm/yyyy hh:mm:ss")
secDiff = DateDiff("s", CDate(meutempo), Now)
minhadiff = Day(Now) - Day(Now) & "/" & Month(Now) - Month(meutempo) & "/" & Year(Now) - Year(meutempo) & " "
minhadiff = minhadiff & Hour(Now) - Hour(meutempo) & ":" & Minute(Now) - Minute(meutempo) & ":" & Second(Now) - Second(meutempo)
minhaDif = Format$(minhadiff, "dd/mm/yyyy hh:mm:ss")
Set itmx = .ListItems(10)
itmx.SubItems(cnt) = "Duração: " & minhadiff
Set itmx = .ListItems(11)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwInOctets, 0)
Set itmx = .ListItems(12)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwInUcastPkts, 0)
Set itmx = .ListItems(13)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwInNUcastPkts, 0)
Set itmx = .ListItems(14)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwInDiscards, 0)
Set itmx = .ListItems(15)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwInErrors, 0)
Set itmx = .ListItems(16)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwInUnknownProtos, 0)
Set itmx = .ListItems(17)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwOutOctets, 0)
Set itmx = .ListItems(18)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwOutUcastPkts, 0)
Set itmx = .ListItems(19)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwOutNUcastPkts, 0)
Set itmx = .ListItems(20)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwOutDiscards, 0)
Set itmx = .ListItems(21)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwOutErrors, 0)
Set itmx = .ListItems(22)
itmx.SubItems(cnt) = FormatNumber(IfRow.dwOutQLen, 0)
Set itmx = .ListItems(23)
itmx.SubItems(cnt) = TrimNull(StrConv(IfRow.wszName, vbUnicode))
End With 'Listview1
'f_WebTimer.ListView1.Refresh
Next cnt
End If 'If GetIfTable( ...
End If 'If buffersize > 0
End Sub
Private Function TrimNull(item As String)
Dim pos As Integer
pos = InStr(item, Chr$(0))
If pos Then
TrimNull = Left$(item, pos - 1)
Else
TrimNull = item
End If
End Function
falta corrigir cálculo do tempo esta com um bugg + ai é só queimar as pestanas e testar
