[Source]Obtener la URL de los navegadores (DDE + Apis)

[LeandroA]

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, pero como yo necesitaba utilizar dentro de un modulo y no hacer referencias a controles utilice esta función con apis.

Código: (vb) [Seleccionar]

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.

[SKL]

Aparte de Obtener se puede ENVIAR? una url?

[LeandroA]

Hola Skl tanto tiempo, aca tenes una funcion para abrir una url usando DDE

Código: (vb) [Seleccionar]

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.