Saber tu IP con Visual Basic 6. Proyecto. (similar al servicio No-ip)

De estas cosas que necesitas, y no se te ocurre otra cosa que hacerla tu mismo.

La idea:

Crear un residente al lado del reloj que grabe en un servidor la IP actual de la instalación para poder conocerla en todo momento, aun que la IP del router cambie.

El proyecto:

Consta de dos frames, el frame 2 estará oculto hasta que se pulse el botón de configuración. Este frame generará un INI para guardar los datos de conexión.

Un Winsock1 para realizar la conexion.

Un timer 1 para realizar una actualización al cabo de un rato

Un Tray Notify icon control que nos permite crear el icono en la barra del reloj.

Como funciona:

Se rellenan los datos de configuración, y al darle a guardar, se conectará a un servidor remoto en donde se encuentra la página en PHP que devolverá la Ip externa de la instalación, Al hacer el contacto, el servidor almacenará el nombre del local, la hora y la nueva ip que se podrá leer abriendo el fichero de registro.

El Key es un añadido que he incluido en el proyecto, no incluiré mucha descripción, que nos permite tener varias instalaciones registradas en un solo fichero.

Cuando se establece la conexión, el muñeco se pone verde, y si no, se pone roj0.

Panel de configuración:

Panel principal:

Residente:

El proyecto final, incluye un botón para que un cliente pueda solicitarme soporte.

Código del programa:

' Se permite la utilización y publicacion de este archivo,
' mientras no se modifique la siguientes lineas:
' Programa desarrollado y publicado en la web www.pesadillo.com.
' Este programa realiza las funciones de un servicio como NO-IP y
' permite conocer la ip de conexion de un equipo y guardarla en un servidor de datos
' Puede encontrar disponible este servicio en la web www.pesadillo.com

Option Explicit
Const APPLICATION As String = "Soporte"
'Importante: Antes de mostrar el BallonTip con el metodo ShowBalloon, _
hay que colocar en el systray, es decir hacerlo visible: Tray.Visible = trueOption Explicit
'constante para el temporizador
Const MINUTOS As Integer = 1
'variable de la ruta ini
Dim Path_Archivo_Ini As String
'definimos variable usuario y correo
Dim user As String
Dim email As String
Dim pass As String
Dim pc As String
Dim ipl As String
Dim npc As String

' definimos variable para almacenar ruta de la pagina
Dim sUrl As String

' Funcion api para llamar a un web
Private Declare Function ShellExecute _
                            Lib "shell32.dll" _
                            Alias "ShellExecuteA" ( _
                            ByVal hwnd As Long, _
                            ByVal lpOperation As String, _
                            ByVal lpFile As String, _
                            ByVal lpParameters As String, _
                            ByVal lpDirectory As String, _
                            ByVal nShowCmd As Long) _
                            As Long

'Función api que recupera un valor-dato de un archivo Ini
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As String, _
    ByVal lpDefault As String, _
    ByVal lpReturnedString As String, _
    ByVal nSize As Long, _
    ByVal lpFileName As String) As Long

'Función api que Escribe un valor - dato en un archivo Ini
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As String, _
    ByVal lpString As String, _
    ByVal lpFileName As String) As Long

Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long

'Funcion para abrir una URL
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

Private Declare Function InternetReadFile Lib "wininet.dll" _
(ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _
lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer

Private Sub setTray(Valor As Boolean)

   tray.Visible = Valor
   tray.Enabled = Valor
   'habilitar el temporizador
   'Timer1.Enabled = Valor
End Sub
Private Function Leer_Ini(Path_INI As String, Key As String, Default As Variant) As String
'Funcion para leer valores en el INI
Dim bufer As String * 255
Dim Len_Value As Long
        Len_Value = GetPrivateProfileString(APPLICATION, Key, Default, bufer, Len(bufer), Path_INI)
        Leer_Ini = Left$(bufer, Len_Value)
End Function
Private Function Grabar_Ini(Path_INI As String, Key As String, Valor As Variant) As String
'Funcion para escribir valores en el INI
    WritePrivateProfileString APPLICATION, _
                                         Key, _
                                         Valor, _
                                         Path_INI
End Function
Private Sub Command1_Click()
    'Escribe en el archivo Ini los valores
    Call Grabar_Ini(Path_Archivo_Ini, "user", Text2.Text)
    Call Grabar_Ini(Path_Archivo_Ini, "email", Text3.Text)
    Call Grabar_Ini(Path_Archivo_Ini, "pass", Text4.Text)
    Call Grabar_Ini(Path_Archivo_Ini, "pc", Text5.Text)

    ' Lee las Key y  Les envia el valor por defecto por si no existe
    user = Leer_Ini(Path_Archivo_Ini, "user", "")
    email = Leer_Ini(Path_Archivo_Ini, "email", "")
    pc = Leer_Ini(Path_Archivo_Ini, "pc", "")
    pass = Leer_Ini(Path_Archivo_Ini, "pass", "")

    'Si las casillas no estan vacias, mostrar IP
    If Not Text2.Text = "" Or Text3.Text = "" Or Text5.Text = "" Then
    'Enviar los datos de registro
    Text1.Text = RegistraIP
    'Leer ip desde servidor
    Text1.Text = LeeIP
    'Reiniciar el formulario
    Frame2.Visible = False
    End If

End Sub

Private Sub Command2_Click()
'Abrir una pagina web de soporte
End Sub

Private Sub Command3_Click()
'Mostrar panel configuracion
Frame2.Visible = True
End Sub

Private Sub Command4_Click()
End
End Sub

Private Sub Command5_Click()
    'Escribe en el archivo Ini los valores antes de ir a la pagina
    Call Grabar_Ini(Path_Archivo_Ini, "user", Text2.Text)
    Call Grabar_Ini(Path_Archivo_Ini, "email", Text3.Text)
    Call Grabar_Ini(Path_Archivo_Ini, "pass", Text4.Text)
    Call Grabar_Ini(Path_Archivo_Ini, "pc", Text5.Text)

'Despues de grabar el ini, conectarse a la pagina para que devuelva la IP
ShellExecute hwnd, "open", "http://www.XXXXXXX.com/", vbNullString, vbNullString, "1"

End Sub

Private Sub Command6_Click()
'ocultar configuracion
Frame2.Visible = False
End Sub

Private Sub Command7_Click()
'Borrar fichero INI de configuracion
Kill Path_Archivo_Ini
'Ponemos a cero los campos.
    Text2.Text = ""
    Text3.Text = ""
    Text5.Text = ""
    Text4.Text = ""
    Text1.Text = ""
End Sub

Private Sub Image2_Click()
'copiar al portapapeles
Clipboard.Clear
Clipboard.SetText Text1.Text, vbCFText
If Clipboard.GetFormat(vbCFText) Then
   Text1.Text = Clipboard.GetText(vbCFText)
End If
End Sub
'Abrir una pagina web con la funcion shellexecute.
Private Sub lblLink_Click()
   Dim r As Long
   r = ShellExecute(0, "open", "http://www.pesadillo.com", 0, 0, 1)
End Sub
Private Sub Form_Load()
'Intervalo en segundos para el temporizador
Timer1.Interval = 1000

    'Path del fichero Ini
    Path_Archivo_Ini = App.Path & "\config.ini"

    ' Lee las Key y  Les envia el valor por defecto por si no existe
    user = Leer_Ini(Path_Archivo_Ini, "user", "")
    email = Leer_Ini(Path_Archivo_Ini, "email", "")
    pc = Leer_Ini(Path_Archivo_Ini, "pc", "")
    pass = Leer_Ini(Path_Archivo_Ini, "pass", "")

    'Conectar para recibir ip de conexion
    Text2.Text = user
    Text3.Text = email
    Text5.Text = pc
    Text4.Text = pass

    'Escribir IP local
    Text6.Text = Winsock1.LocalIP
    Text7.Text = Winsock1.LocalHostName

    'variable IPlocal para enviar
    ipl = Text6.Text
    'variable nombre pc para enciar
    npc = Text7.Text

    'Asigna el icono por defecto en el tray
    'Si los campos estan vacios
    If user = "" Or email = "" Or pc = "" Then Set tray.Icon = Image1(1).Picture Else Set tray.Icon = Image1(0).Picture
    If user = "" Or email = "" Or pc = "" Then MsgBox "Por favor," & vbCrLf & " complete los datos" & vbCrLf & " de conexion.", vbExclamation, "Atencion"

    tray.Enabled = True

    'Iniciar minimizado el programa
    Me.Hide
    Form1.Visible = False
    Form1.Caption = "iP"
    Form1.WindowState = 1

    'Conectar para recibir ip de conexion
    Text1.Text = LeeIP

End Sub

Function RegistraIP() As String
    'Al ejecutar el form, hacer la llamada a la pagina.
    Dim hOpen As Long, hFile As Long, sIP As String, Ret As Long
    Dim Longitud As Integer, Ax As Integer, valido As Boolean, Scaracter As String
    'Creamos la ruta de la pagina
    sUrl = "http://www.xxxx.com/xxx.php?user=" & user & "&pc=" & pc & "&key=" & pass & "&ipl=" & ipl
    'Create a buffer for the file we're going to download
    sIP = Space(1000)
    'Create an internet connection
    hOpen = InternetOpen("", 1, vbNullString, vbNullString, 0)
    'Open the url
    hFile = InternetOpenUrl(hOpen, sUrl, vbNullString, ByVal 0&, &H80000000, ByVal 0&)
    'Read the first 1000 bytes of the file
    InternetReadFile hFile, sIP, 1000, Ret
    'clean up
    InternetCloseHandle hFile
    InternetCloseHandle hOpen
    RegistraIP = Trim(Mid(Trim(sIP), 1, 15))
End Function
Function LeeIP() As String
    'Al ejecutar el form, hacer la llamada a la pagina.
    Dim hOpen As Long, hFile As Long, sIP As String, Ret As Long
    Dim Longitud As Integer, Ax As Integer, valido As Boolean, Scaracter As String

      'Creamos la ruta de la pagina
    sUrl = "http://www.xxxxx.com/xxx.php?user=" & user & "&pc=" & pc & "&key=" & pass & "&ipl=" & ipl

    'Create a buffer for the file we're going to download
    sIP = Space(1000)
    'Create an internet connection
    hOpen = InternetOpen("", 1, vbNullString, vbNullString, 0)
    'Open the url
    hFile = InternetOpenUrl(hOpen, sUrl, vbNullString, ByVal 0&, &H80000000, ByVal 0&)
    'Read the first 1000 bytes of the file
    InternetReadFile hFile, sIP, 1000, Ret
    'clean up
    InternetCloseHandle hFile
    InternetCloseHandle hOpen
    LeeIP = Trim(Mid(Trim(sIP), 1, 15))

End Function

Private Sub Form_Resize()

    If Me.WindowState = 1 Then
        ' pone en el systray
        Call setTray(True)

        tray.BalloonTitle = "Titulo del Baloon Tip"
        tray.BalloonText = " Texto del Baloon Tip "

        ' muestra el globo
        tray.ShowBalloon
        ' oculta el form
        Me.Hide
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Me.WindowState = 1
    Cancel = True
End Sub

Private Sub mnuRestaurar_Click()
    Me.WindowState = 0
    Me.Show
    Call setTray(False)
End Sub

Private Sub mnuSalir_Click()
    If MsgBox(" Salir ?? ", vbQuestion + vbYesNo) = vbYes Then
        End
    End If
End Sub

Private Sub Text1_Change()
    tray.ToolTip = Text1
End Sub

Private Sub Timer1_Timer()

            ' variable estática para acumular la cantidad de segundos
            Static Temp_Seg As Long
            Static Temp_Min As Long
            ' incrementa cuenta segun temprizador
            Temp_Seg = Temp_Seg + 1
            If Temp_Seg >= 60 Then
            Temp_Min = Temp_Min + 1
            Temp_Seg = 0
            End If

            ' comprueba que los segundos no sea igual a la cantidad de minutos que queremos , en este caso 120 minutos
            If Temp_Min >= MINUTOS Then

            ' reestablece
            Temp_Seg = 0
            Temp_Min = 0

            'temporizador para actualizar la IP
            Static i As Integer
            'If i = Image1.Count - 1 Then
            ' i = 0
            'Else
            ' i = i + 1
            'End If

            'averiguar si se ha asignado una IP desde el servidor
            Dim cantidad As Integer
            Dim caracter As String
            For i = 1 To Len(Text1.Text)
            caracter = Mid(Text1.Text, i, 1)
            'contamos el numero de puntos para saber si se ha asignado una ip
            If LCase(caracter) = "." Then
            cantidad = cantidad + 1
            End If
            Next

            If Text2.Text = "" Or Text3.Text = "" Or Text5.Text = "" Then
            'Ocultar IP si no hay datos de usuario
            Text1.Text = ""
            Set tray.Icon = Image1(1).Picture
            Else
            'Conectar para recibir ip de conexion
            Text1.Text = LeeIP
            Set tray.Icon = Image1(0).Picture
            End If

            'asignamos verde si hay Una IP y rojo si no.
            If cantidad = 3 Then
            Set tray.Icon = Image1(0).Picture
            Else
            Set tray.Icon = Image1(1).Picture
            End If
        End If
End Sub

Private Sub Tray_ContextMenu()
    PopupMenu mnuTray
End Sub

Private Sub Tray_DblClick(Button As Integer)
    If Button = 1 Then
       mnuRestaurar_Click
    End If
End Sub

La segunda parte es el fichero que registra el proceso y reporta la IP externa. Basta con incluir este pequeño php en un servidor y ya tenemos el proyecto terminado.

<!--?php  //Gets the IP address  $ip = getenv("REMOTE_ADDR") ;  //Mensaje es la ip  $msg=$ip; if(isset($_GET['user'])){    $user=$_GET['user'];    $pc=$_GET['pc'];    $user = htmlspecialchars($user);    $pc = htmlspecialchars($pc);  $cadena_final = "\r\n".$ip.",".$user.",".$pc; //escribimos la IP en un fichero CSV  $fh = fopen("xxxxxx.csv","a");  fputs($fh,$cadena_final);  fclose($fh);   if ($pc== null) {     $msg="Estacion?";     } else {$msg=$ip;}   if ($email== null) {       $msg="Email?";  } //escribimos el mensaje que leera el programa  Echo $msg;  } Else { Echo "Usuario?"; } ?-->

El php envía mensajes al programa mediante el comando echo.