-
Notifications
You must be signed in to change notification settings - Fork 0
/
mdlNetwork.bas
141 lines (120 loc) · 5.39 KB
/
mdlNetwork.bas
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
Attribute VB_Name = "mdlNetwork"
'Copyright (c)
'
'This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version.
'This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
'You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
'The code in this module is based on the code provided by Richard Deeming, richard (at) trinet.co.uk
'
Option Explicit
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const ERROR_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type
Private Declare Function gethostbyaddr Lib "wsock32.dll" (ByRef dwHost As Long, ByVal hLen As Integer, ByVal aType As Integer) As Long
Private Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Function gethostname Lib "wsock32.dll" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "wsock32.dll" (ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H1 And &HFF&
End Function
Private Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function
Private Sub SocketsCleanup()
If WSACleanup() <> ERROR_SUCCESS Then
App.LogEvent "Socket error occurred in Cleanup.", _
vbLogEventTypeError
End If
End Sub
Private Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA, sLoByte As String, sHiByte As String
If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
DB.X "Warning: The 32-bit Windows Socket is not responding."
SocketsInitialize = False
Exit Function
End If
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
DB.X "Warning: This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets."
SocketsInitialize = False
Exit Function
End If
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
sHiByte = CStr(HiByte(WSAD.wVersion))
sLoByte = CStr(LoByte(WSAD.wVersion))
DB.X "Warning: Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets."
SocketsInitialize = False
Exit Function
End If
SocketsInitialize = True
End Function
Public Function GetIPAddress(Optional ByVal sHost As String, Optional serrmsg As String) As String
'Resolves the host-name (or current machine if balnk) to an IP address
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
Dim werr As Long
If Not SocketsInitialize() Then
GetIPAddress = vbNullString
Exit Function
End If
If LenB(sHost) = 0 Then
If gethostname(sHostName, 256) = SOCKET_ERROR Then
werr = WSAGetLastError()
GetIPAddress = vbNullString
DB.X "Warning: Windows Sockets error " & Str(werr) & " occurred. Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
sHostName = Trim$(sHostName)
Else
sHostName = Trim$(sHost) & ChrW$(0)
End If
lpHost = gethostbyname(sHostName)
If lpHost = 0 Then
werr = WSAGetLastError()
GetIPAddress = vbNullString
serrmsg = "Windows Sockets error " & Str$(werr) & _
" has occurred. Unable to successfully get Host Name." & vbNewLine
GetIPAddress = vbNullString
SocketsCleanup
Exit Function
End If
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
ReDim tmpIPAddr(1 To HOST.hLen)
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
For i = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
SocketsCleanup
End Function