home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Server_Key3610311192001.psc / modGetIP.bas < prev    next >
Encoding:
BASIC Source File  |  2001-11-16  |  4.6 KB  |  180 lines
  1. Attribute VB_Name = "modGetIP"
  2. Public Const MAX_WSADescription = 256
  3. Public Const MAX_WSASYSStatus = 128
  4. Public Const ERROR_SUCCESS As Long = 0
  5. Public Const WS_VERSION_REQD As Long = &H101
  6. Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
  7. Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
  8. Public Const MIN_SOCKETS_REQD As Long = 1
  9. Public Const SOCKET_ERROR As Long = -1
  10.  
  11.  
  12. Public Type HOSTENT
  13.     hName As Long
  14.     hAliases As Long
  15.     hAddrType As Integer
  16.     hLen As Integer
  17.     hAddrList As Long
  18.     End Type
  19.  
  20.  
  21. Public Type WSADATA
  22.     wVersion As Integer
  23.     wHighVersion As Integer
  24.     szDescription(0 To MAX_WSADescription) As Byte
  25.     szSystemStatus(0 To MAX_WSASYSStatus) As Byte
  26.     wMaxSockets As Integer
  27.     wMaxUDPDG As Integer
  28.     dwVendorInfo As Long
  29.     End Type
  30.  
  31.  
  32. Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
  33.  
  34.  
  35. Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
  36.     (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
  37.  
  38.  
  39. Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
  40.  
  41.  
  42. Public Declare Function gethostname Lib "WSOCK32.DLL" _
  43.     (ByVal szHost As String, ByVal dwHostLen As Long) As Long
  44.  
  45.  
  46. Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
  47.     (ByVal szHost As String) As Long
  48.  
  49.  
  50. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
  51.     (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
  52.  
  53.  
  54. Public Function GetIPAddress() As String
  55.     Dim sHostName As String * 256
  56.     Dim lpHost As Long
  57.     Dim HOST As HOSTENT
  58.     Dim dwIPAddr As Long
  59.     Dim tmpIPAddr() As Byte
  60.     Dim i As Integer
  61.     Dim sIPAddr As String
  62.  
  63.  
  64.     If Not SocketsInitialize() Then
  65.         GetIPAddress = ""
  66.         Exit Function
  67.     End If
  68.  
  69.  
  70.     If gethostname(sHostName, 256) = SOCKET_ERROR Then
  71.         GetIPAddress = ""
  72.         MsgBox "Windows Sockets Error " & Str$(WSAGetLastError()) & _
  73.         " has occurred. Unable To successfully Get Host Name."
  74.         SocketsCleanup
  75.         Exit Function
  76.     End If
  77.     sHostName = Trim$(sHostName)
  78.     lpHost = gethostbyname(sHostName)
  79.  
  80.  
  81.     If lpHost = 0 Then
  82.         GetIPAddress = ""
  83.         MsgBox "Windows Sockets are Not responding. " & _
  84.         "Unable To successfully Get Host Name."
  85.         SocketsCleanup
  86.         Exit Function
  87.     End If
  88.     CopyMemory HOST, lpHost, Len(HOST)
  89.     CopyMemory dwIPAddr, HOST.hAddrList, 4
  90.     ReDim tmpIPAddr(1 To HOST.hLen)
  91.     CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
  92.  
  93.  
  94.     For i = 1 To HOST.hLen
  95.         sIPAddr = sIPAddr & tmpIPAddr(i) & "."
  96.     Next
  97.     GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
  98.     SocketsCleanup
  99. End Function
  100.  
  101.  
  102. Public Function GetIPHostName() As String
  103.     Dim sHostName As String * 256
  104.  
  105.  
  106.     If Not SocketsInitialize() Then
  107.         GetIPHostName = ""
  108.         Exit Function
  109.     End If
  110.  
  111.  
  112.     If gethostname(sHostName, 256) = SOCKET_ERROR Then
  113.         GetIPHostName = ""
  114.         MsgBox "Windows Sockets Error " & Str$(WSAGetLastError()) & _
  115.         " has occurred. Unable To successfully Get Host Name."
  116.         SocketsCleanup
  117.         Exit Function
  118.     End If
  119.     GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
  120.     SocketsCleanup
  121. End Function
  122.  
  123.  
  124. Public Function HiByte(ByVal wParam As Integer)
  125.     HiByte = wParam \ &H100 And &HFF&
  126.     
  127. End Function
  128.  
  129.  
  130. Public Function LoByte(ByVal wParam As Integer)
  131.     LoByte = wParam And &HFF&
  132. End Function
  133.  
  134.  
  135. Public Sub SocketsCleanup()
  136.  
  137.  
  138.     If WSACleanup() <> ERROR_SUCCESS Then
  139.         MsgBox "Socket Error occurred In Cleanup."
  140.     End If
  141. End Sub
  142.  
  143.  
  144. Public Function SocketsInitialize() As Boolean
  145.     Dim WSAD As WSADATA
  146.     Dim sLoByte As String
  147.     Dim sHiByte As String
  148.  
  149.  
  150.     If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
  151.         MsgBox "The 32-bit Windows Socket is Not responding."
  152.         SocketsInitialize = False
  153.         Exit Function
  154.     End If
  155.  
  156.  
  157.     If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
  158.         MsgBox "This application requires a minimum of " & _
  159.         CStr(MIN_SOCKETS_REQD) & " supported sockets."
  160.         SocketsInitialize = False
  161.         Exit Function
  162.     End If
  163.     If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
  164.     (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
  165.     HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
  166.     
  167.     sHiByte = CStr(HiByte(WSAD.wVersion))
  168.     sLoByte = CStr(LoByte(WSAD.wVersion))
  169.     
  170.     MsgBox "Sockets version " & sLoByte & "." & sHiByte & _
  171.     " is Not supported by 32-bit Windows Sockets."
  172.     
  173.     SocketsInitialize = False
  174.     Exit Function
  175.     
  176. End If
  177. SocketsInitialize = True
  178. End Function
  179.  
  180.