Option Explicit Private Const WS_VERSION_REQD = &H101 Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF& Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF& Private Const MIN_SOCKETS_REQD = 1 Private Const SOCKET_ERROR = -1 Private Const WSADescription_Len = 256 Private Const WSASYS_Status_Len = 128 Private Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As Long End Type Private Type WSADATA wversion As Integer wHighVersion As Integer szDescription(0 To WSADescription_Len) As Byte szSystemStatus(0 To WSASYS_Status_Len) As Byte iMaxSockets As Integer iMaxUdpDg As Integer lpszVendorInfo As Long End Type Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal hostname$, ByVal HostLen As Long) As Long Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&) Private Function hibyte(ByVal wParam As Integer) hibyte = wParam \ &H100 And &HFF& End Function Private Function lobyte(ByVal wParam As Integer) lobyte = wParam And &HFF& End Function Private Sub SocketsInitialize() Dim WSAD As WSADATA Dim iReturn As Integer Dim sLowByte As String, sHighByte As String, sMsg As String iReturn = WSAStartup(WS_VERSION_REQD, WSAD) If iReturn = 0 Then If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = _ WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then sHighByte = Trim$(Str$(hibyte(WSAD.wversion))) sLowByte = Trim$(Str$(lobyte(WSAD.wversion))) sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte 'Debug.Print sMsg 'sMsg = sMsg & " winsock.dll tarafindan desteklenmiyor. " 'MsgBox sMsg 'End End If Else 'Debug.Print "Winsock.dll Error." End If End Sub Public Function GetCurrentIP(ByVal blnExternalIP As Boolean) As String Dim hostname As String * 256 Dim hostent_addr As Long Dim host As HOSTENT Dim hostip_addr As Long Dim temp_ip_address() As Byte Dim i As Integer Dim ip_address As String Dim IP As String Dim Internal As String Dim EXTERNAL As String If gethostname(hostname, 256) <> SOCKET_ERROR Then hostname = Trim$(hostname) hostent_addr = gethostbyname(hostname) If hostent_addr <> 0 Then RtlMoveMemory host, hostent_addr, LenB(host) RtlMoveMemory hostip_addr, host.hAddrList, 4 Do ReDim temp_ip_address(1 To host.hLength) RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength For i = 1 To host.hLength ip_address = ip_address & temp_ip_address(i) & "." Next ip_address = Mid$(ip_address, 1, Len(ip_address) - 1) ' Return Both LAN and External IP Fix ' Master Yoda 30-05-2000 ' ########################################## ' HERE'S THE PROBLEM!!! 'TheIP = TheIP + ip_address ' ########################################## ' HERE'S THE FIX!!! Internal = IP ' Send ONLY the External IP to the CurrentIP Function EXTERNAL = ip_address ' Send the External IP to the function parameter External IP = ip_address ' Send LAN IP to the function para Internal ' You don't really need to return parameters, ' it just allows you to get both IPs :) ' ########################################## ip_address = "" host.hAddrList = host.hAddrList + LenB(host.hAddrList) RtlMoveMemory hostip_addr, host.hAddrList, 4 Loop While (hostip_addr <> 0) If blnExternalIP = True Then GetCurrentIP = EXTERNAL Else GetCurrentIP = Internal End If Else 'Debug.Print "Winsock.dll error." GetCurrentIP = "" End If Else 'Debug.Print "Windows Socket Error " & Str(WSAGetLastError()) GetCurrentIP = "" End If End Function Private Sub SocketsCleanup() Dim lReturn As Long lReturn = WSACleanup() If lReturn <> 0 Then 'MsgBox "Socket Error " & Trim$(Str$(lReturn)) & " occurred In Cleanup " End If End Sub Private Sub Class_Initialize() SocketsInitialize End Sub Private Sub Class_Terminate() SocketsCleanup End Sub |
|