Exibindo as conexões Dial-up

Exibindo as conexões Dial-up

Que tal exibir as conexões Dial-up existentes em sua máquina ? Que tal exibir a conexão padrão ? Que tal exibir a janela para conexão para a conexão que você selecionar ? Nossa !!! Quanto 'Que tal' . Vamos ao código :

- Inicie um novo projeto no Visual Basic e no formulário padrão insira os controles conforme layout abaixo:

- Um controle ListBox - List1

- Quatro controles commandButton - command1 e command2 , command3 e command4

- Uma caixa de texto - text1

- conforme figura ao lado

- Agora insira um módulo no seu projeto VB ( Menu Project - Add | Module )

- Na seção General Declarations do módulo inserido inclua o código abaixo :

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)

- Ainda no módulo inserido digite o código a seguir para a função GetRegValue :

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

- No mesmo módulo inclua o código para função rgeClear() :

Public Sub rgeClear()
rgeMainKey = 0
rgeSubKey = ""
rgeValue = ""
rgeDataType = 0
rgeEntry = ""
End Sub

- Ainda no módulo digite o código para função :

Function RegEnumKeys&(bFullEnumeration As Boolean)
Dim sRoot$, sRoot2$
Dim lRtn&
Dim hKey&
Dim strucLastWriteTime As FILETIME
Dim sSubKeyName$
Dim sClassString$
Dim lLenSubKey&
Dim lLenClass&
Dim lKeyIndx&
Dim lRet&
Dim hKey2&
Dim sSubKey2$
Dim sNewKey$

Dim sClassName$
Dim lClassLen&
Dim lSubKeys&
Dim lMaxSubKey&
Dim sMaxSubKey$
Dim lMaxClass&
Dim sMaxClass$
Dim lValues&
Dim lMaxValueName&
Dim lMaxValueData&
Dim 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

- Abaixo temos os códigos associados ao evento Click dos botões de comando :

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 Command3_Click()
  Shell "rundll32.exe rnaui.dll,RnaDial " + Text1.Text, vbNormalFocus
End Sub

Private Sub Command4_Click()
  Unload Me
End Sub

- Para encerrar o código associado ao evento DblClick do controle List1 :

Private Sub List1_DblClick()
  Shell "rundll32.exe rnaui.dll,RnaDial " + List1.List(List1.ListIndex), vbNormalFocus
End Sub

Só falta executar o projeto e exibir o resultado :

A tela inicial após clicar no botão para exibir as conexões dial-up e também a conexão padrão

A tela exibida após clicar duas vezes sobre a conexão - Rio Preto Net - exibindo a janela de conexão

Até mais ver ...

José Carlos Macoratti