Sección de código fuente Visual basic

Código fuente - ocx para listar las unidades y carpetas especiales de la pc

Este Activex consta de un control ImageCombo que carga las unidades del sistema y algunas carpetas, como la del escritorio, documentos recientes y algunas otras.

Se puede especificar mediante la propiedad Estilo, si se visualizarán solo los Drives o también el ícono del escritorio de mis documentos y algunas otras carpetas.

El evento Change del mismo es el que se dispara al seleccionar un elemento de la lista y mediante la propiedad Path del control se puede recuperar la ruta seleccionada.

Aclaro que es muy básico el ejemplo, se podrían agregar algunas propiedades, y/o cargar otras carpetas adicionales ...y optimizarlo un poco.

También se podría agregarle para que liste el ícono de Entorno de Red, pero no tengo idea de como capturar dichos datos. :(

Descar código fuente.

Una previa del combo:

Pasos para crear el Control Ocx

Crear un nuevo proyecto de tipo Activex
Desde el menú componentes añadir Microsoft Windows Common Controls 6 y luego colocar dentro del usercontrol un ImageCombo llamado "ImageCombo"
Añadir un control ImageList1. A este no cargarle ninguna imagen, pero especificarle en la solapa general, tamaño de icono de 16 x 16 y la propiedad UseMaskColor en True
Colocar un Picture1 con la propiedad Autoredraw en True, el BackColor en blanco, y 320 de alto x 240 de ancho (en twips)

En la ventana de código del UserControl pegar el siguiente código

Option Explicit '***************************** 'Declaraciones Api '***************************** 'Recupera los Drives Private Declare Function GetLogicalDriveStrings Lib "kernel32" _ Alias "GetLogicalDriveStringsA" ( _ ByVal nBufferLength As Long, _ ByVal lpBuffer As String) As Long 'Recupera información de los archivos Private Declare Function SHGetFileInfo Lib "shell32.dll" _ Alias "SHGetFileInfoA" ( _ ByVal pszPath As String, _ ByVal dwFileAttributes As Long, _ psfi As SHFILEINFO, _ ByVal cbFileInfo As Long, _ ByVal uFlags As Long) As Long 'Dibuja en el Picture1 el ícono que luego se cargará en el control ImageList Private Declare Function ImageList_Draw Lib "comctl32.dll" ( _ ByVal himl As Long, _ ByVal i As Long, _ ByVal hdcDst As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal fStyle As Long) As Long 'Dibuja un icono en un HDC, en este caso en un PictureBox, para el icono de es _ critorio, documetos recientes etc... Private Declare Function DrawIconEx Lib "user32" ( _ ByVal hdc As Long, _ ByVal xLeft As Long, _ ByVal yTop As Long, _ ByVal hIcon As Long, _ ByVal cxWidth As Long, _ ByVal cyWidth As Long, _ ByVal istepIfAniCur As Long, _ ByVal hbrFlickerFreeDraw As Long, _ ByVal diFlags As Long) As Long 'Destruye icono obtenido antes con DrawIconEx Private Declare Function DestroyIcon Lib "user32" ( _ ByVal hIcon As Long) As Long 'Extrae archivos de iconos Private Declare Function ExtractAssociatedIcon _ Lib "shell32.dll" _ Alias "ExtractAssociatedIconA" ( _ ByVal hInst As Long, _ ByVal lpIconPath As String, _ lpiIcon As Long) As Long 'recupera un puntero a la UdtITEMIDLIST de una carpeta especial. Private Declare Function apiSHGetSpecialFolderLocation _ Lib "shell32" _ Alias "SHGetSpecialFolderLocation" ( _ ByVal hwndOwner As Long, _ ByVal nFolder As Long, _ ppidl As Long) As Long ' convierte un item de identificador de lista de un archivo en su path Private Declare Function apiSHGetPathFromIDList _ Lib "shell32" _ Alias "SHGetPathFromIDList" ( _ pidl As Long, _ ByVal pszPath As String) As Long 'Libera bloques de memoria usados Private Declare Sub sapiCoTaskMemFree _ Lib "ole32" _ Alias "CoTaskMemFree" ( _ ByVal pv As Long) '*********************** 'Constantes para las Api '*********************** Private Const DI_MASK = &H1 Private Const DI_IMAGE = &H2 Private Const DI_NORMAL = DI_MASK Or DI_IMAGE 'Para las carpetas especiales, escritorio, Mis documentos etc.. Private Const CSIDL_RECENT = &H8 Private Const CSIDL_DESKTOPDIRECTORY = &H10 Private Const CSIDL_PERSONAL = &H5 Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'Para los iconos usdos con el Api Image_ListDraw Private Const SHGFI_DISPLAYNAME = &H200 Private Const SHGFI_TYPENAME = &H400 Private Const SHGFI_LARGEICON = &H0 Private Const SHGFI_SMALLICON = &H1 Private Const SHGFI_SYSICONINDEX = &H4000 Private Const ILD_TRANSPARENT = &H1 Private Const MAX_PATH = 260 Private Const Drives = SHGFI_SYSICONINDEX Or SHGFI_SMALLICON Or SHGFI_DISPLAYNAME Private Const Iconos = SHGFI_SYSICONINDEX Or SHGFI_SMALLICON Or SHGFI_DISPLAYNAME Or _ SHGFI_TYPENAME '**************************** 'Estructuras '**************************** 'Estructura necesaria para el Api SHGetFileInfo Private Type SHFILEINFO hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * MAX_PATH szTypeName As String * 80 End Type Enum E_Estilo [Solo Drives] = 0 [Normal] = 1 End Enum '********************************* 'Variables '********************************* 'Variable para usar SHFILEINFO Dim FI As SHFILEINFO 'Handle de imagen para usar con el Api Image_ListDraw Dim hImage As Long 'Valores de propiedades por default: Const m_def_Path = "" Const m_def_hWnd = 0 Private m_def_Estilo As E_Estilo 'Copia de las variables locales: Dim m_Path As String Dim m_hWnd As Long Private m_Text As String Private m_Estilo As Long Private m_ListIndex As Integer '**************************** 'Declaraciones de eventos: '**************************** Event Change() 'MappingInfo=ImageCombo1,ImageCombo,-1,Change Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=ImageCombo1, _ ImageCombo , -1, KeyDown Event KeyPress(KeyAscii As Integer) 'MappingInfo=ImageCombo1,ImageCombo,-1,KeyPress Event KeyUp(KeyCode As Integer, Shift As Integer) _ 'MappingInfo=ImageCombo1,ImageCombo,-1,KeyUp Event Validate(Cancel As Boolean) 'MappingInfo=ImageCombo1,ImageCombo,-1,Validate '********************* 'Métodos y funciones '*********************+ Public Sub Refresh() Dim strSave As String * 80, i As Integer ImageList1.BackColor = ImageCombo.BackColor ImageCombo.ComboItems.Clear If m_Estilo Then 'Recientes '************ Extraer fGetSpecialFolderLocation(CSIDL_RECENT), Iconos, ILD_TRANSPARENT, 0 'Escritorio '************ ExtraerOtros "Escritorio", 2, 1, _ fGetSpecialFolderLocation(CSIDL_DESKTOPDIRECTORY), 2, 3 'Mis documentos '************** Extraer fGetSpecialFolderLocation(CSIDL_PERSONAL), Iconos, ILD_TRANSPARENT, 1 'Extraer icono Mi Pc '*******************+ ExtraerOtros "Mi PC", 4, 1, "Mi PC", 4, 0 End If 'Drives '************* GetLogicalDriveStrings 80, strSave For i = 1 To 20 If StripTerminator(strSave) = "" Then Exit For Extraer StripTerminator(strSave), Drives, SHGFI_LARGEICON, 3 strSave = Right$(strSave, Len(strSave) - InStr(1, strSave, Chr$(0))) Next i If m_Estilo Then 'Mis documentos todoso los Users '********************************* Extraer fGetSpecialFolderLocation(CSIDL_COMMON_DOCUMENTS), _ Iconos, ILD_TRANSPARENT, 2 'Elementos de escritorio '************************** ListarCombo fGetSpecialFolderLocation(CSIDL_DESKTOPDIRECTORY) End If 'Seleccionamos el escritorio en el imageCombo ImageCombo.SelectedItem = ImageCombo.ComboItems(m_ListIndex) If m_Path = "" Then m_Path = ImageCombo.SelectedItem.Tag End If End Sub 'Extrae los iconos del archivo explorer.exe para el escritorio y Mi PC '******************************************************************** Private Sub ExtraerOtros(cCaption As String, pos As Integer, indent As Integer, _ tTag As String, indice As Integer, iIcono As Long) Dim mIcon As Long Picture1.Cls With ImageCombo mIcon = ExtractAssociatedIcon(App.hInstance, Environ$("windir") _ & "\explorer.exe", iIcono) DrawIconEx Picture1.hdc, 0, 0, mIcon, 16, 16, 0, 0, DI_NORMAL DestroyIcon mIcon ImageList1.ListImages.Add , Picture:=Picture1.Image .ComboItems.Add , , cCaption, pos, pos, indent .ComboItems(indice).Tag = tTag End With End Sub 'Extrae los Drives '***************** Private Sub Extraer(Ruta As String, _ flag As Long, _ Estilo As Long, _ Identation As Integer) Picture1.Cls hImage = SHGetFileInfo(Ruta, ByVal 0&, FI, Len(FI), flag) ImageList_Draw hImage, FI.iIcon, Picture1.hdc, 0, 0, Estilo ImageList1.ListImages.Add , Picture:=Picture1.Image If ImageCombo.ImageList Is Nothing Then Set ImageCombo.ImageList = ImageList1 End If ImageCombo.ComboItems.Add , , StripTerminator(FI.szDisplayName), _ ImageList1.ListImages.Count, ImageList1.ListImages.Count, _ Identation ImageCombo.ComboItems(ImageCombo.ComboItems.Count).Tag = Ruta End Sub 'Lista los elementos del esxritorio '************************************ Private Sub ListarCombo(Ruta As String) Dim Directorios As String If Not Right(Ruta, 1) = "\" Then Ruta = Ruta & "\" End If Directorios = Dir(Ruta, vbDirectory) Do While Directorios <> "" If Directorios <> "." And Directorios <> ".." Then If (GetAttr(Ruta & Directorios) And vbDirectory) = vbDirectory Then Extraer Ruta & Directorios, Iconos, ILD_TRANSPARENT, 1 End If End If Directorios = Dir Loop End Sub 'Recupera el path y descripción de las Carpetas especiales de windows '********************************************************************** Private Function fGetSpecialFolderLocation(ByVal lngCSIDL As Long) As String Dim lngRet As Long Dim strLocation As String Dim pidl As Long ' retrieve a PIDL for the specified location lngRet = apiSHGetSpecialFolderLocation(UserControl.hWnd, lngCSIDL, pidl) If lngRet = 0 Then strLocation = Space$(MAX_PATH) ' convert the pidl to a physical path lngRet = apiSHGetPathFromIDList(ByVal pidl, strLocation) If Not lngRet = 0 Then ' if successful, return the location fGetSpecialFolderLocation = Left$(strLocation, _ InStr(strLocation, vbNullChar) - 1) End If Call sapiCoTaskMemFree(pidl) End If End Function 'Función que elimina los espacios nulos '**************************************** Private Function StripTerminator(sInput As String) As String Dim ZeroPos As Integer ZeroPos = InStr(1, sInput, vbNullChar) If ZeroPos > 0 Then StripTerminator = Left$(sInput, ZeroPos - 1) Else StripTerminator = sInput End If End Function '********************************** 'Propiedades '********************************** 'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS 'MappingInfo=ImageCombo1,ImageCombo,-1,BackColor Public Property Get BackColor() As OLE_COLOR BackColor = ImageCombo.BackColor End Property Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR) ImageCombo.BackColor() = New_BackColor If Ambient.UserMode Then Refresh End If PropertyChanged "BackColor" End Property 'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS 'MappingInfo=ImageCombo1,ImageCombo,-1,Font Public Property Get Font() As Font Set Font = ImageCombo.Font End Property Public Property Set Font(ByVal New_Font As Font) Set ImageCombo.Font = New_Font PropertyChanged "Font" End Property 'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS 'MappingInfo=ImageCombo1,ImageCombo,-1,ForeColor Public Property Get ForeColor() As OLE_COLOR ForeColor = ImageCombo.ForeColor End Property Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR) ImageCombo.ForeColor() = New_ForeColor PropertyChanged "ForeColor" End Property 'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS 'MappingInfo=ImageCombo1,ImageCombo,-1,ToolTipText Public Property Get ToolTipText() As String ToolTipText = ImageCombo.ToolTipText End Property Public Property Let ToolTipText(ByVal New_ToolTipText As String) ImageCombo.ToolTipText() = New_ToolTipText PropertyChanged "ToolTipText" End Property 'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS 'MemberInfo=8,0,0,0 Public Property Get hWnd() As Long hWnd = ImageCombo.hWnd End Property Public Property Let hWnd(ByVal New_hWnd As Long) MsgBox "La propiedad es de solo lectura", vbInformation, "Error" End Property 'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS 'MemberInfo=13,0,0,0 Public Property Get Path() As String Path = m_Path End Property Public Property Let Path(ByVal New_Path As String) MsgBox "La propiedad es de solo lectura. Utilizar ListIndex para cambiar la unidad", _ vbExclamation, "Error" End Property Public Property Get Estilo() As E_Estilo Estilo = m_Estilo End Property Public Property Let Estilo(ByVal vNewValue As E_Estilo) If Ambient.UserMode = False Then m_Estilo = vNewValue 'Refresh PropertyChanged "Estilo" m_ListIndex = 2 Else MsgBox "La propiedad es de solo lectura", vbCritical, "Error" End If End Property Public Property Get ListIndex() As Integer ListIndex = m_ListIndex End Property Public Property Let ListIndex(Value As Integer) m_ListIndex = Value If Ambient.UserMode Then ImageCombo.SelectedItem = ImageCombo.ComboItems(Value) m_Path = ImageCombo.ComboItems(Value).Tag RaiseEvent Change End If PropertyChanged "ListIndex" End Property Private Sub ImageCombo_Dropdown() 'Antes de refrescar guardamos el índice seleccionado m_ListIndex = ImageCombo.SelectedItem.Index 'refrescamos el ImageCombo cargando todo nuevamente Refresh End Sub '********************* 'Eventos del imagecombo '********************* Private Sub ImageCombo_KeyDown(KeyCode As Integer, Shift As Integer) RaiseEvent KeyDown(KeyCode, Shift) End Sub Private Sub ImageCombo_KeyPress(KeyAscii As Integer) RaiseEvent KeyPress(KeyAscii) End Sub Private Sub ImageCombo_KeyUp(KeyCode As Integer, Shift As Integer) RaiseEvent KeyUp(KeyCode, Shift) End Sub Private Sub ImageCombo_Validate(Cancel As Boolean) RaiseEvent Validate(Cancel) End Sub Private Sub ImageCombo_Click() Dim pos As Integer With ImageCombo.SelectedItem If InStr(Len(.Tag), .Tag, "\") Then m_Path = Left(.Tag, Len(.Tag) - 1) Else m_Path = .Tag End If End With m_ListIndex = ImageCombo.SelectedItem.Index RaiseEvent Change End Sub '*************************************************** 'Inicialización, escritura y lectura de propiedades '*************************************************** 'Inicializar propiedades para control de usuario Private Sub UserControl_InitProperties() m_hWnd = ImageCombo.hWnd m_Estilo = 1 ImageCombo.Text = Extender.Name m_Path = m_def_Path m_ListIndex = 2 End Sub 'Cargar valores de propiedad desde el almacén Private Sub UserControl_ReadProperties(PropBag As PropertyBag) ImageCombo.BackColor = PropBag.ReadProperty("BackColor", &H80000005) Set ImageCombo.Font = PropBag.ReadProperty("Font", Ambient.Font) ImageCombo.ForeColor = PropBag.ReadProperty("ForeColor", &H80000008) ImageCombo.ToolTipText = PropBag.ReadProperty("ToolTipText", "") m_hWnd = PropBag.ReadProperty("hWnd", m_def_hWnd) m_Path = PropBag.ReadProperty("Path", m_def_Path) ImageCombo.Text = Extender.Name m_Estilo = PropBag.ReadProperty("Estilo", m_def_Estilo) m_ListIndex = PropBag.ReadProperty("ListIndex", 1) End Sub 'Escribir valores de propiedad en el almacén Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("BackColor", ImageCombo.BackColor, &H80000005) Call PropBag.WriteProperty("Font", ImageCombo.Font, Ambient.Font) Call PropBag.WriteProperty("ForeColor", ImageCombo.ForeColor, &H80000008) Call PropBag.WriteProperty("ToolTipText", ImageCombo.ToolTipText, "") Call PropBag.WriteProperty("hWnd", m_hWnd, m_def_hWnd) Call PropBag.WriteProperty("Path", m_Path, m_def_Path) Call PropBag.WriteProperty("Estilo", m_Estilo, m_def_Estilo) Call PropBag.WriteProperty("ListIndex", m_ListIndex, 1) End Sub '************************** 'Eventos del UserControl '************************** Private Sub UserControl_Resize() Height = ImageCombo.Height ImageCombo.Width = Width ImageCombo.Move 0, 0 End Sub Private Sub UserControl_Show() If Ambient.UserMode Then ImageCombo.Enabled = True Picture1.BackColor = vbWhite 'cargamos el imagecombo Refresh Else ImageCombo.Enabled = False End If End Sub

Buscar en Recursos vb