[mTuenti] - API Tuenti - VB6

[skyweb07]

Bueno esta APi esta hecha para que los programadores de VB6 puedan interactuar con algunos datos del Tuenti, ya que los programadores de dicha página todavia no se han dignado de crear una API y al parecer no quieren por el momento por lo que hay que ingeniarselas para sacar algunos datos de la página . Antes que nada les comento que soy un Anti-Redes Sociales pero bueno no hay que ligar las cosas personales. Bueno sin más charla aqui les va el código y espero que le den un buen uso . Saludos a todos.

PD: Se le pueden añadir muchas más opciones pero me aburri ya de esa mier*** de página.

Código [Seleccionar] Expandir

Option Explicit

'---------------------------------------------------------------------------------------
' Modulo         : mTuenti
' Autor          : skyweb07
' Creación       : 14/02/10 23:01
' Próposito      : Una simple API para el tuenti.
' Requerimientos : Ninguno.
' Créditos       : LeandroA - Función UTF8ToUnicode
'                : http://javierarias.wordpress.com/api-tuenti/ - Idea original.
'---------------------------------------------------------------------------------------

' // Wininet

Public 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
Public 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
Public Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Public Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer

' // Kernel32

Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long

Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
Private Const INTERNET_FLAG_RELOAD = &H80000000

Private Const hTuentiURL As String = "http://m.tuenti.com/"

Public Function SendMessage(uID As Long, hMessagge As String)
   
    ' // Función para enviar un mensaje a un usuario determinado.
    ' // [uID] = ID del usuario a enviar mensaje.
    ' // [hMessagge] = El Mensaje a enviar.
    ' // Para usar esta función es necesario estar logueado anteriormente.
   
    Dim hData       As String
   
    Const hStatus   As String = hTuentiURL & "?m=messaging&func=process_send_message&user_id=[UID]&csfr=[CS]&text="
   
    hData = UTF8ToUnicode(GET_(hTuentiURL & "?m=home"))
   
    If InStr(1, hData, "csfr=") Then
       
        Call POST_(Replace$(Replace$(hStatus, "[CS]", Textbetween(hData, "csfr=", Chr$(34))), "[UID]", uID) & hMessagge)
   
    End If

End Function

Public Function SetStatus(hState As String) As Boolean
   
    ' // Función para cambiar el texto del estado del tuenti.
    ' // [hState] = Estado nuevo.
    ' // Para usar esta función es necesario estar logueado anteriormente.
   
    Dim hData       As String
   
    Const hStatus   As String = hTuentiURL & "?m=profile&func=process_set_status&from=home&csfr=[CS]&status="
   
    hData = UTF8ToUnicode(GET_(hTuentiURL & "?m=home"))
   
    If InStr(1, hData, "csfr=") Then
       
        Call POST_(Replace$(hStatus, "[CS]", Textbetween(hData, "csfr=", Chr$(34))) & hState)
   
    End If

End Function

Public Function GetProfileImage(uID As Long) As String
   
    ' // Función para descargar la imagen de un usuario determinado.
    ' // [uID] = La ID del Usuario que desea descargar la imagen.
    ' // Para usar esta función es necesario estar logueado anteriormente.
   
    Dim hData       As String
   
    Const hPI       As String = hTuentiURL & "?m=profile&user_id="
   
    hData = UTF8ToUnicode(GET_(hPI & uID))
   
        If InStr(1, hData, "profile_img") Then
           
            GetProfileImage = GET_(Textbetween(hData, "profile_img" & Chr$(34) & " src=" & Chr$(34), Chr$(34)))
           
        End If
   
End Function

Public Function GetUserInfo(uID As Long) As String
   
    ' // Función para obtener información determinada sobre un usuario determinado.
    ' // [uID] = La ID del Usuario que desea obtener la información.
    ' // Para usar esta función es necesario estar logueado anteriormente.
   
    Dim hData       As String
    Dim hDelimiter  As String
    Dim hSplit()    As String
   
    Const Info      As String = hTuentiURL & "?m=profile&user_id="
   
    If Not IsEmpty(uID) Then
   
    hData = UTF8ToUnicode(GET_(Info & uID))
   
        hDelimiter = Textbetween(hData, "Sobre", "box")
       
        hSplit() = Split(hDelimiter, "<br />")
       
            If UBound(hSplit) Then
               
                GetUserInfo = Left$(hSplit(0), InStr(1, hSplit(0), "<") - 1) & vbCrLf & _
                Back(hSplit(0), ">") & vbCrLf & _
                hSplit(1) & vbCrLf & hSplit(2) & vbCrLf & hSplit(3) & vbCrLf & _
                "Foto del perfil : " & Textbetween(hData, "profile_img" & Chr$(34) & " src=" & Chr$(34), Chr$(34)) & vbNewLine
               
            End If
       
    End If
   
End Function

Public Function GetFriends(uID As Long) As Collection

    ' // Función que devuelve una colección de amigos de un usuario determinado.
    ' // [uID] = La ID del Usuario que desea obtener la información.
    ' // Para usar esta función es necesario estar logueado anteriormente.
   
    Dim hData       As String
    Dim hDelimiter  As String
    Dim hSplit()    As String
    Dim vItem       As Integer
    Dim hPage       As Long
   
    Const Friends   As String = hTuentiURL & "?m=friends&func=view_friends_of_user&user_id=[ID]" & "&page="
   
    Set GetFriends = New Collection
   
    Do
       
        hData = UTF8ToUnicode(GET_(Replace$(Friends, "[ID]", uID) & hPage))
       
        If InStr(1, hData, "No hay amigos que mostrar.") Then Exit Do

            hDelimiter = Textbetween(hData, "#filter", Right$(hData, 20))
           
               hSplit() = Split(hDelimiter, "user_id")
                   
                    For vItem = 1 To UBound(hSplit) Step 2
                       
                        If Trim_(Back(Textbetween(hSplit(vItem), "user_id", "</a>"), ">")) <> "Página anterior" Then
                           
                            GetMyFriends.Add Trim_(Back(Textbetween(hSplit(vItem), "user_id", "</a>"), ">"))
                             
                        End If

                    Next vItem
       
               hPage = hPage + 1

        DoEvents
       
    Loop
   
End Function

Public Function GetMyFriends() As Collection
   
    ' // Función que devuelve una colección de mis amigos.
    ' // Para usar esta función es necesario estar logueado anteriormente.
   
    Dim hData       As String
    Dim hDelimiter  As String
    Dim hSplit()    As String
    Dim vItem       As Integer
    Dim hPage       As Long
   
    Const Friends   As String = hTuentiURL & "?m=friends&page="
   
    Set GetMyFriends = New Collection
   
    Do
   
        hData = UTF8ToUnicode(GET_(Friends & hPage))
       
        If InStr(1, hData, "No hay amigos que mostrar.") Then Exit Do

            hDelimiter = Textbetween(hData, "#filter", Right$(hData, 20))
           
               hSplit() = Split(hDelimiter, "user_id")
               
                    For vItem = 1 To UBound(hSplit) Step 2

                        GetMyFriends.Add Trim_(Back(Textbetween(hSplit(vItem), "user_id", "</a>"), ">"))

                    Next vItem
       
               hPage = hPage + 1

        DoEvents
       
    Loop
   
End Function

Public Function Login(hMail As String, hPassword As String, Optional hRemember As Boolean = False) As Boolean
   
    ' // Función para loguearse en el tuenti.
   
    Dim hData       As String

    Const Tuenti As String = hTuentiURL & "?m=login&func=process_login&tuentiemail=[MAIL]&password=[PASSWORD]&remember=[R]"

    hData = GET_(Replace$(Replace$(Replace$(Tuenti, "[MAIL]", hMail), "[PASSWORD]", hPassword), "[R]", Int(hRemember)))
   
    If InStr(1, hData, "func=log_out") > 0 Then Login = True

End Function

Public Function LogOut() As Boolean
   
    ' // Función para salir del tuenti.
   
    Dim hData       As String
   
    Const hLogOut As String = hTuentiURL & "?m=login&func=log_out"
   
    If POST_(hLogOut) = True Then LogOut = True

End Function

Private Function GET_(hURL As String, Optional hUserAgent As String = "Mozilla Firefox") As String
   
    ' // Función para descargar cualquier tipo de documento o texto de internet utilizando wininet.
   
    Dim hInternet    As Long
    Dim hFile        As Long
    Dim hBuffer      As String * 1000
    Dim hRead        As Long

    hInternet = InternetOpen(hUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
   
        If hInternet <> 0 Then
           
            hFile = InternetOpenUrl(hInternet, hURL, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)
           
                 If hFile <> 0 Then
                   
                    Do
                   
                       Call InternetReadFile(hFile, hBuffer, 1000, hRead)
                       
                       GET_ = GET_ & Left$(hBuffer, hRead)

                       If hRead = 0 Then Exit Do
                       
                       DoEvents
                       
                    Loop
                 
                 End If
       
        End If
       
        If hInternet <> 0 Then Call InternetCloseHandle(hInternet)
        If hFile <> 0 Then Call InternetCloseHandle(hFile)

End Function

Private Function POST_(hURL As String, Optional hUserAgent As String = "Mozilla Firefox") As Boolean
   
    ' // Función para abrir una URL específica.
   
    Dim hInternet   As Long
    Dim hFile       As Long
   
    hInternet = InternetOpen(hUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
   
        If hInternet <> 0 Then
           
            hFile = InternetOpenUrl(hInternet, hURL, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)
           
            If hFile <> 0 Then POST_ = True

        End If
       
        If hInternet <> 0 Then Call InternetCloseHandle(hInternet)
        If hFile <> 0 Then Call InternetCloseHandle(hFile)
       
End Function

Private Function UTF8ToUnicode(ByVal sUTF8 As String) As String ' // LeandroA
   
    ' // Función para convertir texto UTF8 a Unicode.
   
    Dim UTF8Size        As Long
    Dim BufferSize      As Long
    Dim BufferUNI       As String
    Dim LenUNI          As Long
    Dim bUTF8()         As Byte
   
    If LenB(sUTF8) = 0 Then Exit Function
   
    bUTF8 = StrConv(sUTF8, vbFromUnicode)
    UTF8Size = UBound(bUTF8) + 1
   
    BufferSize = UTF8Size * 2
    BufferUNI = String$(BufferSize, vbNullChar)
   
    LenUNI = MultiByteToWideChar(65001, 0, bUTF8(0), UTF8Size, StrPtr(BufferUNI), BufferSize)
   
    If LenUNI Then UTF8ToUnicode = Left$(BufferUNI, LenUNI)

End Function

Private Function Back(hData As String, Char As String) As String
   
    If InStrRev(hData, Char) <> 0 Then Back = Right(hData, Len(hData) - InStrRev(hData, Char))

End Function

Private Function Trim_(hData As String) As String

    Trim_ = Trim$(Replace$(hData, Chr$(0), vbNullString))
   
End Function

Private Function Textbetween(hData As String, hDelimit1 As String, hDelimit2 As String) As String

    On Error Resume Next
   
    Textbetween = Left$(Mid$(hData, InStr(hData, hDelimit1) + Len(hDelimit1)), InStr(Mid$(hData, InStr(hData, hDelimit1) + Len(hDelimit1)), hDelimit2) - 1)

End Function

[fary]

Gracias por el modulo, luego intento acer algo...

slau2!

[Karcrack]

Esta muy bien

Solo hay un problemita, y es que ,claro, al no haber un API oficial (y puede que no la haya) puede que mañana deje de ir, y tocaria cambiar seguramente todas las URLs que utilizas...

A ver cuando se dignan y hace un API decente...

[skyweb07]

Esta muy bien

Solo hay un problemita, y es que ,claro, al no haber un API oficial (y puede que no la haya) puede que mañana deje de ir, y tocaria cambiar seguramente todas las URLs que utilizas...

A ver cuando se dignan y hace un API decente...

Sip ese es el problema de todo lo que "no se puede hacer" pero bueno hay que jode*** hasta que se dignen a dotarnos con una API aunque yo no la usare porque odio las redes sociales

[agus0]

esta bueno

y facebook tiene api xP nunca me fije en las redes sociales

[antoz]

Ya se usar la funcion de Login y la SendMessage pero de las demas ... he estado probando y nose como usarlas... como puedo usar, por ejemplo, la de GetUserInfo o la de GetFriends?
Gracias de antemano.
Saludos.

[Archreg]

Hoola! Bueno, no he probado casi nada con las Api's en VB6 (Ni llamadas en general)

Me he perdido y no puedo hacer que funcione, (Creo que ni el login, no sé cómo comprobarlo D:)

¿Alguien podría ayudarme un poco? Creo que con explicárme cómo hago el login podría hacer lo demás

¿Alguien me ayuda? Gracias

EDIT: Me acabo de dar cuenta de la fecha del tema, pero lo revivió el de arriba xD
Espero que la fecha no sea molestia para ayudar a la gente

[antoz]

Pues lo unico que tienes que hacer es llamar a la función desde el formulario de la siguiente manera:
Login EMAIL, CONTRASEÑA, True (o False para recordar/no recordar la contraseña).

Puedes usarlo así, por ejemplo:

Código [Seleccionar] Expandir

Private Sub Form_Load()

Login "ANTOZ@HOTMAILLOPETA.COM", "MICONTRASEÑA", True

End Sub

[Archreg]

Muchas gracias antoz!