CodeItBetter Programming Another VB Programming Blog

'Internet - How to Open a URL in a New IE window
Option Explicit
 
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, _
    ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, _
    phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, _
    ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, _
    ByVal lpData As Long, lpcbData As Long) As Long
Const KEY_READ = &H20019
Const REG_SZ = 1
Const ERROR_NONE = 0
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
 
Private Sub Command1_Click()
'Opens the google.com in a new browser window
    OpenBrowser "http://www.google.com"
End Sub
 
Function OpenBrowser(sURL As String) As Boolean
    Dim sValue As String
    Dim retval As Long
    sValue = QueryValue(HKEY_CLASSES_ROOT, "http\shell\open\command", "")
    retval = Shell(sValue & " " & sURL, vbNormalFocus)
    If retval = 0 Then
        OpenBrowser = False
    Else
        OpenBrowser = True
    End If
End Function
 
Private Function QueryValue(hKeyLocation As Long, sKeyName As String, _
    sValueName As String) As String
    Dim lRetVal As Long
    Dim hKey As Long
    Dim vValue As Variant
    lRetVal = RegOpenKeyEx(hKeyLocation, sKeyName, 0, KEY_READ, hKey)
    lRetVal = QueryValueEx(hKey, sValueName, vValue)
    QueryValue = vValue
    RegCloseKey hKey
End Function
 
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String
    On Error GoTo QueryValueExError
    ' Determine the size and type of data to be read
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Err.Raise 5
    Select Case lType
    Case REG_SZ:
        'For strings
        sValue = String$(cch, 0)
        lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
        If lrc = ERROR_NONE Then
            vValue = Left$(sValue, cch - 1)
        Else
            vValue = Empty
        End If
    Case Else
        'For other values

    End Select
 
QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
 
QueryValueExError:
    Resume QueryValueExExit
End Function