1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
|
Option Explicit
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
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 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)
Private Declare Function inet_ntoa Lib "wsock32" (ByVal addr As Long) As
Long
Private Declare Function lstrcpyA Lib "kernel32" _
(ByVal RetVal As String, _
ByVal Ptr As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal Ptr As Any) As Long
Private Declare Function GetFriendlyIfIndex Lib "iphlpapi" (ByVal IfIndex As
Long) As Long
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(, , "last 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")
End With
End Sub
Public Function GetInetStrFromPtr(ByVal Address As Long) As String
GetInetStrFromPtr = GetStrFromPtrA(inet_ntoa(Address))
End Function
Public Function GetStrFromPtrA(ByVal lpszA As Long) As String
GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function
Private Sub Command1_Click()
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
Dim n As Long
Dim itmx As ListItem
Dim tmp As String
Call GetIfTable(ByVal 0&, cbRequired, 1)
If cbRequired > 0 Then
ReDim buff(0 To cbRequired - 1) As Byte
If GetIfTable(buff(0), cbRequired, 1) = ERROR_SUCCESS Then
'saves using LenB in the CopyMemory calls below
nStructSize = LenB(IPInterfaceRow)
'first 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 IPInterfaceRow type
CopyMemory IPInterfaceRow, buff(4 + (cnt - 1) * nStructSize),
nStructSize
With Listview1
.ColumnHeaders.Add , , "Adapter " & CStr(cnt)
Set itmx = .ListItems(1)
itmx.SubItems(cnt) = TrimNull(StrConv(IPInterfaceRow.bDescr,
vbUnicode))
Set itmx = .ListItems(2)
itmx.SubItems(cnt) =
GetFriendlyIfIndex(IPInterfaceRow.dwIndex)
Select Case IPInterfaceRow.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) = IPInterfaceRow.dwType & " " & tmp
tmp = ""
Set itmx = .ListItems(4)
itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwMtu, 0)
Set itmx = .ListItems(5)
itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwSpeed, 0)
For n = 0 To IPInterfaceRow.dwPhysAddrLen - 1
tmp = tmp & IPInterfaceRow.bPhysAddr(n) & " "
Next
Print
Set itmx = .ListItems(6)
itmx.SubItems(cnt) = tmp
tmp = ""
For n = 0 To IPInterfaceRow.dwPhysAddrLen - 1
tmp = tmp & Hex(IPInterfaceRow.bPhysAddr(n)) & " "
Next
Print
Set itmx = .ListItems(7)
itmx.SubItems(cnt) = tmp
tmp = ""
Select Case IPInterfaceRow.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) = IPInterfaceRow.dwAdminStatus & " " & tmp
tmp = ""
Select Case IPInterfaceRow.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) = IPInterfaceRow.dwOperStatus & " " & tmp
tmp = ""
Set itmx = .ListItems(10)
itmx.SubItems(cnt) = IPInterfaceRow.dwLastChange
Set itmx = .ListItems(11)
itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwInOctets,
0)
Set itmx = .ListItems(12)
itmx.SubItems(cnt) =
FormatNumber(IPInterfaceRow.dwInUcastPkts, 0)
Set itmx = .ListItems(13)
itmx.SubItems(cnt) =
FormatNumber(IPInterfaceRow.dwInNUcastPkts, 0)
Set itmx = .ListItems(14)
itmx.SubItems(cnt) =
FormatNumber(IPInterfaceRow.dwInDiscards, 0)
Set itmx = .ListItems(15)
itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwInErrors,
0)
Set itmx = .ListItems(16)
itmx.SubItems(cnt) =
FormatNumber(IPInterfaceRow.dwInUnknownProtos, 0)
Set itmx = .ListItems(17)
itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwOutOctets,
0)
Set itmx = .ListItems(18)
itmx.SubItems(cnt) =
FormatNumber(IPInterfaceRow.dwOutUcastPkts, 0)
Set itmx = .ListItems(19)
itmx.SubItems(cnt) =
FormatNumber(IPInterfaceRow.dwOutNUcastPkts, 0)
Set itmx = .ListItems(20)
itmx.SubItems(cnt) =
FormatNumber(IPInterfaceRow.dwOutDiscards, 0)
Set itmx = .ListItems(21)
itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwOutErrors,
0)
Set itmx = .ListItems(22)
itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwOutQLen,
0)
End With 'Listview1
Next cnt
End If 'If GetIfTable( ...
End If 'If cbRequired > 0
End Sub
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 |
Qui sait manipuler l'API wlanapi.dll ?
Répondre avec citation
Partager