Autor
. 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:
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
'---------------------------------------------------------------------------------------
' 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
En línea
