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

Option Explicit
 
'---------------------------------------------------------------------------------------
' Modulo         : mEnumerateRegistryApps
' Autor          : skyweb07
' Email          : skyweb09@hotmail.es
' Creación       : 02/02/2010 14:35
' Próposito      : Obtener una lista detallada de las aplicaciones instaladas en window utilizando las entradas del registro.
' Requerimientos : Ninguno.
'---------------------------------------------------------------------------------------

' // Entradas del registro

Enum hKeys
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
End Enum

' // Estructura que no vamos a utilizar pero necesaria [Si la utilizaramos devolveria los valores de los datos de la edición del registro.]

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
' // Apis para el manejo del registro.

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByRef lpData As Any, ByRef lpcbData As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByRef lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, ByRef lpcbClass As Long, ByRef lpftLastWriteTime As FILETIME) As Long

' // Constantes del registro.

Private Const STANDARD_RIGHTS_ALL As Long = &H1F0000
Private Const KEY_CREATE_LINK As Long = &H20
Private Const KEY_CREATE_SUB_KEY As Long = &H4
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_NOTIFY As Long = &H10
Private Const KEY_SET_VALUE As Long = &H2
Private Const SYNCHRONIZE As Long = &H100000
Private Const KEY_READ As Long = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE As Long = (KEY_READ)
Private Const STANDARD_RIGHTS_WRITE As Long = (READ_CONTROL)
Private Const KEY_WRITE As Long = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const KEY_ALL_ACCESS As Long = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))

Private Const REG_BINARY As Long = 3
Private Const REG_DWORD As Long = 4
Private Const REG_DWORD_BIG_ENDIAN As Long = 5
Private Const REG_DWORD_LITTLE_ENDIAN As Long = 4
Private Const REG_EXPAND_SZ As Long = 2
Private Const REG_LINK As Long = 6
Private Const REG_MULTI_SZ As Long = 7
Private Const REG_NONE As Long = 0
Private Const REG_QWORD As Long = 11
Private Const REG_QWORD_LITTLE_ENDIAN As Long = 11
Private Const REG_SZ As Long = 1
Private Const REG_ALL = (REG_BINARY Or REG_DWORD Or REG_DWORD_BIG_ENDIAN Or REG_DWORD_LITTLE_ENDIAN Or REG_DWORD_LITTLE_ENDIAN Or REG_EXPAND_SZ Or REG_LINK Or REG_MULTI_SZ Or REG_NONE Or REG_QWORD Or REG_QWORD_LITTLE_ENDIAN Or REG_SZ)

Private Const ERROR_NO_MORE_ITEMS As Long = 259&
Private Const ERROR_SUCCESS As Long = 0&
 
Public Function EnumApplications() As Collection
    
    Dim vKeys() As String
    Dim i       As Long
    
    Set EnumApplications = New Collection
    
    Const Y As String = " - "
    
    If EnumKeys(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall", vKeys()) Then
        
        For i = 0 To UBound(vKeys)
            
            EnumApplications.Add ProductInfo(vKeys(i), "DisplayName") & Y & ProductInfo(vKeys(i), "Publisher") & Y & ProductInfo(vKeys(i), "DisplayVersion") & Y & Format$(ProductInfo(vKeys(i), "InstallDate"), "####/##/##") & Y & ProductInfo(vKeys(i), "InstallSource") & Y & ProductInfo(vKeys(i), "URLInfoAbout")
 
        Next i
        
    End If
    
End Function

Private Function ProductInfo(hEntry As String, hAttribute As String) As String
    
   ProductInfo = ReadKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\" & hEntry, hAttribute)

End Function

Private Function EnumKeys(hKey As hKeys, hSubKey As String, hReturn() As String) As Long
 
    Dim vBuffer     As String * 260
    Dim vReturn     As Long
    Dim vIndex      As Long
    Dim FT          As FILETIME
 
    If RegOpenKeyEx(hKey, hSubKey, ByVal 0&, KEY_ALL_ACCESS, vReturn) = ERROR_SUCCESS Then
        
        Do Until RegEnumKeyEx(vReturn, vIndex, vBuffer, Len(vBuffer), ByVal 0&, vbNullString, ByVal 0&, FT) = ERROR_NO_MORE_ITEMS
            
            ReDim Preserve hReturn(0 To vIndex)
            
            hReturn(vIndex) = Left$(vBuffer, InStr(1, vBuffer, Chr$(0)) - 1)
            
            vIndex = vIndex + 1: EnumKeys = EnumKeys + 1
            
        Loop
        
    End If
    
End Function
 
Private Function ReadKey(hKey As hKeys, hSubKey As String, hValue As String) As String
    
    Dim hReturn     As Long
    Dim hResult     As Long
    Dim hData       As Long
    Dim hFinal      As String
    
    If RegOpenKeyEx(hKey, hSubKey, ByVal 0&, KEY_ALL_ACCESS, hReturn) = ERROR_SUCCESS Then
            
        hResult = RegQueryValueEx(hReturn, hValue, 0, REG_ALL, ByVal 0&, hData)
        
        hFinal = String$(hData, Chr$(0))
        
        If RegQueryValueEx(hReturn, hValue, 0, REG_ALL, ByVal hFinal, hData) = ERROR_SUCCESS Then
            
            ReadKey = Left$(hFinal, InStr(1, hFinal, Chr$(0)) - 1)
        
        End If
        
    End If
    
    If hReturn <> 0 Then
        
        Call RegCloseKey(hReturn)
        
    End If
    
End Function

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall