CodeItBetter Programming Another VB Programming Blog

'Internet - How to connect Internet programmatically (in two ways)
'Method 1:

Option Explicit
 
Private Sub Command1_Click()
    Dim lRet As Long
    Dim strConnectionName As String
    Dim strUserName As String
    Dim strPassword As String
 
    strConnectionName = "Connection through RO_100 VE Network Connection"
    strUserName = "man@one"
    strPassword = "123s456"
 
    lRet = Shell("RASDIAL " &  chr ( 34) & strConnectionName &  chr ( 34) & " " & strUserName & _
        " " & strPassword, vbNormalFocus)
End Sub
 
'Method 2:

Option Explicit
 
'Add two Command Buttons, a Text Box and a List Box to your form.
'The first button to get the default internet connection name and the second
'button is to fill the List Box with all internet connections.
'Double click on one of the internet connections in the List Box to connect to the internet.

Const REG_NONE = 0&
Public Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Public Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&
Public rgeEntry$
Public rgeDataType&
Public rgeValue$
Public rgeMainKey&
Public rgeSubKey$
Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ
Type FILETIME
    lLowDateTime As Long
    lHighDateTime As Long
End Type
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Declare Function RegOpenKeyEx& Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&)
Declare Function RegCloseKey& Lib "advapi32.dll" (ByVal hKey&)
Declare Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
Declare Function RegEnumKeyEx& Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey&, ByVal dwIndex&, ByVal lpname$, lpcbName&, ByVal lpReserved&, ByVal lpClass$, lpcbClass&, lpftLastWriteTime As FILETIME)
Declare Function RegQueryInfoKey& Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey&, ByVal lpClass$, lpcbClass&, ByVal lpReserved&, lpcSubKeys&, lpcbMaxSubKeyLen&, lpcbMaxClassLen&, lpcValues&, lpcbMaxValueNameLen&, lpcbMaxValueLen&, lpcbSecurityDescriptor&, lpftLastWriteTime As FILETIME)
 
Public Function GetRegValue(keyroot As Variant, subkey As Variant, valname As String)
    Const KEY_ALL_ACCESS As Long = &HF0063
    Const ERROR_SUCCESS As Long = 0
    Const REG_SZ As Long = 1
    Dim hsubkey As Long, dwType As Long, sz As Long
    Dim R As Long
    R = RegOpenKeyEx(keyroot, subkey, 0, KEY_ALL_ACCESS, hsubkey)
    sz = 256
    v$ = String$(sz, 0)
    R = RegQueryValueEx(hsubkey, valname, 0, dwType, ByVal v$, sz)
    If R = ERROR_SUCCESS And dwType = REG_SZ Then
        retval = Left$(v$, sz)
        GetRegValue = retval
    Else
        retval = "--Not String--"
    End If
    R = RegCloseKey(hsubkey)
End Function
 
Public Sub rgeClear()
    rgeMainKey = 0
    rgeSubKey = ""
    rgeValue = ""
    rgeDataType = 0
    rgeEntry = ""
End Sub
 
Function RegEnumKeys&(bFullEnumeration As Boolean)
    Dim sRoot$, sRoot2$, lRtn&, hKey&
    Dim strucLastWriteTime As FILETIME
    Dim sSubKeyName$, sClassString$, lLenSubKey&, lLenClass&, lKeyIndx&
    Dim lRet&, hKey2&, sSubKey2$, sNewKey$, sClassName$, lClassLen&
    Dim lSubKeys&, lMaxSubKey&, sMaxSubKey$, lMaxClass&, sMaxClass$
    Dim lValues&, lMaxValueName&, lMaxValueData&, lSecurityDesc&
    lRtn = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, hKey)
    sClassName = Space$(255)
    lClassLen = CLng(Len(sClassName))
    lRet = RegQueryInfoKey(hKey, sClassName, lClassLen, 0&, lSubKeys, lMaxSubKey, lMaxClass, lValues, lMaxValueName, lMaxValueData, lSecurityDesc, strucLastWriteTime)
    sMaxSubKey = Space$(lMaxSubKey + 1)
    sMaxClass = Space$(lMaxClass + 1)
    lKeyIndx = 0&
    Do While lRtn = ERROR_SUCCESS
ReTryKeyEnumeration:
        sSubKeyName = sMaxSubKey
        lLenSubKey = lMaxSubKey
        sClassString = sMaxClass
        lLenClass = lMaxClass
        lRtn = RegEnumKeyEx(hKey, lKeyIndx, sSubKeyName, lLenSubKey, 0&, sClassString, lLenClass, strucLastWriteTime)
        If InStr(sSubKeyName, Chr$(0)) > 1 Then
            sSubKeyName = Left$(sSubKeyName, InStr(sSubKeyName, Chr$(0)) - 1)
        End If
        If lRtn = ERROR_SUCCESS Then
            Form1.List1.AddItem sSubKeyName
            lNewKey = lNewKey + 1
            sNewKey = "A" & Format$(lNewKey, "000000")
            If bFullEnumeration = True Then
                sSubKey2 = sSubKeyName
                If rgeSubKey <> "" Then
                    sSubKey2 = Trim(rgeSubKey) & "\" & sSubKeyName
                End If
                lRet = RegOpenKeyEx(rgeMainKey, sSubKey2, 0&, KEY_READ, hKey2)
            Else
                Exit Do
            End If
            lKeyIndx = lKeyIndx + 1
        ElseIf lRtn = ERROR_MORE_DATA Then
            lMaxSubKey = lMaxSubKey + 5
            lMaxClass = lMaxClass + 5
            sMaxSubKey = Space$(lMaxSubKey + 1)
            sMaxClass = Space$(lMaxClass + 1)
            GoTo ReTryKeyEnumeration
        ElseIf lRtn = ERROR_NO_MORE_ITEMS Then
            lRtn = ERROR_SUCCESS
            Exit Do
            Exit Do
        End If
    Loop
    RegEnumKeys = lRtn
    lRtn = RegCloseKey(hKey)
End Function
 
Private Sub Command1_Click()
    Text1.Text = GetRegValue(HKEY_CURRENT_USER, "RemoteAccess", "Default")
End Sub
 
Private Sub Command2_Click()
    rgeMainKey = HKEY_CURRENT_USER
    rgeSubKey$ = "RemoteAccess\Profile"
    RegEnumKeys True
End Sub
 
Private Sub List1_DblClick()
    Shell "rundll32.exe rnaui.dll,RnaDial " + List1.List(List1.ListIndex)
End Sub