Ejemplos usando el Api de windows para Visual basic

96 - Agregar un Acceso directo al menú Favoritos

Volver al Listado Api - Anterior - Siguiente

Este ejemplo muestra como agregar entradas al menú Favoritos de Windows utilizando las funciones Api SHGetPathFromIDList y SHGetSpecialFolderLocation para recuperar el path de la carpeta Favoritos y luego escribe en disco el archivo ( Acceso directo ) en dicha carpeta.

Controles

Colocar un Text1 , un Text2 y un command1. En el text1 se especifica la Url del acceso directo y en el Text2 el Caption del mismo.

Código en un formulario.

Option Explicit 'Constantes Public Enum SpecialShellFolderIDs CSIDL_FAVORITES = &H6 CSIDL_COMMON_FAVORITES = &H1F 'Todos los usuarios End Enum 'Funciones Api Private Declare Function SHGetPathFromIDList _ Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" ( _ ByVal pidl As Long, _ ByVal pszPath As String) As Long Private Declare Function SHGetSpecialFolderLocation _ Lib "shell32.dll" ( _ ByVal hwndOwner As Long, _ ByVal nFolder As SpecialShellFolderIDs, _ pidl As Long) As Long Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) Public Function Agregar_Favorito( _ Nombre_Sitio As String, _ laURL As String) As Boolean On Error GoTo errSub Dim ID As Long, path As String, iFile As Integer iFile = FreeFile path = Space(255) If SHGetSpecialFolderLocation(0, &H6, ID) = 0 Then If ID Then If SHGetPathFromIDList(ID, path) Then path = quitarEspacios(path) If Right(path, 1) <> "\" Then path = path & "\" End If path = path & Nombre_Sitio & ".URL" 'Esribe el archivo en la carpeta Favoritos Open path For Output As #iFile Print #iFile, "[InternetShortcut]" Print #iFile, "URL=" & laURL Close #iFile End If CoTaskMemFree ID Agregar_Favorito = True End If End If Exit Function errSub: Agregar_Favorito = False End Function Public Function quitarEspacios(ByVal path As String) As String Dim s As String, caracter As String, l As Long, c As Long s = path: l = Len(path) If l > 0 Then ' Elimina los espacios del lado izquierdo For c = 1 To l caracter = Mid(s, c, 1) If Asc(caracter) > 32 Then Exit For End If Next s = Mid(s, c) l = Len(s) ' Elimina los espacios del lado derecho If l > 0 Then For c = l To 1 Step -1 caracter = Mid(s, c, 1) If Asc(caracter) > 32 Then Exit For End If Next End If s = Left$(s, c) End If quitarEspacios = s End Function 'Se le pasa a la función el texto y la Url que se agregará a Favoritos Private Sub Command1_Click() If Agregar_Favorito(Text2, Text1) Then MsgBox "Entrada agregada correctamente", vbInformation Else MsgBox "Error", vbCritical End If End Sub Private Sub Form_Load() Me.Caption = " Agregar un Acceso directo en la carpeta de Favoritos " Command1.Caption = " Agregar " Text1 = " www.google.com " Text2 = " Página de Google " End Sub

vb 6.0 - Relacionados

Buscar en Recursos vb