Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: LeandroA en Febrero 12, 2010, 08:43:13 pm
-
Hola esta función devuelve información (Titulo, Url) de los siguientes navegadores Firefox, IExplorer, Opera, utiliza una conversión DDE utilizando apis.
Esto puede hacerse de una manera muy sencilla utilizando los controles de visual basic (http://foro.elhacker.net/programacion_vb/algun_modulo_o_clase_para_detectar_urls_en_firefox_e_ie-t256953.0.html;msg1246147#msg1246147), pero como yo necesitaba utilizar dentro de un modulo y no hacer referencias a controles utilice esta función con apis.
Option Explicit
'--------------------------------------
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Date: 12/02/2010
'Update 06/05/2010
'--------------------------------------
Private Declare Function DdeInitialize Lib "user32" Alias "DdeInitializeA" (pidInst As Long, ByVal pfnCallback As Long, ByVal afCmd As Long, ByVal ulRes As Long) As Integer
Private Declare Function DdeCreateStringHandle Lib "user32" Alias "DdeCreateStringHandleA" (ByVal idInst As Long, ByVal psz As String, ByVal iCodePage As Long) As Long
Private Declare Function DdeConnect Lib "user32" (ByVal idInst As Long, ByVal hszService As Long, ByVal hszTopic As Long, pCC As Any) As Long
Private Declare Function DdeFreeStringHandle Lib "user32" (ByVal idInst As Long, ByVal hsz As Long) As Long
Private Declare Function DdeUninitialize Lib "user32" (ByVal idInst As Long) As Long
Private Declare Function DdeClientTransaction Lib "user32.dll" (ByVal pData As Long, ByVal cbData As Long, ByVal hConv As Long, ByVal hszItem As Long, ByVal wFmt As Long, ByVal wType As Long, ByVal dwTimeout As Long, ByRef pdwResult As Long) As Long
Private Declare Function DdeAccessData Lib "user32.dll" (ByVal hData As Long, ByRef pcbDataSize As Long) As Long
Private Declare Function DdeUnaccessData Lib "user32.dll" (ByVal hData As Long) As Long
Private Declare Function DdeFreeDataHandle Lib "user32.dll" (ByVal hData As Long) As Long
Private Declare Function DdeDisconnect Lib "user32.dll" (ByVal hConv As Long) As Long
Private Declare Function DdeGetLastError Lib "user32.dll" (ByVal idInst As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Const XCLASS_DATA As Long = &H2000
Private Const XTYP_REQUEST As Long = (&HB0 Or XCLASS_DATA)
Private Const CP_WINANSI As Long = 1004
Private Const CF_TEXT As Long = 1
Private Const FIREFOX As String = "firefox"
Private Const OPERA As String = "opera"
Private Const IEXPLORER As String = "iexplore"
Private Function GetBrowserInfo(ByVal sServer As String) As String
Dim lpData As Long, hData As Long, sData As String
Dim hServer As Long, hTopic As Long, hItem As Long
Dim hConv As Long, idInst As Long
Dim sBuffer As String
Const sTopic = "WWW_GetWindowInfo"
Const sItem = "0xFFFFFFFF"
If DdeInitialize(idInst, 0, 0, 0) <> 0 Then Exit Function
hServer = DdeCreateStringHandle(idInst, sServer, CP_WINANSI)
hTopic = DdeCreateStringHandle(idInst, sTopic, CP_WINANSI)
hItem = DdeCreateStringHandle(idInst, sItem, CP_WINANSI)
hConv = DdeConnect(idInst, hServer, hTopic, ByVal 0&)
If hConv Then
hData = DdeClientTransaction(0, 0, hConv, hItem, CF_TEXT, XTYP_REQUEST, 1000, 0)
lpData = DdeAccessData(hData, 500)
sBuffer = String(500, Chr(0))
lstrcpy sBuffer, lpData
GetBrowserInfo = Left$(sBuffer, InStr(sBuffer, Chr(0)) - 1)
DdeUnaccessData hData
DdeFreeDataHandle hData
DdeDisconnect hConv
End If
DdeFreeStringHandle idInst, hServer
DdeFreeStringHandle idInst, hTopic
DdeFreeStringHandle idInst, hItem
DdeUninitialize idInst
End Function
Private Sub Form_Load()
MsgBox GetBrowserInfo(OPERA)
MsgBox GetBrowserInfo(IEXPLORER)
MsgBox GetBrowserInfo(FIREFOX)
End Sub
Donde no retorne nada es porque la aplicación no esta en ejecución o hubo un error. si hay mas de una ventana abierta retornara la información de la ultima ventana activa.
Nota: "Safary y Google Chrome" aun no implementaron conversaciones DDE, por lo tanto no funciona con esos navegadores.
-
Aparte de Obtener se puede ENVIAR? una url?
-
Hola Skl tanto tiempo, aca tenes una funcion para abrir una url usando DDE
Option Explicit
'--------------------------------------
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Date: 06/05/2010
'--------------------------------------
Private Declare Function DdeInitialize Lib "user32" Alias "DdeInitializeA" (pidInst As Long, ByVal pfnCallback As Long, ByVal afCmd As Long, ByVal ulRes As Long) As Integer
Private Declare Function DdeCreateStringHandle Lib "user32" Alias "DdeCreateStringHandleA" (ByVal idInst As Long, ByVal psz As String, ByVal iCodePage As Long) As Long
Private Declare Function DdeConnect Lib "user32" (ByVal idInst As Long, ByVal hszService As Long, ByVal hszTopic As Long, pCC As Any) As Long
Private Declare Function DdeFreeStringHandle Lib "user32" (ByVal idInst As Long, ByVal hsz As Long) As Long
Private Declare Function DdeUninitialize Lib "user32" (ByVal idInst As Long) As Long
Private Declare Function DdeFreeDataHandle Lib "user32.dll" (ByVal hData As Long) As Long
Private Declare Function DdeDisconnect Lib "user32.dll" (ByVal hConv As Long) As Long
Private Declare Function DdeCreateDataHandle Lib "user32" (ByVal idInst As Long, pSrc As Byte, ByVal cb As Long, ByVal cbOff As Long, ByVal hszItem As Long, ByVal wFmt As Long, ByVal afCmd As Long) As Long
Private Declare Function DdeClientTransaction Lib "user32" (ByVal pData As Long, ByVal cbData As Long, ByVal hConv As Long, ByVal hszItem As Long, ByVal wFmt As Long, ByVal wType As Long, ByVal dwTimeout As Long, pdwResult As Long) As Long
Private Const XCLASS_FLAGS = &H4000
Private Const XTYP_EXECUTE = (&H50 Or XCLASS_FLAGS)
Private Const CP_WINANSI As Long = 1004
Private Const FIREFOX As String = "firefox"
Private Const OPERA As String = "opera"
Private Const IEXPLORER As String = "iexplore"
Private Function BrowserOpenURL(ByVal sServer As String, ByVal sURL As String) As Boolean
Dim hServer As Long
Dim hTopic As Long
Dim hItem As Long
Dim hConv As Long
Dim hData As Long
Dim idInst As Long
Dim aURL() As Byte
Const sTopic = "WWW_OpenURL"
Const sItem = "0xFFFFFFFF"
If DdeInitialize(idInst, 0, 0, 0) <> 0 Then Exit Function
hServer = DdeCreateStringHandle(idInst, sServer, CP_WINANSI)
hTopic = DdeCreateStringHandle(idInst, sTopic, CP_WINANSI)
hItem = DdeCreateStringHandle(idInst, sItem, CP_WINANSI)
hConv = DdeConnect(idInst, hServer, hTopic, ByVal 0&)
If hConv Then
If InStr(UCase(sURL), "HTTP://") = 1 And sServer = OPERA Then
sURL = Mid(sURL, 8)
End If
aURL = StrConv(sURL, vbFromUnicode)
hData = DdeCreateDataHandle(idInst, aURL(0), Len(sURL), 0&, 0&, 0&, 0&)
If hData <> 0 Then
If DdeClientTransaction(hData, -1, hConv, 0, 0, XTYP_EXECUTE, 1000, 0) = 0 Then
BrowserOpenURL = True
End If
DdeFreeDataHandle hData
End If
DdeDisconnect hConv
End If
DdeFreeStringHandle idInst, hServer
DdeFreeStringHandle idInst, hTopic
DdeFreeStringHandle idInst, hItem
DdeUninitialize idInst
End Function
Private Sub Form_Load()
Call BrowserOpenURL(IEXPLORER, "http://www.leandroascierto.com.ar")
Call BrowserOpenURL(OPERA, "http://www.leandroascierto.com.ar")
Call BrowserOpenURL(FIREFOX, "http://www.leandroascierto.com.ar")
End Sub
hice algunas correciones en la primera función para obtener las url.