Script Code : Buat Form Bandwidth Monitor

Anda pasti tahu apa itu Bandwidth Monitor? kalau belum tau Bandwidth Monitor adalah suatu program kecil untuk mengetahui suatu proses kinerja dari PC kita, baik itu proses dalam mengirim data atau mengunduh suatu data, Bandwidth Monitor yang saya buat memang agak seperti IDM (Internet Download Manager), tapi tidak sebagus kayak IDM. Tapi lumayan  untuk program kecil, bisa digunakan sendiri untuk mengetahui proses kinerja dari PC, baiklah di sini saya akan berbagi script code program untuk membuat Bandwidth Monitor, tapi bahasa pemprograman yang digunakan adalah bahasa pemprograman VB (Visual Basic).

Keterangan Gambar.

Script Code :

Disini anda tinggal mengklik bagian dari menu dibawah ini!

1. Forms
    - frmMain(frmMain.frm)

2. Modules
    - Main(Main.bas)

3. Class Modules
    - CInterface(CInterface.cls)
    - CInterfaces(CInterfaces.cls)
    - CIpHelper(CIpHelper.cls)

--------------------------------------------------------------------------------------------------
1. Forms
   
     frmMain

Private Sub picTray_Click()
PopupMenu mnuPopup
End Sub
-----------------------------------------------------------------------------------------
Private Sub picTray_DblClick()
Unload Me
End Sub
-----------------------------------------------------------------------------------------
Private Sub picTray_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Me.Visible Then Exit Sub
Select Case X / Screen.TwipsPerPixelX
Case Is = WM_LBUTTONDOWN
Me.Show
DeleteIcon
Case Is = WM_RBUTTONDOWN
Case Is = WM_MOUSEMOVE
End Select
End Sub
-----------------------------------------------------------------------------------------
Private Sub tmrReset_Timer()
DownloadSpeedTop = 0 'Download kecepatan rata-rata
UploadSpeedTop = 0 'Rata-rata kecepatan upload
End Sub
-----------------------------------------------------------------------------------------
Private Sub tmrUpdate_Timer()
On Error Resume Next
If DateDiff("s", LastMoment, Now) < 1 Then Exit Sub
tmrUpdate.Enabled = False
Dim objInterface As CInterface
Set objInterface = m_objIpHelper.Interfaces(cboConnectionType.ListIndex + 1)
lblType = m_objIpHelper.Interfaces(cboConnectionType.ListIndex + 1).InterfaceDescription & " "
Dim BytesRecv As Long, BytesSent As Long
BytesRecv = m_objIpHelper.BytesReceived
BytesSent = m_objIpHelper.BytesSent
lblRecv.Caption = Format(BytesRecv / 1024, "###,###,###,###,##0 KB")
lblSent.Caption = Format(BytesSent / 1024, "###,###,###,###,##0 KB")
Dim DS As Long, US As Long
DS = BytesRecv - LastRecvBytes
US = BytesSent - LastSentBytes
If DownloadSpeedTop < DS Then
tmrReset.Enabled = False
tmrReset.Enabled = True
DownloadSpeedTop = DS
End If
If UploadSpeedTop < US Then
tmrReset.Enabled = False
tmrReset.Enabled = True
UploadSpeedTop = US
End If
DownloadSpeedAverage = (DownloadSpeedAverage + DS) / 2
UploadSpeedAverage = (UploadSpeedAverage + US) / 2
lblDownloadSpeedTop = "Top download speed: " & Format(DownloadSpeedTop / 1024, "###,###,###,###,#0.#0 Kb/S")
lblUploadSpeedTop = "Top upload speed: " & Format(UploadSpeedTop / 1024, "###,###,###,###,#0.#0 Kb/S")
lblDownloadSpeedAverage = "Average download speed: " & Format(DownloadSpeedAverage / 1024, "###,###,###,###,#0.#0 Kb/S")
lblUploadSpeedAverage = "Average upload speed: " & Format(UploadSpeedAverage / 1024, "###,###,###,###,#0.#0 Kb/S")
If DS / 1024 < 1 Then
lblDSpeed = Format(DS, "0 BS ")
Else
lblDSpeed = Format(DS / 1024, "0.#0 KBS ")
End If
If US / 1024 < 1 Then
lblUSpeed = Format(US, "0 BS ")
Else
lblUSpeed = Format(US / 1024, "0.#0 KBS ")
End If
UpdateGraph DS, US
LastRecvBytes = BytesRecv
LastSentBytes = BytesSent
LastMoment = Now
If m_objIpHelper.Interfaces.Count <> cboConnectionType.ListCount Then
Dim a As Long
cboConnectionType.Clear
For a = 1 To m_objIpHelper.Interfaces.Count
cboConnectionType.AddItem m_objIpHelper.Interfaces(a).InterfaceDescription & " "
Next
If Val(GetSetting(App.Title, "Setting", "Connection", 0)) + 1 <= cboConnectionType.ListCount Then
cboConnectionType.ListIndex = Val(GetSetting(App.Title, "Setting", "Connection", 0))
Else
cboConnectionType.ListIndex = 0
End If
End If
Log2DB DS, US
tmrUpdate.Enabled = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub UpdateGraph(NewRcv As Long, NewSent As Long)
On Error Resume Next
Dim a As Long, TopRcv As Double, TopSent As Double, vTop As Double, Frq As Long
Frq = 85
For a = 2 To Frq
Rcv(a - 1) = Rcv(a)
Sent(a - 1) = Sent(a)
If Rcv(a) > TopRcv Then TopRcv = Rcv(a)
If Sent(a) > TopSent Then TopSent = Sent(a)
Next
Rcv(Frq) = NewRcv
Sent(Frq) = NewSent
If Rcv(Frq) > TopRcv Then TopRcv = Rcv(Frq)
If Sent(Frq) > TopSent Then TopSent = Sent(Frq)
If TopRcv > TopSent Then vTop = TopRcv Else vTop = TopSent
picGraph.Cls
If Me.Visible Then
If picGraph.BackColor = vbBlack Then picGraph.BackColor = vbWhite
picGraph.PSet (13, 1), vbWhite
picGraph.ForeColor = &HE0E0E0
picGraph.Print ""
picGraph.PSet (11, -1), vbWhite
picGraph.ForeColor = &HFFEFEF
picGraph.Print ""
End If
For a = 1 To Frq
picGraph.Line ((a - 1) * (picGraph.ScaleWidth / Frq), picGraph.ScaleHeight - 1)-(a * (picGraph.ScaleWidth / Frq) - 1, picGraph.ScaleHeight - (picGraph.ScaleHeight * (Rcv(a) / vTop)) - 1), RGB(0, 255, 0), BF
picGraph.Line ((a - 1) * (picGraph.ScaleWidth / Frq), picGraph.ScaleHeight - 1)-(a * (picGraph.ScaleWidth / Frq) - 1, picGraph.ScaleHeight - (picGraph.ScaleHeight * (Sent(a) / vTop)) - 1), RGB(255, 0, 0), BF
Next
If mnuSystemTrayIconTypeAnalog.Checked = True Then
picIcon.PaintPicture picGraph.Image, 0, 0, picIcon.ScaleWidth, picIcon.ScaleHeight, picGraph.ScaleWidth - picGraph.ScaleHeight, 0, picGraph.ScaleHeight, picGraph.ScaleHeight
Else
picIcon.Cls
If TextWidth(Format(NewRcv / 1024, "##0.0")) > picIcon.ScaleWidth Then picIcon.PSet (0, -4) Else picIcon.PSet ((picIcon.ScaleWidth - TextWidth(Format(NewRcv / 1024, "##0.0"))) / 2, -4)
picIcon.ForeColor = RGB(0, 255, 0)
picIcon.Print Format(NewRcv / 1024, "##0.0")
If TextWidth(Format(NewSent / 1024, "##0.0")) > picIcon.ScaleWidth Then picIcon.PSet (0, picIcon.ScaleHeight / 2 - 4) Else picIcon.PSet ((picIcon.ScaleWidth - TextWidth(Format(NewSent / 1024, "##0.0"))) / 2, picIcon.ScaleHeight / 2 - 4)
picIcon.ForeColor = RGB(255, 150, 150)
picIcon.Print Format(NewSent / 1024, "##0.0")
End If
If Not Me.Visible Then
If picGraph.BackColor = vbWhite Then picGraph.BackColor = vbBlack
imgListTray.ListImages.Remove 1
imgListTray.ListImages.Add , , picIcon.Image
ModifyIcon
End If
End Sub
-----------------------------------------------------------------------------------------
Sub Log2DB(DownloadSpeed As Long, UploadSpeed As Long)
If DateDiff("s", LastLogged, Now) < LoggingInterval Or mnuLogToDatabase.Checked = False Then Exit Sub
OpenDatabase(App.Path & "\BM.mdb").Execute "INSERT INTO tblLog (LogDate, LogTime, DownLoadSpeed, UploadSpeed) VALUES (#" & Date & "#, #" & Time & "#, " & DownloadSpeed & ", " & UploadSpeed & ")"
LastLogged = Now
End Sub

2. Modules

     Main

Option Explicit
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowPos& Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Const HWND_TOPMOST = -1
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 19 'Mengganti panjang String dengan panjang szTip
End Type
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_DOALL = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
Private Const WM_MOUSEMOVE = &H200
-----------------------------------------------------------------------------------------
Public Sub DragForm(frm As Form)
On Local Error Resume Next
ReleaseCapture
SendMessage frm.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End Sub
-----------------------------------------------------------------------------------------
Public Sub StayOnTop(frm As Form, OnTop As Boolean)
If OnTop Then
SetWindowPos frm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
Else
SetWindowPos frm.hwnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End If
End Sub
-----------------------------------------------------------------------------------------
Public Sub CreateIcon() 'Pemanggilan method untuk membuat icon
Dim Tic As NOTIFYICONDATA, erg As Long
Tic.cbSize = Len(Tic)
Tic.hwnd = frmMain.picTray.hwnd
Tic.uID = 1&
Tic.uFlags = NIF_DOALL
Tic.uCallbackMessage = WM_MOUSEMOVE
Tic.hIcon = frmMain.picTray.Picture
Tic.szTip = "System Tray Example"
erg = Shell_NotifyIcon(NIM_ADD, Tic)
End Sub
-----------------------------------------------------------------------------------------
Public Sub ModifyIcon() 'Memanggil method untuk memodifikasi icon
Dim Tic As NOTIFYICONDATA, erg As Long
Tic.cbSize = Len(Tic)
Tic.hwnd = frmMain.picTray.hwnd
Tic.uID = 1&
Tic.uFlags = NIF_DOALL
Tic.uCallbackMessage = WM_MOUSEMOVE
Tic.hIcon = frmMain.imgListTray.ListImages(1).ExtractIcon
Tic.szTip = "System Tray Example"
erg = Shell_NotifyIcon(NIM_MODIFY, Tic)
End Sub
-----------------------------------------------------------------------------------------
Public Sub DeleteIcon() 'Memanggil method untuk menghapus icon
Dim Tic As NOTIFYICONDATA, erg As Long
Tic.cbSize = Len(Tic)
Tic.hwnd = frmMain.picTray.hwnd
Tic.uID = 1&
erg = Shell_NotifyIcon(NIM_DELETE, Tic)
End Sub

3. Class Modules

     CInterface

Private m_strInterfaceName As String
Private m_lngInterfaceIndex As Long
Private m_InterfaceType As InterfaceTypes
Private m_lngSpeed As Long
Private m_lngAdapterAddress As String
Private m_AdminStatus As AdminStatuses
Private m_OperationalStatus As OperationalStates
Private m_datLastChange As Date
Private m_lngOctetsReceived As Long
Private m_lngUnicastPacketsReceived As Long
Private m_lngMaximumTransmissionUnit As Long
Private m_lngNonunicastPacketsReceived As Long
Private m_lngDiscardedIncomingPackets As Long
Private m_lngIncomingErrors As Long
Private m_lngUnknownProtocolPackets As Long
Private m_lngOctetsSent As Long
Private m_lngUnicastPacketsSent As Long
Private m_lngNonunicastPacketsSent As Long
Private m_lngDiscardedOutgoingPackets As Long
Private m_lngOutgoingErrors As Long
Private m_lngOutputQueueLength As Long
Private m_lngInterfaceDescription As String
-----------------------------------------------------------------------------------------
Public Property Get InterfaceDescription() As String
InterfaceDescription = m_lngInterfaceDescription
End Property
-----------------------------------------------------------------------------------------
Public Property Let InterfaceDescription(strNewValue As String)
m_lngInterfaceDescription = strNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get OutputQueueLength() As Long
OutputQueueLength = m_lngOutputQueueLength
End Property
-----------------------------------------------------------------------------------------
Public Property Let OutputQueueLength(lngNewValue As Long)
m_lngOutputQueueLength = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get OutgoingErrors() As Long
OutgoingErrors = m_lngOutgoingErrors
End Property
-----------------------------------------------------------------------------------------
Public Property Let OutgoingErrors(lngNewValue As Long)
m_lngOutgoingErrors = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get DiscardedOutgoingPackets() As Long
DiscardedOutgoingPackets = m_lngDiscardedOutgoingPackets
End Property
-----------------------------------------------------------------------------------------
Public Property Let DiscardedOutgoingPackets(lngNewValue As Long)
m_lngDiscardedOutgoingPackets = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get NonunicastPacketsSent() As Long
NonunicastPacketsSent = m_lngNonunicastPacketsSent
End Property
-----------------------------------------------------------------------------------------
Public Property Let NonunicastPacketsSent(lngNewValue As Long)
m_lngNonunicastPacketsSent = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get UnicastPacketsSent() As Long
UnicastPacketsSent = m_lngUnicastPacketsSent
End Property
-----------------------------------------------------------------------------------------
Public Property Let UnicastPacketsSent(lngNewValue As Long)
m_lngUnicastPacketsSent = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get OctetsSent() As Long
OctetsSent = m_lngOctetsSent
End Property
-----------------------------------------------------------------------------------------
Public Property Let OctetsSent(lngNewValue As Long)
m_lngOctetsSent = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get UnknownProtocolPackets() As Long
UnknownProtocolPackets = m_lngUnknownProtocolPackets
End Property
-----------------------------------------------------------------------------------------
Public Property Let UnknownProtocolPackets(lngNewValue As Long)
m_lngUnknownProtocolPackets = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get IncomingErrors() As Long
IncomingErrors = m_lngIncomingErrors
End Property
-----------------------------------------------------------------------------------------
Public Property Let IncomingErrors(lngNewValue As Long)
m_lngIncomingErrors = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get DiscardedIncomingPackets() As Long
DiscardedIncomingPackets = m_lngDiscardedIncomingPackets
End Property
-----------------------------------------------------------------------------------------
Public Property Let DiscardedIncomingPackets(lngNewValue As Long)
m_lngDiscardedIncomingPackets = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get NonunicastPacketsReceived() As Long
NonunicastPacketsReceived = m_lngNonunicastPacketsReceived
End Property
-----------------------------------------------------------------------------------------
Public Property Let NonunicastPacketsReceived(lngNewValue As Long)
m_lngNonunicastPacketsReceived = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get MaximumTransmissionUnit() As Long
MaximumTransmissionUnit = m_lngMaximumTransmissionUnit
End Property
-----------------------------------------------------------------------------------------
Public Property Let MaximumTransmissionUnit(lngNewValue As Long)
m_lngMaximumTransmissionUnit = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get UnicastPacketsReceived() As Long
UnicastPacketsReceived = m_lngUnicastPacketsReceived
End Property
-----------------------------------------------------------------------------------------
Public Property Let UnicastPacketsReceived(lngNewValue As Long)
m_lngUnicastPacketsReceived = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get OctetsReceived() As Long
OctetsReceived = m_lngOctetsReceived
End Property
-----------------------------------------------------------------------------------------
Public Property Let OctetsReceived(lngNewValue As Long)
m_lngOctetsReceived = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get LastChange() As Date
LastChange = m_datLastChange
End Property
-----------------------------------------------------------------------------------------
Public Property Let LastChange(datNewValue As Date)
m_datLastChange = datNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get OperationalStatus() As OperationalStates
OperationalStatus = m_OperationalStatus
End Property
-----------------------------------------------------------------------------------------
Public Property Let OperationalStatus(NewValue As OperationalStates)
m_OperationalStatus = NewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get AdminStatus() As AdminStatuses
AdminStatus = m_AdminStatus
End Property
-----------------------------------------------------------------------------------------
Public Property Let AdminStatus(NewValue As AdminStatuses)
m_AdminStatus = NewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get AdapterAddress() As String
AdapterAddress = m_lngAdapterAddress
End Property
-----------------------------------------------------------------------------------------
Public Property Let AdapterAddress(strNewValue As String)
m_lngAdapterAddress = strNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get Speed() As Long
Speed = m_lngSpeed
End Property
-----------------------------------------------------------------------------------------
Public Property Let Speed(lngNewValue As Long)
m_lngSpeed = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get InterfaceType() As InterfaceTypes
InterfaceType = m_InterfaceType
End Property
-----------------------------------------------------------------------------------------
Public Property Let InterfaceType(NewValue As InterfaceTypes)
m_InterfaceType = NewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get InterfaceIndex() As Long
InterfaceIndex = m_lngInterfaceIndex
End Property
-----------------------------------------------------------------------------------------
Public Property Let InterfaceIndex(lngNewValue As Long)
m_lngInterfaceIndex = lngNewValue
End Property
-----------------------------------------------------------------------------------------
Public Property Get InterfaceName() As String
InterfaceName = m_strInterfaceName
End Property
-----------------------------------------------------------------------------------------
Public Property Let InterfaceName(strNewValue As String)
m_strInterfaceName = strNewValue
End Property

     CInterfaces

Private mCol As Collection
-----------------------------------------------------------------------------------------
Public Function Add(objInterface As CInterface) As CInterface
mCol.Add objInterface
'Mengembalikan objek yang dibuat
Set Add = objInterface
Set objInterface = Nothing
End Function
-----------------------------------------------------------------------------------------
Public Property Get Item(vntIndexKey As Variant) As CInterface
'Digunakan untuk referensi elemen
'vntIndexKey mengandung indeks atau kunci,
'Menyatakan variant
'Syntax: Set foo = x.Item(xyz) or Set foo = x.Item(5)
Set Item = mCol(vntIndexKey)
End Property
-----------------------------------------------------------------------------------------
Public Property Get Count() As Long
'Digunakan untuk mengambil jumlah elemen pada
'collection. Syntax: Debug.Print x.Count
Count = mCol.Count
End Property
-----------------------------------------------------------------------------------------
Public Sub Remove(vntIndexKey As Variant)
'Digunakan untuk menghapus elemen
'vntIndexKey mengandung indeks atau kunci yang dinyatakan sebagai variant
'Syntax: x.Remove(xyz)
mCol.Remove vntIndexKey
End Sub
-----------------------------------------------------------------------------------------
Public Property Get NewEnum() As IUnknown
'Properti ini untuk menghitung dengan sintak For...Each
Set NewEnum = mCol.[_NewEnum]
End Property
-----------------------------------------------------------------------------------------
Private Sub Class_Initialize()
'Menciptakan koleksi ketika membuat class
Set mCol = New Collection
End Sub
-----------------------------------------------------------------------------------------
Private Sub Class_Terminate()
'Menghapus koleksi ketika mengakhiri class
Set mCol = Nothing
End Sub

     CIpHelper

Option Explicit
Public Enum OperationalStates
MIB_IF_OPER_STATUS_NON_OPERATIONAL = 0
MIB_IF_OPER_STATUS_UNREACHABLE = 1
MIB_IF_OPER_STATUS_DISCONNECTED = 2
MIB_IF_OPER_STATUS_CONNECTING = 3
MIB_IF_OPER_STATUS_CONNECTED = 4
MIB_IF_OPER_STATUS_OPERATIONAL = 5
End Enum
Public Enum InterfaceTypes
MIB_IF_TYPE_OTHER = 1
MIB_IF_TYPE_ETHERNET = 6
MIB_IF_TYPE_TOKENRING = 9
MIB_IF_TYPE_FDDI = 15
MIB_IF_TYPE_PPP = 23
MIB_IF_TYPE_LOOPBACK = 24
MIB_IF_TYPE_SLIP = 28
End Enum
Public Enum AdminStatuses
MIB_IF_ADMIN_STATUS_UP = 1
MIB_IF_ADMIN_STATUS_DOWN = 2
MIB_IF_ADMIN_STATUS_TESTING = 3
End Enum
Private Const MAXLEN_IFDESCR = 256
Private Const MAXLEN_PHYSADDR = 8
Private Const MAX_INTERFACE_NAME_LEN = 256
Private Const ERROR_NOT_SUPPORTED = 50&
Private Const ERROR_SUCCESS = 0&
Private Type MIB_IFROW
wszName(0 To 511) As Byte
dwIndex As Long
dwType As Long
dwMtu As Long
dwSpeed As Long
dwPhysAddrLen As Long
bPhysAddr(0 To 7) 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 255) As Byte
End Type
Private Declare Function GetIfTable Lib "IPHlpApi" (ByRef pIfRowTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDest As Any, ByRef pSource As Any, ByVal Length As Long)
Private mvarInterfaces As CInterfaces
Private m_lngBytesReceived As Long
Private m_lngBytesSent As Long
-----------------------------------------------------------------------------------------
Public Property Set Interfaces(ByVal vData As CInterfaces)
Set mvarInterfaces = vData
End Property
-----------------------------------------------------------------------------------------
Public Property Get Interfaces() As CInterfaces
Set mvarInterfaces = Nothing
Set mvarInterfaces = New CInterfaces
Call InitInterfaces(mvarInterfaces)
Set Interfaces = mvarInterfaces
End Property
-----------------------------------------------------------------------------------------
Public Property Get BytesReceived() As Double
BytesReceived = m_lngBytesReceived
End Property
-----------------------------------------------------------------------------------------
Public Property Get BytesSent() As Double
BytesSent = m_lngBytesSent
End Property
-----------------------------------------------------------------------------------------
Private Function InitInterfaces(objInterfaces As CInterfaces) As Boolean
On Error Resume Next
Dim arrBuffer() As Byte
Dim lngSize As Long
Dim lngRetVal As Long
Dim lngRows As Long
Dim i As Integer
Dim j As Integer
Dim IfRowTable As MIB_IFROW
Dim objInterface As New CInterface
lngSize = 0
'Mereset BytesReceived and BytesSent
m_lngBytesReceived = 0
m_lngBytesSent = 0
'Panggil GetIfTable untuk mendapatkan ukuran buffer ke dalam variabel lngSize
lngRetVal = GetIfTable(ByVal 0&, lngSize, 0)
If lngRetVal = ERROR_NOT_SUPPORTED Then
Exit Function
End If
'Menyiapkan buffer
ReDim arrBuffer(0 To lngSize - 1) As Byte
'Memanggil fungsi sekali lagi
lngRetVal = GetIfTable(arrBuffer(0), lngSize, 0)
If lngRetVal = ERROR_SUCCESS Then
'Nilai panjang untuk tabel baris
CopyMemory lngRows, arrBuffer(0), 4
For i = 1 To lngRows
'Menyalin tabel baris data dengan struktur IfRowTable
CopyMemory IfRowTable, arrBuffer(4 + (i - 1) * Len(IfRowTable)), Len(IfRowTable)
With IfRowTable
objInterface.InterfaceDescription = Left(StrConv(.bDescr, vbUnicode), .dwDescrLen)
If .dwPhysAddrLen > 0 Then
For j = 0 To .dwPhysAddrLen - 1
objInterface.AdapterAddress = objInterface.AdapterAddress & _
CStr(IIf(.bPhysAddr(j) = 0, "00", Hex(.bPhysAddr(j)))) & "-"
Next j
objInterface.AdapterAddress = Left(objInterface.AdapterAddress, Len(objInterface.AdapterAddress) - 1)
End If
objInterface.AdminStatus = .dwAdminStatus
objInterface.InterfaceIndex = .dwIndex
objInterface.DiscardedIncomingPackets = .dwInDiscards
objInterface.IncomingErrors = .dwInErrors
objInterface.NonunicastPacketsReceived = .dwInNUcastPkts
objInterface.OctetsReceived = .dwInOctets
objInterface.UnicastPacketsReceived = .dwInUcastPkts
objInterface.UnknownProtocolPackets = .dwInUnknownProtos
objInterface.LastChange = .dwLastChange
objInterface.MaximumTransmissionUnit = .dwMtu
objInterface.OperationalStatus = .dwOperStatus
objInterface.DiscardedOutgoingPackets = .dwOutDiscards
objInterface.OutgoingErrors = .dwOutErrors
objInterface.NonunicastPacketsSent = .dwOutNUcastPkts
objInterface.OctetsSent = .dwOutOctets
objInterface.OutputQueueLength = .dwOutQLen
objInterface.UnicastPacketsSent = .dwOutUcastPkts
objInterface.Speed = .dwSpeed
objInterface.InterfaceType = .dwType
objInterface.InterfaceName = StrConv(.wszName, vbUnicode)
'Kumpulan informasi untuk semua interface
m_lngBytesReceived = m_lngBytesReceived + .dwInOctets
m_lngBytesSent = m_lngBytesSent + .dwOutOctets
End With
mvarInterfaces.Add objInterface
Next i
End If
End Function

Sekian dulu informasi dari saya, bila ada pertanyaan bisa lewat kotak komentar.
Terima kasih, semoga bermanfaat!

Baca Juga Artikel Terkait :