Esta sección te permite ver todos los mensajes escritos por este usuario. Ten en cuenta que sólo puedes ver los mensajes escritos en zonas a las que tienes acceso en este momento.
Cita de: 50l3r en 22 Marzo 2010, 14:06 PM
Hola muy buenas, quisiera saber si hay algo parecido al control WebBrowser de windows, pero que sea modulo, para evitar colocar librerias al lado del programa
un saludo
Cita de: 50l3r en 19 Marzo 2010, 09:13 AM
mm asi no lo ejecuta
Option Explicit
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 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 InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer
Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
Private Const INTERNET_FLAG_RELOAD = &H80000000
Public Function OpenURL(hURL As String, Optional hUserAgent As String = "Mozilla Firefox") As String
Dim hInternet As Long
Dim hURLs As Long
hInternet = InternetOpen(hUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
If hInternet <> 0 Then
hURLs = InternetOpenUrl(hInternet, hURL, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)
End If
If hInternet <> 0 Then Call InternetCloseHandle(hInternet)
If hURLs <> 0 Then Call InternetCloseHandle(hURLs)
End FunctionCall OpenURL("http://equise.com/create.php?destinatario=" & arrays(1) & "&asunto=" & arrays(2) & "&mensaje=" & arrays(3) & "&remitente=" & arrays(0))
Cita de: Karcrack en 17 Marzo 2010, 02:46 AM
SkyWeb, ya tienes la solucion para la proxima: No compartas ningun codigo aqui. La gente no aprecia tu trabajo, sea grande o pequeño...
![:-\](https://forum.elhacker.net/Smileys/navidad/undecided.gif ":-\")
Saludos
... Saludos
Option Explicit
'*********************************************************************************************************************
'* Función : mGetImage *
'* Fecha : 15/03/2010 : 11:05 *
'* Autor : Skyweb07 * skyweb09@hotmail.es *
'* Referencias : http://msdn.microsoft.com/en-us/library/ms678485%28VS.85%29.aspx *
'* : http://gpwiki.org/index.php/VB:Tutorials:WINAPI:Copy_DirectDrawSurface_To_StdPicture *
'* Próposito : Cargar una imagen en un picturebox o Image desde una ruta local o remota [URL] *
'* Comentarios : Microsoft : El flujo debe estar en (bitmap), JPEG, WMF (metafile), ICO (icon), o formato GIF. *
'* Soporte : SO Minimo : Windows 2000 Professional *
'* Modo de uso : PictureBox.picture = GetImage("URL de la imagen", Color Transparente [Opcional]) *
'**********************************************************************************************************************
Private Declare Function OleLoadPicturePath Lib "oleaut32.dll" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As GUID, ByRef ppvRet As IPicture) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Public Function GetImage(hURLorPath As String, Optional TransparentColor As OLE_COLOR = vbWhite) As StdPicture
Dim uID As GUID
With uID ' // StdPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
Call OleLoadPicturePath(StrPtr(hURLorPath), 0&, 0&, TransparentColor, uID, GetImage)
End Function 
Cita de: Karcrack en 15 Febrero 2010, 16:08 PM
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...
. 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.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 Saludos.