Se podría hacer...?

sansonaye
11 de Diciembre del 2003
Hola a todos! Soy nuevo en el foro y en el mundo de VB. Me gustaría crear un programa, que al abrir una web, se fueran seleccionando unos enlaces predeterminados. Por ejemplo: Al abrir mi explorador, se abriera la página de www.terra.es, después, automáticamente se activara el vinculo "chat" y se abriera en la misma página www.terra.es/chat y así todas las rutas que yo quisiera...

¿Pido algo imposible? Ayúdenme por favor...

Victor
11 de Diciembre del 2003
No te entendi bien, pero si lo que quieres es que adentro de un programa pongas la direccion y se conecta a esa direccion. Lo que tienes que hacer es que atravez del registro modifique la pagina de inicio y que se abra el explorador con esa pagina. Claro que despues de volvera a la original.
Creas un form con un textbox y un boton(commandbotton)
y en el codigo pones lo siguiente.

Option Explicit
Dim a, ssS

Dim colShellFolders As Collection
Dim colShellFoldersKey As Collection

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long

' Registry manipulation API's (32-bit)

'Claves del Registro
Public Enum eHKEY
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
'
HKEY_CURRENT_CONFIG = &H80000005
HKEY_DYN_DATA = &H80000006
End Enum
'
Public Enum eHKEYError
ERROR_SUCCESS = 0 'Todo correcto, sin error
ERROR_FILE_NOT_FOUND = 2& 'este error ocurre cuando se abre
'una clave y no existe

ERROR_ACCESS_DENIED = 5&
ERROR_MORE_DATA = 234& 'More data is available
ERROR_NO_MORE_ITEMS = 259& 'No more data is available

ERROR_BADKEY = 1010& 'Se produce cuando se intenta acceder
'a una clave que no está abierta
End Enum
'
'Los tipos de datos posibles, algunos sólo para Windows NT
Public Enum eHKEYDataType
REG_NONE = 0& 'No value type
REG_SZ = 1& 'Unicode null terminated string
REG_BINARY = 3 'Free form binary
REG_DWORD = 4 '32-bit number
End Enum

' Standard rights, used later below
Const SYNCHRONIZE = &H100000
Const READ_CONTROL = &H20000
Const STANDARD_RIGHTS_ALL = &H1F0000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)
Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)

'Security Access Mask
Public Enum eREGSAM
'Permission to:
KEY_QUERY_VALUE = &H1 ' query subkey data
KEY_SET_VALUE = &H2 ' set subkey data
KEY_CREATE_SUB_KEY = &H4 ' create subkeys
KEY_ENUMERATE_SUB_KEYS = &H8 ' enumerate subkeys
KEY_NOTIFY = &H10 ' for change notification
KEY_CREATE_LINK = &H20 ' create a symbolic link

'KEY_READ Combination of:
' KEY_QUERY_VALUE, KEY_ENUMERATE_SUB_KEYS, and
' KEY_NOTIFY access.
KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
'KEY_WRITE Combination of:
' KEY_SET_VALUE and KEY_CREATE_SUB_KEY access.
KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))

'Permission for read access
KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))

'KEY_ALL_ACCESS Combination of:
' KEY_QUERY_VALUE, KEY_SET_VALUE, KEY_CREATE_SUB_KEY,
' KEY_ENUMERATE_SUB_KEYS, KEY_NOTIFY and KEY_CREATE_LINK access.
KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))

End Enum

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
(ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, _
lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, _
lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, _
lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, _
lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" 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.dll" _
(ByVal hKey As Long) As Long

Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
(ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpValueName As String, lpcbValueName As Long, _
lpReserved As Long, lpType As Long, lpData As Any, _
lpcbData As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
(ByVal hKey As Long, ByVal lpszSubKey As String, _
phkResult As Long) As Long
'
'Windows 95:
' The RegDeleteKey function deletes a subkey and all its descendants.
'Windows NT:
' The RegDeleteKey function deletes the specified subkey.
' The subkey to be deleted must not have subkeys.
'
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
(ByVal hKey As Long, ByVal lpszSubKey As String) As Long

Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal hKey As Long, ByVal szValueName As String) As Long

Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _
(ByVal hKey As Long, ByVal iSubKey As Long, _
ByVal lpszName As String, ByVal cchName As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" _
(ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpName As String, lpcbName As Long, _
ByVal lpReserved As Long, ByVal lpClass As String, _
lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" _
(ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal lpValue As String, lpcbValue As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpszValueName As String, _
ByVal dwReserved As Long, lpdwType As Long, _
lpbData As Any, cbData As Long) As Long

'The RegSetValue function sets the data for the default or unnamed
'value of a specified registry key. The data must be a text string.
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" _
(ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal dwType As Long, ByVal lpData As String, _
ByVal cbData As Long) As Long

'
'The RegSetValueEx function sets the data and type of a
'specified value under a registry key.
'
'lpValueName:
'Pointer to a string containing the name of the value to set.
'If a value with this name is not already present in the key,
'the function adds it to the key.
'If lpValueName is NULL or an empty string, "", the function sets
'the type and data for the key's unnamed or default value.
'
'On Windows 95, the type of a key's default value is always REG_SZ,
'so the dwType parameter must specify REG_SZ for an unnamed value.
'On Windows 98, an unnamed value can be of any type.
'
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpszValueName As String, _
ByVal dwReserved As Long, ByVal fdwType As Long, _
lpbData As Any, ByVal cbData As Long) As Long

'
'Este código está 'copiado' de un ejemplo de David Janson
'Sólo es necesario para Windows NT, ya que win95 permite borrar todas
'las subclaves
'
'También hay que usarla en windows 98
'
'
' this gets a bit tricky since you can't delete a key that has subkeys.
' We have to do this recursively. This code ignores errors (such as security
' problems) when they occur.
'
Private Function DeleteKeyNT(hParentKey As Long, szKey As String) As Long
Dim hKey As Long
Dim lRet As eHKEYError
Dim cSubKeys As Long
Dim cbMaxSubKeyLen As Long
Dim cbSubKeyLen As Long
Dim dwIndex As Long
Dim ft As FILETIME

Dim szTempSubKey As String
Dim szSubKey As String

' open the key to look for subkeys
lRet = RegOpenKeyEx(hParentKey, szKey, 0, KEY_ALL_ACCESS, hKey)
If Not lRet = ERROR_SUCCESS Then
DeleteKeyNT = lRet
Exit Function
End If
lRet = RegQueryInfoKey(hKey, ByVal 0&, ByVal 0&, 0, cSubKeys, cbMaxSubKeyLen, _
ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, ft)

If Not lRet = ERROR_SUCCESS Then
DeleteKeyNT = lRet
Call RegCloseKey(hKey)
Exit Function
End If

' if there are subkeys, then recursively delete them
If cSubKeys > 0 Then
dwIndex = cSubKeys - 1 ' start at the end
cbMaxSubKeyLen = cbMaxSubKeyLen + 1 ' +1 for the null terminator
szTempSubKey = String(cbMaxSubKeyLen, "*") ' buffer to get name back in
Do
cbSubKeyLen = cbMaxSubKeyLen

lRet = RegEnumKeyEx(hKey, dwIndex, szTempSubKey, cbSubKeyLen, 0, ByVal 0&, 0, ft)
If lRet = ERROR_SUCCESS Then
szSubKey = Left(szTempSubKey, cbSubKeyLen)
Call DeleteKeyNT(hKey, szSubKey)
End If
dwIndex = dwIndex - 1 ' enumerate backwards
Loop While dwIndex >= 0
End If

' done enumerating subkeys. Close this key and delete it
Call RegCloseKey(hKey)

lRet = RegDeleteKey(hParentKey, szKey)
DeleteKeyNT = lRet
End Function

Public Function GetReg(ByVal sKey As String, Optional ByVal sValue As String = "", Optional ByVal hKey As eHKEY = HKEY_CURRENT_USER, Optional ByVal bAsString As Boolean = False) As Variant
'Obtener un valor de una entrada del registro
'
'Parámetros de entrada:
' sKey SubClave del registro
' Se puede especificar el nombre de la clave raiz
' que se convertirá al valor adecuado
' sValue Nombre de la entrada que queremos obtener
' hKey Clave principal del registro.
' Si en sKey se incluye, no es necesario especificarla
' bAsString Mostrarlo como una cadena, al estilo de RegEdit
'Devuelve:
' el contenido de esa clave o un valor vacío
'
Dim lRet As Long
Dim hKey2 As Long
Dim rDT As eHKEYDataType
Dim retDT As eHKEYDataType
Dim lSize As Long
Dim sData As String
Dim aData() As Byte
Dim lDWord As Long
Dim i As Long
Dim sTmp As String

hKey = ParseKey(sKey, hKey)

'Valores por defecto
ReDim aData(0)
lDWord = 0
sData = ""

'Abrir la clave indicada
lRet = RegOpenKeyEx(hKey, sKey, 0&, KEY_QUERY_VALUE, hKey2)

'Si todo va bien (se ha podido abrir la clave)
If lRet = ERROR_SUCCESS Then
'Leer esa entrada y obtener el tipo de dato, longitud, etc.
lRet = RegQueryValueEx(hKey2, sValue, 0&, retDT, 0&, lSize)
'Si es un valor binario
If retDT = REG_BINARY Then
If lSize Then
ReDim aData(lSize)
'Leer los datos binarios
lRet = RegQueryValueEx(hKey2, sValue, 0&, rDT, aData(0), lSize)
End If
ElseIf retDT = REG_DWORD Then
lRet = RegQueryValueEx(hKey2, sValue, 0&, rDT, lDWord, lSize)
ElseIf retDT = REG_SZ Then
If lSize Then
sData = String$(lSize - 1, Chr$(0))
'Leer la cadena
'(el ByVal es porque está declarada como Any)---v
lRet = RegQueryValueEx(hKey2, sValue, 0&, rDT, ByVal sData, lSize)
End If
End If
'Cerrar la clave abierta
RegCloseKey hKey2
End If
'Devolver el valor leído
If retDT = REG_BINARY Then
If bAsString Then
'Al estilo de como se muestra con RegEdit
For i = 0 To UBound(aData) - 1
sTmp = sTmp & Hex$(aData(i)) & " "
Next
GetReg = sTmp
Else
GetReg = aData
End If
ElseIf retDT = REG_DWORD Then
If bAsString Then
'Al estilo de como se muestra con RegEdit
GetReg = "0x" & Format$(Hex$(lDWord), "00000000") & " (" & lDWord & ")"
Else
GetReg = lDWord
End If
ElseIf retDT = REG_SZ Then
GetReg = sData
End If
End Function

'Busca una entrada en el registro
Public Function QueryRegBase(ByVal sValue As String, Optional ByVal hKey As eHKEY = HKEY_CLASSES_ROOT) As String
'Devuelve el valor de la entrada del registro
'Esta función se usará para los valores por defecto
'
Dim sBuf As String
Dim buflen As Long

'Nos aseguramos que hKey tenga el valor correcto
Select Case hKey
Case HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS
'nada que hacer, todo correcto
Case Else
'Asignamos el valor por defecto
hKey = HKEY_CLASSES_ROOT
End Select

'On Local Error Resume Next
sBuf = String$(300, Chr$(0))
buflen = Len(sBuf)
'Buscar la entrada especificada y devolver el valor asignado
If RegQueryValue(hKey, sValue, sBuf, buflen) = ERROR_SUCCESS Then
If buflen > 1 Then
'El formato devuelto es ASCIIZ, así que quitar el último caracter
QueryRegBase = Left$(sBuf, buflen - 1)
Else
QueryRegBase = ""
End If
Else
QueryRegBase = ""
End If
'On Local Error GoTo 0
End Function

Private Function ParseKey(sKey As String, Optional ByVal hKey As eHKEY = HKEY_CURRENT_USER) As eHKEY
'Esta función se usa internamente (privada) para convertir una cadena
'en la correspondiente clave raiz.
'El segundo parámetro es para poder usarlo en caso que se pase como
'parámetro, pero normalmente será totalmente opcional.
'
'En sKey se devolverá el valor de la clave una vez quitada la clave
'principal.
'
Dim i As Long
Dim sRootKey As String

'Comprobar si se indica la clave principal en sKey
i = InStr(sKey, "HKEY_")
If i Then
i = InStr(sKey, "")
If i Then
sRootKey = Left$(sKey, i - 1)
sKey = Mid$(sKey, i + 1)
Else
sRootKey = sKey
sKey = ""
End If
'Por si se usan abreviaturas de las claves
ElseIf Left$(sKey, 5) = "HKCR" Then
sRootKey = "HKEY_CLASSES_ROOT"
sKey = Mid$(sKey, 6)
ElseIf Left$(sKey, 5) = "HKCU" Then
sRootKey = "HKEY_CURRENT_USER"
sKey = Mid$(sKey, 6)
ElseIf Left$(sKey, 5) = "HKLM" Then
sRootKey = "HKEY_LOCAL_MACHINE"
sKey = Mid$(sKey, 6)
ElseIf Left$(sKey, 4) = "HKU" Then
sRootKey = "HKEY_USERS"
sKey = Mid$(sKey, 5)
ElseIf Left$(sKey, 5) = "HKCC" Then
sRootKey = "HKEY_CURRENT_CONFIG"
sKey = Mid$(sKey, 6)
ElseIf Left$(sKey, 5) = "HKDD" Then
sRootKey = "HKEY_DYN_DATA"
sKey = Mid$(sKey, 6)
Else
'Nos aseguramos que kKey tenga el valor correcto
Select Case hKey
Case HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CURRENT_CONFIG, HKEY_DYN_DATA
'nada que hacer, todo correcto
Case Else
'Asignamos el valor por defecto
hKey = HKEY_CLASSES_ROOT
End Select
End If
'Si se ha indicado el nombre de la clave raiz
If Len(sRootKey) Then
Select Case sRootKey
Case "HKEY_CLASSES_ROOT"
hKey = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
hKey = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
hKey = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
hKey = HKEY_USERS
Case "HKEY_CURRENT_CONFIG"
hKey = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
hKey = HKEY_DYN_DATA
Case Else
hKey = HKEY_CLASSES_ROOT
End Select
End If

ParseKey = hKey
End Function

Public Function ShellFolders(Optional bSoloClaves As Boolean = False) As Variant
'Devolverá las claves de la clave Shell Folders
Dim hKey As eHKEY
Dim Entry As String
Dim phkResult As Long
Dim maxBufLen As Long
Dim L As Long
Dim buf As String
Dim buflen As Long
Dim lRet As Long
Dim retDT As eHKEYDataType
Dim i As Long
Dim sValue As String
Dim iCount As Long

'Borrar el contenido de la colección
Set colShellFolders = Nothing
Set colShellFolders = New Collection
Set colShellFoldersKey = Nothing
Set colShellFoldersKey = New Collection

'==============================================================
'
'=== NOTA CACHONDA === por lo incomprensible...
' Es curioso, pero si utilizo estas intrucciones aquí
' el bucle For iCount=0 to 1 no acaba nunca
'
'==============================================================
'
'Para el directorio de windows
'buf = "WindowsDir"
'colShellFoldersKey.Add buf, buf
'colShellFolders.Add "Windows", buf
'
'Para el directorio de System
'buf = "SystemDir"
'colShellFoldersKey.Add buf, buf
'colShellFolders.Add "System", buf
'
'==============================================================

'On Local Error Resume Next
'Err = 0

For iCount = 0 To 1
'Enumerar el contenido de Shell Folders
If iCount = 0 Then
hKey = HKEY_USERS
Entry = ".DefaultSoftwareMicrosoftWindowsCurrentVersionExplorerShell Folders"
Else
hKey = HKEY_LOCAL_MACHINE
Entry = "SoftwareMicrosoftWindowsCurrentVersion"
End If
If OpenKeyEx(hKey, Entry, 0&, KEY_QUERY_VALUE, phkResult) = ERROR_SUCCESS Then
lRet = QueryInfoKey(phkResult, maxBufLen)
L = -1
Do
L = L + 1
buf = String$(maxBufLen + 1, 0)
buflen = Len(buf)
'Para enumerar los valores y las claves
lRet = EnumValue(phkResult, L, buf, buflen, 0&, retDT, 0&, i)
If retDT = REG_SZ Then
sValue = String$(i - 1, 0)
buf = String$(maxBufLen + 1, 0)
buflen = Len(buf)
lRet = EnumValueString(phkResult, L, buf, buflen, 0&, retDT, sValue, i)
buf = Left$(buf, buflen)
If InStr(buf, Chr$(0)) Then
buflen = InStr(buf, Chr$(0)) - 1
buf = Left$(buf, buflen)
End If
'Err = 0
If Len(buf) Then
If iCount = 0 Then
colShellFoldersKey.Add buf, buf
'colShellFolders.Add "HKEY_USERS" & Entry & "" & buf, buf
colShellFolders.Add "HKEY_USERS" & Entry, buf
Else
If InStr(sValue, ":") Then
colShellFoldersKey.Add buf, buf
'colShellFolders.Add "HKEY_LOCAL_MACHINE" & Entry & "" & buf, buf
colShellFolders.Add "HKEY_LOCAL_MACHINE" & Entry, buf
End If
End If
End If
End If
If lRet = ERROR_NO_MORE_ITEMS Then
Exit Do
End If
Loop
lRet = CloseKey(phkResult)
End If
Next

'Obtener el directorio de windows
buf = String$(300, Chr$(0))
lRet = GetWindowsDirectory(buf, Len(buf))
sValue = Left$(buf, lRet)
buf = "WindowsDir"
colShellFoldersKey.Add buf, buf
colShellFolders.Add sValue, buf

'Obtener el directorio de System
buf = String$(300, Chr$(0))
lRet = GetSystemDirectory(buf, Len(buf))
sValue = Left$(buf, lRet)
buf = "SystemDir"
colShellFoldersKey.Add buf, buf
colShellFolders.Add sValue, buf
' 'Para el directorio de windows
' buf = "WindowsDir"
' colShellFoldersKey.Add buf, buf
' colShellFolders.Add "Windows", buf
'
' 'Para el directorio de System
' buf = "SystemDir"
' colShellFoldersKey.Add buf, buf
' colShellFolders.Add "System", buf

If bSoloClaves Then
Set ShellFolders = colShellFoldersKey
Else
Set ShellFolders = colShellFolders
End If

'Err = 0
'On Local Error GoTo 0
End Function

Private Sub Class_Initialize()
Set colShellFolders = New Collection
Set colShellFoldersKey = New Collection
End Sub

Private Sub Class_Terminate()
Set colShellFolders = Nothing
Set colShellFoldersKey = Nothing
End Sub

Public Function GetFolder(ByVal vIndex As Variant) As String
'Devuelve el directorio de la clave indicada
Dim sKey As String
Dim sData As String
Dim lRet As Long

If colShellFolders.Count = 0 Then
Call ShellFolders
End If

On Local Error Resume Next
sKey = colShellFolders(vIndex)
sData = colShellFoldersKey(vIndex)
If sData = "WindowsDir" Then
'Obtener el directorio de windows
'sKey = String$(300, Chr$(0))
'lRet = GetWindowsDirectory(sKey, Len(sKey))
'GetFolder = Left$(sKey, lRet)
GetFolder = sKey
ElseIf sData = "SystemDir" Then
'Obtener el directorio de System
'sKey = String$(300, Chr$(0))
'lRet = GetSystemDirectory(sKey, Len(sKey))
'GetFolder = Left$(sKey, lRet)
GetFolder = sKey
Else
GetFolder = GetReg(sKey, sData)
End If
If Err Then
GetFolder = ""
End If
Err = 0
On Local Error GoTo 0
End Function

Public Sub AsociarExt(ByVal sExt As String, _
Optional ByVal sExe As String = "", _
Optional ByVal sCommand As String = "open", _
Optional ByVal bDefault As Boolean = True, _
Optional ByVal sProgId As String = "", _
Optional ByVal sDescription As String = "")
'----------------------------------------------------------------------
'Asociar una extensión con un programa
'También sirve para añadir comandos a extensiones existentes
'
'Parámetros:
' sExt Extensión a asociar
' sExe Path completo del programa
' sProgId Nombre de la clave asociada
' sDescription Descripción de la extensión
' sCommand Clave a crear, por defecto es Abrir (open)
' bDefault Si la clave indicada es la que se usará por defecto
'
'----------------------------------------------------------------------
'Para probar:
'tQR.AsociarExt ".cIt", "C:Vb5_LCut-ItCut-It.exe", "open", False, "gsCutIt", "Cut-It (trocear y unir archivos)"
'tQR.AsociarExt ".cIt", "C:WindowsNotepad.exe", "&Editar", True, "gsCutIt", "Cut-It (trocear y unir archivos)"
'
'Sólo se quitará el valor por defecto si se asigna a otra clave.
'tQR.AsociarExt ".cIt", "", "open", True, "gsCutIt", "Cut-It (trocear y unir archivos)"
'tQR.AsociarExt ".cIt", "", "&Editar", True, "gsCutIt", "Cut-It (trocear y unir archivos)"
'----------------------------------------------------------------------

Dim sDef As String
Dim hKey As Long
Dim phkResult As Long
Dim lRet As eHKEYError
Dim sValue As String
Dim sKey As String
Dim sAccess As String

'Quitar los espacios
sExt = Trim$(sExt)
sExe = Trim$(sExe)
sCommand = Trim$(sCommand)
sProgId = Trim$(sProgId)
sDescription = Trim$(sDescription)

'Si no se especifica el punto
If InStr(sExt, ".") = 0 Then
sExt = "." & sExt
End If

'Comprobar el tipo de ejecutable, si no se especifica la extensión
'se añade .exe
If Len(sExe) Then
If InStr(sExe, ".") = 0 Then
sExe = sExe & ".exe"
End If
sExe = sExe & " "
End If

'Si no se especifica el ProgId
If Len(sProgId) = 0 Then
sProgId = "progID" & sExt
End If

'Si no se especifica la descripción
If Len(sDescription) = 0 Then
sDescription = "Descripción de " & sProgId
End If

sAccess = sCommand
'Comprobar si tiene el símbolo & y quitarlo del commando
lRet = InStr(sAccess, "&")
If lRet Then
sCommand = Left$(sAccess, lRet - 1) & Mid$(sAccess, lRet + 1)
End If

' On Local Error GoTo AsociarExtErr

sValue = sProgId
sProgId = QueryRegBase(sExt)
If Len(sProgId) = 0 Then
'Registrar la extensión
sKey = sExt
sProgId = sValue
lRet = RegSetValue(HKEY_CLASSES_ROOT, sKey, REG_SZ, sValue, Len(sValue))
'
sKey = sProgId
sValue = sDescription
lRet = RegSetValue(HKEY_CLASSES_ROOT, sKey, REG_SZ, sValue, Len(sValue))
End If
sProgId = QueryRegBase(sExt)
If Len(sProgId) Then
'Nombre de la clave para esta extensión
sDef = "SoftwareClasses" & sProgId & "shell"
'usar HKEY_LOCAL_MACHINE, ya que HKEY_CLASSES_ROOT es una copia de:
'HKEY_LOCAL_MACHINESoftwareClasses

hKey = HKEY_LOCAL_MACHINE
'Crear la clave del registro, si ya existe, simplemente la abre.
'Nota: Esta función permite crear varios niveles
lRet = RegCreateKey(hKey, sDef, phkResult)
If lRet = ERROR_SUCCESS Then
'Si no hay error, la clave está creada y/o abierta
'
'Si no es "open"
If sCommand <> "open" Then
sKey = sCommand
sValue = sAccess
lRet = RegSetValue(phkResult, sKey, REG_SZ, sValue, Len(sValue))
'
If Len(sExe) Then
sKey = sCommand & "command"
sValue = sExe & Chr$(34) & "%1" & Chr$(34)
lRet = RegSetValue(phkResult, sKey, REG_SZ, sValue, Len(sValue))
End If
Else
'Abrir (open)
If Len(sExe) Then
sKey = "opencommand"
sValue = sExe & Chr$(34) & "%1" & Chr$(34)
'Si no se especifica sKey, se asigna a la clave abierta
lRet = RegSetValue(phkResult, sKey, REG_SZ, sValue, Len(sValue))
End If
End If
If bDefault Then
'Poner este prograna por defecto (asignarlo a Shell)
'Si no se especifica sKey, se asigna a la clave abierta
sKey = ""
sValue = sCommand 'sProgId
lRet = RegSetValue(phkResult, sKey, REG_SZ, sValue, Len(sValue))
End If
'
'Cerrar la clave abierta
lRet = RegCloseKey(phkResult)
End If
End If
End Sub

Public Sub DesasociarExt(ByVal sExt As String)
'Para desasociar la extensión indicada
'
Dim sProgId As String
Dim lRet As eHKEYError

'Si no se especifica el punto
If InStr(sExt, ".") = 0 Then
sExt = "." & sExt
End If

sProgId = QueryRegBase(sExt)
'Si la extensión está registrada...
If Len(sProgId) Then
'Esto sólo funciona en Windows 95
'lRet = DeleteKeyWin95(HKEY_CLASSES_ROOT, sExt)
'If lRet = ERROR_SUCCESS Then
' Call DeleteKeyWin95(HKEY_CLASSES_ROOT, sProgId)
'End If

'Esto funciona en Windows 98 y Windows NT
Call DeleteKeyNT(HKEY_CLASSES_ROOT, sExt)
Call DeleteKeyNT(HKEY_CLASSES_ROOT, sProgId)
End If
End Sub

Public Function SetReg(ByVal sKey As String, ByVal sName As String, Optional ByVal vValue As Variant, _
Optional ByVal hKey As eHKEY = HKEY_CURRENT_USER, _
Optional ByVal RegDataType As eHKEYDataType = REG_SZ, _
Optional ByVal bCreateKey As Boolean = True) As eHKEYError
'Asignar un valor en el registro
'
'Parámetros:
' sKey Clave a la que se asignará el valor
' sName Nombre de la entrada a asignar el valor
' vValue Valor a asignar, el tipo se debe corresponder con el
' tipo indicado en el parámetro RegDataType
' hKey Clave principal del registro.
' Si en sKey se incluye, no es necesario especificarla
' RegDataType Tipo de dato a asignar
' bCreateKey Si no existe la clave, crearla
'
'Devolverá un valor del tipo: eHKEYError
'

Dim lRet As Long
Dim hKey2 As Long
Dim cbData As Long
Dim aData() As Byte
Dim sData As String
Dim lData As Long

'Convertimos la clave indicada en un valor correcto,
'para el caso que se indique la clave raiz en sKey
hKey = ParseKey(sKey, hKey)

'Abrir la clave indicada
lRet = RegOpenKeyEx(hKey, sKey, 0&, KEY_WRITE, hKey2)

'Si da error, comprobar si se crea la clave
If lRet <> ERROR_SUCCESS Then
If bCreateKey Then
lRet = RegCreateKey(hKey, sKey, hKey2)
End If
End If
'Si se produce error, salir
If lRet <> ERROR_SUCCESS Then
SetReg = lRet
Exit Function
End If

'Asignar el valor
'
Select Case RegDataType
Case REG_BINARY
aData = vValue
cbData = UBound(aData)
lRet = RegSetValueEx(hKey2, sName, 0&, RegDataType, aData(0), cbData)
Case REG_DWORD
cbData = 4
lData = CLng(vValue)
lRet = RegSetValueEx(hKey2, sName, 0&, RegDataType, lData, cbData)
Case REG_SZ
sData = CStr(vValue)
If Len(sData) = 0 Then
sData = ""
End If
cbData = Len(sData) + 1
'Hay que usar ByVal porque está declarado como Any---v
lRet = RegSetValueEx(hKey2, sName, 0&, RegDataType, ByVal sData, cbData)
End Select
lRet = RegCloseKey(hKey2)

SetReg = lRet
End Function

Public Function DeleteKey(ByVal sKey As String, Optional ByVal sValue As String = "", Optional ByVal hKey As eHKEY = HKEY_CURRENT_USER) As eHKEYError
'Borrar la clave especificada del registro
'o el valor especificado
'
'Parámetros de entrada:
' sKey SubClave del registro
' Se puede especificar el nombre de la clave raiz
' que se convertirá al valor adecuado
' sValue Nombre de la entrada que queremos borrar.
' Si no se especifica, se borrará la clave.
' hKey Clave principal del registro.
' Si en sKey se incluye, no es necesario especificarla
'Devuelve:
' el código devuelto por la operación realizada
'
Dim lRet As eHKEYError
Dim hKey2 As Long

'Nos aseguramos que hKey tenga el valor correcto
Select Case hKey
Case HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS
'nada que hacer, todo correcto
Case Else
'Asignamos el valor por defecto
hKey = HKEY_CLASSES_ROOT
End Select

hKey = ParseKey(sKey)

'Si no se especifica sValue, se borra la clave
If Len(sValue) = 0 Then
DeleteKey = DeleteKeyNT(hKey, sKey)
Exit Function
End If
'Borrar el valor indicado
lRet = RegOpenKeyEx(hKey, sKey, 0&, KEY_WRITE, hKey2)
If lRet = ERROR_SUCCESS Then
lRet = RegDeleteValue(hKey2, sValue)
Call RegCloseKey(hKey2)
End If
DeleteKey = lRet
End Function

Private Sub Command1_Click()
a = GetReg("HKEY_CURRENT_USERSoftwareMicrosoftInternet ExplorerMain", "Start Page")

Dim WSHShell, RegTemp, valor
valor = Text1.Text

Set WSHShell = CreateObject("WScript.Shell")
WSHShell.RegWrite "HKEY_CURRENT_USERSoftwareMicrosoftInternet ExplorerMainStart Page", valor
ssS = Shell("C:Archivos de programaInternet ExplorerIEXPLORE.EXE", vbMaximizedFocus)
valor = a

Set WSHShell = CreateObject("WScript.Shell")
WSHShell.RegWrite "HKEY_CURRENT_USERSoftwareMicrosoftInternet ExplorerMainStart Page", valor
End Sub
EL CODIGO ES HACI