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