![[MÓDULO] mGeoIP Info1810](https://i.servimg.com/u/f21/15/51/87/91/info1810.png)
Para ver Todo el contenido del foro es necesario estar Registrado! 
Jue Jun 02, 2011 3:43 pm
- Código:
Option Explicit
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' MODULO : mGeoIP |||
' FECHA : 28/10/2010 00:38 |||
' AUTOR : Fakedo0r |||
' CORREO : [Tienes que estar registrado y conectado para ver este vínculo] |||
' CREDITOS : JhonJhon_123 |||
' DESCRIPCION : Localizar IP |||
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'==============================================================================
' --- APIS
'==============================================================================
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Long
Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInet As Long) As Long
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
'==============================================================================
' --- CONSTANTES
'==============================================================================
Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Const HTTP_QUERY_CONTENT_LENGTH As Long = 5
'==============================================================================
' --- TYPES
'==============================================================================
Public Type GeoDatos
Country As String
City As String
End Type
'==============================================================================
' --- FUNCION INET
'==============================================================================
Private Function DescargaWeb(URL As String) As String
Dim Gestor As Long
Dim GestorURL As Long
Dim BytesTotal As Long
Dim LenBufferSize As Long
Dim Buffer As String
Dim Agente As String
Dim Data As String
Dim BufferSize As String
Dim Res As Integer
Agente = "By Fakedo0r"
Gestor = InternetOpen(Agente, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
GestorURL = InternetOpenUrl(Gestor, URL, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)
Buffer = String(1024, Chr(0))
BufferSize = Space(1024)
LenBufferSize = Len(BufferSize)
If HttpQueryInfo(GestorURL, HTTP_QUERY_CONTENT_LENGTH, ByVal BufferSize, LenBufferSize, 0) <> 0 Then
BufferSize = Left(BufferSize, LenBufferSize)
End If
If Gestor <> 0 Then
Res = InternetReadFile(GestorURL, Buffer, 1024, BytesTotal)
If Res <> 0 Then
Data = Buffer
Do While BytesTotal <> 0
Res = InternetReadFile(GestorURL, Buffer, 1024, BytesTotal)
If Res <> 0 Then
Data = Data & Mid(Buffer, 1, BytesTotal)
End If
DoEvents
Loop
End If
End If
InternetCloseHandle Gestor
InternetCloseHandle GestorURL
DescargaWeb = Data
End Function
'==============================================================================
' --- FUNCION LOCALIZAR IP
'==============================================================================
Public Function GeoIPInfo(IP As String) As GeoDatos
Dim URL As String
Dim Datos As String
Dim sDatos() As String
Dim Part1 As String
Dim Part2 As String
Dim Part3 As String
Dim Pos1 As String
Dim Nombre As String
Dim Final As String
Dim Data As Variant
Dim aDatos As GeoDatos
URL = "http://www.geoipview.com/?q="
URL = URL & IP
Datos = DescargaWeb(URL)
Part1 = "align=absmiddle alt=" & Chr(34) & "" & Chr(34) & "></td>"
Pos1 = InStr(1, Datos, Part1)
Datos = Mid$(Datos, Pos1 + Len(Part1), Len(Datos))
Part1 = "</TABLE>"
Pos1 = InStr(1, Datos, Part1)
Datos = Left$(Datos, Pos1 - 1)
sDatos = Split(Datos, "<TR><TD class=" & Chr(34) & "show1" & Chr(34) & " nowrap>")
For Each Data In sDatos
Part1 = ": </td><td class=" & Chr(34) & "show2" & Chr(34) & ">"
Part2 = "</td>"
Pos1 = InStr(1, Data, Part1)
If Pos1 = 0 Then GoTo Error
Nombre = Left$(Data, Pos1 - 1)
Part3 = Mid$(Data, Pos1 + Len(Part1), Len(Data))
Final = Split(Part3, Part2)(0)
Select Case Nombre
Case "Country"
aDatos.Country = Final
Case "City"
aDatos.City = Final
End Select
Error:
Next
GeoIPInfo = aDatos
End Function
