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
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
| Option Explicit
Private Const INTERNET_CONNECTION_LAN = &H2
Private Const INTERNET_CONNECTION_MODEM = &H1
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Const WS_VERSION_REQD As Long = &H101
Private Const PING_TIMEOUT As Long = 500
Public Enum tPingError
PingError_InvalidTarget = 0
PingError_Timeout = -1
PingError_Other = -2
End Enum
Private Type ICMP_OPTIONS
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Private Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Long
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription As String * MAX_WSADescription
szSystemStatus As String * MAX_WSASYSStatus
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Declare Function InternetGetConnectedState Lib "wininet.dll" ( _
ByRef lpdwFlags As Long, _
ByVal dwReserved As Long _
) As Long
Private Declare Function gethostbyname Lib "wsock32" ( _
ByVal HostName As String _
) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long _
)
Public Declare Function WSAStartup Lib "wsock32" _
(ByVal wVersionRequired As Long, _
lpWSADATA As WSADATA) As Long
Public Declare Function WSACleanup Lib "wsock32" () As Long
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" ( _
ByVal IcmpHandle As Long _
) As Long
Private Declare Function IcmpSendEcho Lib "icmp.dll" ( _
ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Long, _
ByVal RequestOptions As Long, _
ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, _
ByVal Timeout As Long) As Long
Public Function GetFullHostNameFromHostName( _
ByVal HostName As String _
) As String
' Return the full host name from a host name.
Dim HostEntry As HOSTENT
Dim HostEntryPtr As Long
Dim IPAddressesPtr As Long
Dim Result As String
If InitializeSockets Then
HostEntryPtr = gethostbyname(HostName & vbNullChar)
If HostEntryPtr > 0 Then
CopyMemory HostEntry, ByVal HostEntryPtr, Len(HostEntry)
Result = Space(256)
CopyMemory ByVal Result, ByVal HostEntry.hName, 256
Result = Left(Result, InStr(Result, vbNullChar) - 1)
GetFullHostNameFromHostName = Result
End If
End If
End Function
Public Function GetIPAddressFromHostName( _
ByVal HostName As String _
) As Long
' Return the IP address from a host name as a long.
Dim HostEntry As HOSTENT
Dim HostEntryPtr As Long
Dim IPAddressesPtr As Long
Dim Result As Long
If InitializeSockets Then
HostEntryPtr = gethostbyname(HostName & vbNullChar)
If HostEntryPtr > 0 Then
CopyMemory HostEntry, ByVal HostEntryPtr, Len(HostEntry)
CopyMemory IPAddressesPtr, ByVal HostEntry.hAddrList, 4
CopyMemory Result, ByVal IPAddressesPtr, 4
GetIPAddressFromHostName = Result
End If
End If
End Function
Public Function GetIPAddressFromString( _
ByVal IPAddress As String _
) As Long
' Return the long form of the string IP address.
Dim Octets As Variant
Dim HexString As String
Dim Index As Long
Octets = Split(IPAddress, ".")
If UBound(Octets) <> 3 Then Exit Function
For Index = 0 To 3
If Not IsNumeric(Octets(Index)) Then Exit Function
Next Index
GetIPAddressFromString = CLng("&H" & _
Right("0" & Hex(Octets(0)), 2) _
& Right("0" & Hex(Octets(1)), 2) _
& Right("0" & Hex(Octets(2)), 2) _
& Right("0" & Hex(Octets(3)), 2))
End Function
Public Function GetNormalizedIPAddress( _
ByVal Text As String, _
Optional ByVal ZeroPadOctets As Long = 0 _
) As String
' Convert text to IP address. Text can be any value or an eight character
' hexidecimal number. Examples:
'
' 0 -> 0.0.0.0
' 255.10 -> 255.10.0.0
' FFFE0001 -> 255.254.0.1
' 258.-1.0.0 -> 255.0.0.0
'
' Use the parameter ZeroPadOctets to pad each octet with zeroes. Pass a
' positive integer from 1 to 4 to pad that number of octets starting from
' the left. Pass a negative integer from -1 to -4 to pad that number of
' octets starting from the right.
Dim Nodes As Variant
Dim Index As Long
Dim Result As String
If Len(Text) > 0 Then
Nodes = Split(Text, ".")
If UBound(Nodes) = 0 And Len(Nodes(0)) = 8 Then
ReDim Nodes(0 To 3)
For Index = 0 To 3
Nodes(Index) = CStr(CLng("&H" & Mid(Text, Index * 2 + 1, 2)))
Next Index
End If
For Index = 0 To UBound(Nodes)
If Not IsNumeric(Nodes(Index)) Then Nodes(Index) = 0
Nodes(Index) = Application.Max(0, Application.Min(255, Nodes(Index)))
Next Index
Result = Join(Nodes, ".") & Left(".0.0.0", 6 - UBound(Nodes) * 2)
Nodes = Split(Result, ".")
If ZeroPadOctets > 0 Then
For Index = 0 To 3
If Index + 1 <= ZeroPadOctets Then Nodes(Index) = Right("00" & Nodes(Index), 3)
Next Index
Else
For Index = 0 To 3
If 4 - Index <= -ZeroPadOctets Then Nodes(Index) = Right("00" & Nodes(Index), 3)
Next Index
End If
GetNormalizedIPAddress = Join(Nodes, ".")
End If
End Function
Public Function GetStringFromIPAddress( _
ByVal IPAddress As Long _
) As String
' Return the string form of the IP address.
Dim IPAddressString As String
Dim Index As Long
IPAddressString = Space(4)
CopyMemory ByVal IPAddressString, IPAddress, 4
GetStringFromIPAddress = _
Asc(Mid$(IPAddressString, 1, 1)) _
& "." _
& Asc(Mid$(IPAddressString, 2, 1)) _
& "." _
& Asc(Mid$(IPAddressString, 3, 1)) _
& "." _
& Asc(Mid$(IPAddressString, 4, 1))
End Function
Public Function InitializeSockets() As Boolean
' Initialize Windows sockets.
Dim WinSockData As WSADATA
InitializeSockets = WSAStartup(WS_VERSION_REQD, WinSockData) = 0
End Function
Public Function IsInternetConnectionDialUp() As Boolean
' Return True if a dial up Internet connection is active, False otherwise.
Dim Result As Boolean
Dim Flags As Long
Result = InternetGetConnectedState(Flags, 0&)
If (Flags And INTERNET_CONNECTION_MODEM) > 0 Then
IsInternetConnectionDialUp = True
End If
End Function
Public Function IsInternetConnectionLAN() As Boolean
' Return True if a LAN Internet connection is active, False otherwise.
Dim Result As Boolean
Dim Flags As Long
Result = InternetGetConnectedState(Flags, 0&)
If (Flags And INTERNET_CONNECTION_LAN) > 0 Then
IsInternetConnectionLAN = True
End If
End Function
Public Function IsInternetConnectionOnline() As Boolean
' Return True is an Internet connection is available, False otherwise.
Dim Result As Boolean
Dim Flags As Long
Result = InternetGetConnectedState(Flags, 0&)
If Result Then
IsInternetConnectionOnline = True
End If
End Function
Public Function IsServerAvailable( _
ByVal Path As String _
) As Boolean
' Return true if the server or path is available, False otherwise. If the
' server is not local and is not available the response time can be five
' to ten seconds.
On Error Resume Next
ChDir Path
IsServerAvailable = Err <> 76
End Function
Public Function Ping( _
ByVal Target As Variant, _
Optional ByVal Data As String = " " _
) As tPingError
' Ping the target and return the round trip time in milliseconds or a negative
' value describing the failure. Target can be a host name, string IP address,
' or long IP address.
Dim IPAddress As Long
Dim Port As Long
Dim EchoReply As ICMP_ECHO_REPLY
Select Case VarType(Target)
Case vbLong
IPAddress = Target
Case vbString
IPAddress = GetIPAddressFromString(Target)
If IPAddress = 0 Then
IPAddress = GetIPAddressFromHostName(Target)
If IPAddress = 0 Then
Ping = PingError_InvalidTarget
Exit Function
End If
End If
Case Else
Stop ' Target must be a string or a long
End Select
' Initialize Windows sockets
If Not InitializeSockets Then
Ping = PingError_Other
Exit Function
End If
' Open a port
Port = IcmpCreateFile()
If Port = 0 Then
TerminateSockets
Ping = PingError_Other
Exit Function
End If
' Ping the IP adddress
IcmpSendEcho Port, IPAddress, Data, Len(Data), 0, EchoReply, Len(EchoReply), PING_TIMEOUT
' Evaluate ping response
If EchoReply.status = IP_REQ_TIMED_OUT Then
Ping = PingError_Timeout
ElseIf EchoReply.status <> 0 Then
Ping = PingError_Other
Else
Ping = EchoReply.RoundTripTime
End If
' Cleanup
IcmpCloseHandle Port
TerminateSockets
End Function
Public Sub TerminateSockets()
' Terminate Windows sockets.
WSACleanup
End Sub |
