Sección de códigos , trucos y ejemplos para visual basic

502 - Cargar solo unidades y carpetas de sistema en un Treeview ( Sin subdirectorios )

Este es un simple módulo de clase en vb para poder cargar en un Treeview, las unidades y carpetas de sistema, similar al explorer. Pero no es igual al explorador de windows, solo visualiza las unidades y las carpetas especiales, es decir que no carga y muestra la estructura de directorios al seleccionar una carpeta o recurso del sistema. Se podría decir que es similar al control Drive de vb, pero utilizando un Treeview, y con algunas otras opciones extra en comparación al Drive, como la de poder:

Mostrar solo unidades
Mostrar unidades+Algunas carpetas de sistema de windows ( Font, windows, system32, Archivos de programa)
Mostrar unidades+Directorios de sistema del usuario actual
Mostrar unidades+Directorios de sistema de todos los usuarios

Nota. El módulo no está completo, solo tiene implementadas las opciones mencionadas anteriormente, pero obviamente se le pueden añadir muchas otras funciones.

Algunas de ellas podrían ser:

En vez de cargar todas las carpetas en el método Init del módulo, hacerlo mediante un método propio. De este modo se podría recorrer la colección de carpetas y añadir las que se quieran, ya que como está realizado, carga todas. De todas formas se podría hacer, eliminando de la colección los elementos que se quieran, y luego ejecutar el método Init nuevamente para cargar el Treeview. O crear una propiedad, que indique cuales carpetas cargar, y luego se ignoren aquellas que no se han elegido, ( todo esto en el bucle del método init que añade los nodos), o la rutina "pvInitColPathsFolders"
Añadir la etiqueta de volumen a cada unidad. Es algo simple, solo se debería utilizar la Api GetVolumeInformation , obtener la etiqueta, y asignarla a la propiedad Text del nodo. ( ejemplo de GetVolumeInformation ). Si se añade esta función, no afectaría a la propiedad Path, ya que se utiliza la clave para hacer referencia a la Ruta, no la propiedad Text. Por lo tanto no hay que modificar otras rutinas.
Añadir la opción Mis sitios de Red ( no está implementado ), al igual que algunas otras como la papelera.
El módulo carga en el Treeview todo en una lista ( no se crea en ningún momento subNodos). Entonces, otra opción podría ser agrupar en nodos: Un Nodo para los drives, otro nodo para las carpetas del usuario, y otro para las carpetas de windows. ( Para que quede mas organizado)
Ordenar alfabéticamente las colecciones de carpetas utilizando algún algoritmo de ordenación, ya que como está realizado el ejemplo, no sirve utilizar la propiedad Sorted del Treeview, por que las unidades no quedarían al comienzo, es decir quedarían mezcladas entre toda la lista. ( Creo que si se implementa la opción anterior, ahora si se podria utilizar la propiedad Sorted, no el Sorted del Treeview, si no el Sorted del nodo)
Agregar algunos eventos, el ejemplo es bien simple y solo contiene uno que permite obtener el path actual, para de este modo utilizarlo con algún otro control que liste los directorios+archivos.

Nota importante: Probar el ejemplo en otras versiones de windows para comprobar que no tiene errores, ya que solo se probó en XP. ( Aunque tampoco aseguro que no tenga algún error en xp )

Vista previa del ejemplo

Crear el ejemplo:

Iniciar un nuevo proyecto
Añadir un módulo de clase. Cambiar el nombre del Módulo ( por defecto Class1) a clsTVDrives ( Sin espacios )
Agregar la referencia a windows CommonControls 5. Añadir un Treeview ( Treeview1) y un ImageList (ImageList1)
Añadir cuatro Option Button en un Array ( Option1(0), Option1(1), Option1(2) y Option1(3))
Agregar una caja de verificación ( Check1)
Dos botones ( Command1 y Command2 )

Importante : Para utilizarlo con el Treeview de la versión 6, hay que cambiar esta línea

Private Sub mTVDrives_NodeClick(ByVal Node As ComctlLib.Node)

por esta otra

Private Sub mTVDrives_NodeClick(ByVal Node As MsComctlLib.Node)

Código fuente en el Form

Option Explicit ' \\ Declaraciones ' ------------------------------------------------------------------------------------------ Private Declare Function SetErrorMode Lib "kernel32" (ByVal wMode As Long) As Long Private Declare Sub InitCommonControls Lib "Comctl32" () Private WithEvents mCTvDrives As clsTVDrives ' ----------------------------------------------------------------------------------------- ' \\ -- Cambiar tamaño de los íconos ' ----------------------------------------------------------------------------------------- Private Sub Check1_Click() Dim lIndex As Integer If Option1(0).Value Then lIndex = 0 If Option1(1).Value Then lIndex = 1 If Option1(2).Value Then lIndex = 2 If Option1(3).Value Then lIndex = 3 ' -- Actualizar Call Option1_Click(lIndex) End Sub ' ----------------------------------------------------------------------------------------- ' \\ -- Botón para establecer el selected item ' ----------------------------------------------------------------------------------------- Private Sub Command1_Click() Dim sValue As String sValue = InputBox("Establecer el item a seleccionar. Indicar el Drive, incluida la barra, o una ruta de una carpeta ( Path completo sin barra al final)") If Len(sValue) Then With mCTvDrives .Path = sValue End With End If End Sub ' ----------------------------------------------------------------------------------------- ' \\ -- Botón para recorrer los elementos e imprimirlos en la ventana inmediato de vb ' ----------------------------------------------------------------------------------------- Private Sub Command2_Click() Dim xItem As Variant With mCTvDrives For Each xItem In .ColDrives Debug.Print CStr(xItem) Next Debug.Print String(200, "*") Debug.Print String(200, "-") For Each xItem In .ColSFolderAllUsers Debug.Print CStr(xItem) Next Debug.Print String(200, "*") Debug.Print String(200, "-") For Each xItem In .ColSFolderCurrentUser Debug.Print CStr(xItem) Next Debug.Print String(200, "*") Debug.Print String(200, "-") For Each xItem In .ColSystemPaths Debug.Print CStr(xItem) Next End With End Sub ' ----------------------------------------------------------------------------------------- ' \\ -- Ejecutar InitCommonControls ' ----------------------------------------------------------------------------------------- Private Sub Form_Initialize() ' -- Evitar diálogos de error del sistema Call SetErrorMode(2) Call InitCommonControls End Sub ' ----------------------------------------------------------------------------------------- ' \\ -- Inicio del formulario ' ----------------------------------------------------------------------------------------- Private Sub Form_Load() ' -- Crear instancia Set mCTvDrives = New clsTVDrives ' -- Setear controles Option1(0).Caption = "Solo unidades" Option1(1).Caption = "Unidades+Carpetas del usuario actual" Option1(2).Caption = "Unidades+Carpetas de todos los usuarios" Option1(3).Caption = "Unidades+carpetas de windows" Check1.Caption = "Iconos Grandes" ' -- Cargar Option1(1).Value = True Command1.Caption = "Seleccionar item" End Sub ' ----------------------------------------------------------------------------------------- ' \\ -- Obtener el path/Drive ' ----------------------------------------------------------------------------------------- Private Sub mCTvDrives_ItemClick(ByVal sPath As String) On Error GoTo error_handler Me.Caption = sPath Exit Sub error_handler: MsgBox Err.Description, vbCritical, "Error en mCTvDrives_ItemClick" End Sub ' ----------------------------------------------------------------------------------------- ' \\ -- opciones de carga dependiendo del botón de opción seleccionado ' ----------------------------------------------------------------------------------------- Private Sub Option1_Click(Index As Integer) ' -- Setear opción ( que elementos cargar ) Dim lFolderDrives As eLoadSpecialFolder Select Case Index Case 0: lFolderDrives = eNothing Case 1: lFolderDrives = eCurrentUser Case 2: lFolderDrives = eAllUser Case 3: lFolderDrives = eWindowsPaths End Select With mCTvDrives If Check1.Value = 0 Then ' -- Cargar de 16 pixeles Call .init(TreeView1, ImageList1, eSmallIcon, lFolderDrives) Else ' -- Cargar de 32 pixeles Call .init(TreeView1, ImageList1, eLargeIcon, lFolderDrives) End If End With End Sub ' ----------------------------------------------------------------------------------------- ' \\ -- Salir ' ----------------------------------------------------------------------------------------- Private Sub Form_Unload(Cancel As Integer) If Not mCTvDrives Is Nothing Then Set mCTvDrives = Nothing End Sub

Código fuente en el módulo de clase ( clsTVDrives )

Option Explicit ' -------------------------------------------------------------------------- ' \\ -- Descripción : Simple módulo de clase para cargar solo los Drives en un Treeview ' , y las carpetas de sistema del usuario y algunas principales de windows. ' ' -- Autor : Luciano Lodola - http://www.recursosvisualbasic.com.ar/ ' ' -- Créditos : 1 - Al autor de la función LoadIcon ( Desconocido ) ' 2 - Al sitio web vbnet.mvps.org por el uso de la función setErrorMode con el modo SEM_FAILCRITICALERRORS ( http://vbnet.mvps.org/index.html?code/disk/floppyready.htm ) ' 3 - Al sitio allapi.mentalis.org, por el uso del Api SHGetSpecialFolderLocation y getLogicalDrives ' ' -- Importante : 1 - Este módulo funciona con el Treeview de la versión 5, ' en caso de pasar un Treeview de la versión 6, solo hay que cambiar el parámetro ' ComctlLib.Node, por MSComctlLib.Node ( por que no se puede declarar como Object), ' Esto hacerlo en el evento NodeClick de este módulo. ' 2 - El código fue solo probado en windows XP. ' ' -- Derechos : Este código fuente no contiene ningún tipo de restricción. ' Se puede utilizar, distribuir y modificar sin ninguna limitación o restricción. ' Aunque no es obligatorio, en caso de utilizarlo en un programa o publicarlo en un sitio, se agradece mensionar a los autores del mismo. ' -------------------------------------------------------------------------- ' -------------------------------------------------------------------------- ' \\ -- Declaraciones de constantes ' -------------------------------------------------------------------------- ' -- Const SEM_FAILCRITICALERRORS As Long = &H1 Const SEM_NOOPENFILEERRORBOX As Long = &H8000& ' -------------------------------------------------------------------------- ' \\ -- Declaraciones de UDT ' -------------------------------------------------------------------------- Private Type SHITEMID cb As Long abID As Byte End Type ' -- Usado por SHGetFileInfo Private Type IconType cbSize As Long picType As PictureTypeConstants hIcon As Long End Type ' -- Usado por SHGetFileInfo Private Type CLSIdType id(16) As Byte End Type Private Type ITEMIDLIST mkid As SHITEMID End Type ' -- Usado por ShellFileInfo Private Type ShellFileInfoType hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * 260 szTypeName As String * 80 End Type ' -------------------------------------------------------------------------- ' \\ -- Enumeraciones ' -------------------------------------------------------------------------- ' -- Enum que define si se cargan, además de los Drives, ' las carpetas del usuario actual, de todos los usuarios, y las de sistema Enum eLoadSpecialFolder [eNothing] = 0 [eCurrentUser] = 1 [eAllUser] = 2 [eWindowsPaths] = 3 End Enum ' -- No implementado ( Para organizar y agrupar los nodos ) Enum eLoadMode [eNodes] = 0 [eList] = 1 End Enum ' -- Define el tamaño de los íconos Enum eIconSize eSmallIcon = 257 eLargeIcon = 256 End Enum ' -- Enum para Carpetas de sistema Enum eCSIDL_SPECIAL_FOLDERS e_ADMINTOOLS = &H30 e_ALTSTARTUP = &H1D e_APPDATA = &H1A e_BITBUCKET = &HA e_COMMON_ADMINTOOLS = &H2F e_COMMON_ALTSTARTUP = &H1E e_COMMON_APPDATA = &H23 e_COMMON_DESKTOPDIRECTORY = &H19 e_COMMON_DOCUMENTS = &H2E e_COMMON_FAVORITES = &H1F e_COMMON_PROGRAMS = &H17 e_COMMON_STARTMENU = &H16 e_COMMON_STARTUP = &H18 e_COMMON_TEMPLATES = &H2D e_CONNECTIONS = &H31 e_CONTROLS = &H3 e_COOKIES = &H21 e_DESKTOP = &H0 e_DESKTOPDIRECTORY = &H10 e_DRIVES = &H11 e_FAVORITES = &H6 e_FLAG_DONT_VERIFY = &H4000 e_FLAG_MASK = &HFF00& e_FLAG_PFTI_TRACKTARGET = e_FLAG_DONT_VERIFY e_FONTS = &H14 e_INTERNET = &H1 e_HISTORY = &H22 e_INTERNET_CACHE = &H20 e_LOCAL_APPDATA = &H1C e_MYPICTURES = &H27 e_NETHOOD = &H13 e_NETWORK = &H12 e_PERSONAL = &H5 e_PRINTERS = &H4 e_PRINTHOOD = &H1B e_PROFILE = &H28 e_PROGRAM_FILES = &H26 e_PROGRAM_FILES_COMMON = &H2B e_PROGRAM_FILES_COMMONX86 = &H2C e_PROGRAM_FILESX86 = &H2A e_PROGRAMS = &H2 e_RECENT = &H8 e_SENDTO = &H9 e_STARTMENU = &HB e_STARTUP = &H7 e_SYSTEM = &H25 e_SYSTEMX86 = &H29 e_TEMPLATES = &H15 e_WINDOWS = &H24 End Enum ' -------------------------------------------------------------------------- ' \\ -- Funciones de windows ' -------------------------------------------------------------------------- Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As ShellFileInfoType, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As IconType, riid As CLSIdType, ByVal fown As Long, lpUnk As Object) As Long Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long Private Declare Function GetLogicalDrives Lib "kernel32" () As Long Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long Private Declare Function SetErrorMode Lib "kernel32" (ByVal wMode As Long) As Long ' -------------------------------------------------------------------------- ' \\ -- Declaraciones de variables ' -------------------------------------------------------------------------- ' -- No implementado ( para organizar el TReeview - Por un lado los Drives en un nodo, y por el otro las carpetas en otro nodo) Private mLoadMode As eLoadMode Private mColDrives As Collection ' -- Colecciónde unidades Private WithEvents mTVDrives As Treeview ' -- Referencia al treeview ( Con evento - NodeClick) Private mImageList As imageList ' -- Referencia al imagelist Private mPath As String ' -- Recurso seleccionado actualmente Private mColSFolderCurrentUser As Collection ' -- Colecciones Private mColSFolderAllUsers As Collection Private mColSystemPaths As Collection ' -------------------------------------------------------------------------- ' \\ -- Declaraciones de Eventos ' -------------------------------------------------------------------------- ' -- Evento para enviar el drive como parámetro o el path de las carpetas ' en caso que se pase como parámetro optSpecialFolder Event ItemClick(ByVal sPath As String) ' --------------------------------------------------------------------------------------- ' --------------------------------------------------------------------------------------- ' \\ -- Fin de declaraciones ' --------------------------------------------------------------------------------------- ' --------------------------------------------------------------------------------------- ' \\ -- Inicio del módulo al instanciarlo ' --------------------------------------------------------------------------------------- Private Sub Class_Initialize() ' -- crear nueva colección para almacenar los drives Set mColDrives = New Collection ' -- Llamar a la función que obtiene y devuelve una colección con las unidades ' utilizando la función de windows GetLogicalDrives Set mColDrives = pvGetDrives ' -- cargar colecciones con las carpetas de sistema Call pvInitColPathsFolders ' -- Para no desplegar el diálogo de error de windows ' al no poder acceder a una unidad no disponible _ ' Nota: No es necesario en este módulo (no se usa), pero lo setea para ' cuando se enlace con otro control que si quiera acceder a un drive no disponible) Call SetErrorMode(SEM_FAILCRITICALERRORS) End Sub ' --------------------------------------------------------------------------------------- ' \\ -- Fin del módulo - Al eliminar la referencia ' --------------------------------------------------------------------------------------- Private Sub Class_Terminate() ' -- Destruir colecciones y objetos Set mColDrives = Nothing Set mColSFolderCurrentUser = Nothing Set mColSFolderAllUsers = Nothing Set mColSystemPaths = Nothing End Sub ' -------------------------------------------------------------------------- ' \\ -- Inicio del módulo para la carga de las unidades ' ( Recibe el treeview, imagelist, el tamaño de imagen y ' los elementos a listar ( Drives solos o Drives+Carpetas)) ' -------------------------------------------------------------------------- Sub init(Treeview As Treeview, imageList As imageList, lIconSize As eIconSize, optSpecialFolder As eLoadSpecialFolder) On Error GoTo error_handler ' -- Referenciar controles Set mTVDrives = Treeview Set mImageList = imageList ' -- Setear propiedades del treeview With mTVDrives ' -- Propiedades opcionales .HideSelection = False .LineStyle = tvwRootLines ' -- Estilo de arbol .Indentation = 6 ' -- Indentacion .LabelEdit = tvwManual ' -- No editar el nodo .Sorted = False ' -- Fin de Propiedades opcionales .Nodes.Clear If Not .imageList Is Nothing Then Set mTVDrives.imageList = Nothing End With ' -- Setear propiedades del imagelist ( Tamaño de los íconos a almacenar) With mImageList .ListImages.Clear If lIconSize = eLargeIcon Then .ImageHeight = 32 .ImageWidth = 32 Else .ImageHeight = 16 .ImageWidth = 16 End If ' -- Recorrer la colección de Drives Dim xDrive As Variant Dim xNode As Node For Each xDrive In mColDrives ' -- Agregar el ícono del Drive en la lista de imagenes .ListImages.Add , CStr(xDrive), LoadIcon(lIconSize, CStr(xDrive)) ' -- Enlazar el Treeview con la lista de imagenes If mTVDrives.imageList Is Nothing Then mTVDrives.imageList = mImageList ' -- Agregar el nodo ( La unidad ) Set xNode = mTVDrives.Nodes.Add(, , CStr(xDrive), CStr(xDrive), CStr(xDrive)) Next ' -- Crear colección para referenciarla con mColSFolderAllUsers, mColSFolderCurrentUser o mColSystemPaths Dim xColection As New Collection ' -- Incluir o no las carpetas de sistema ( Referenciar la colección a utilizar ) If optSpecialFolder = eAllUser Then Set xColection = mColSFolderAllUsers If optSpecialFolder = eCurrentUser Then Set xColection = mColSFolderCurrentUser If optSpecialFolder = eWindowsPaths Then Set xColection = mColSystemPaths Dim xPath As Variant ' -- Si se listan los directorios de sistema .. entonces If optSpecialFolder <> eNothing Then ' -- recorrer la colección For Each xPath In xColection ' -- Agregar ícono de carpeta, path .ListImages.Add , UCase(CStr(xPath)), LoadIcon(lIconSize, CStr(xPath)) ' -- Agregar al treeview mTVDrives.Nodes.Add , , UCase(CStr(xPath)), GetFolderName(CStr(xPath)), UCase(CStr(xPath)) Next End If End With ' -- destruir colección temporal If Not xColection Is Nothing Then Set xColection = Nothing Set xNode = Nothing ' -- Errores --------------------------------------------------------- Exit Sub error_handler: MsgBox Err.Description, vbCritical, "Error en el inicio del módulo" End Sub ' -------------------------------------------------------------------------- ' \\ -- Obtener solo la carpeta de la ruta completa ' -------------------------------------------------------------------------- Function GetFolderName(ByVal sPath As String) On Error GoTo error_handler ' -- verificar el BackSlash If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1) ' -- Separar los directorios en el array Dim arrFolders() As String arrFolders = Split(sPath, "\") ' -- Retornar la carpeta ( el ultimo elemento del array ) GetFolderName = arrFolders(UBound(arrFolders)) Exit Function ' -- Errores --------------------------------------------------------- error_handler: End Function ' ----------------------------------------------------------------------------------------- ' \\ -- Devuelve True si se puede acceder a un drive ' ----------------------------------------------------------------------------------------- Function DriveIsReady(ByVal sDrive As String) As Boolean Screen.MousePointer = vbHourglass If Len(sDrive) = 1 Then sDrive = sDrive & ":\" If Len(sDrive) = 2 Then sDrive = sDrive & "\" DriveIsReady = GetVolumeInformation(sDrive, vbNullString, 0, 0, 0, 0, vbNullString, 0) Screen.MousePointer = vbDefault End Function ' ----------------------------------------------------------------------------------------- ' \\ -- Devolver los íconos de las unidades y de las carpetas de sistema del usuario ' ----------------------------------------------------------------------------------------- Function LoadIcon(lIconSize As eIconSize, sFileName As String) As IPictureDisp Dim ret As Long Dim Unkown As IUnknown Dim Icon As IconType Dim CLSID As CLSIdType Dim ShellInfo As ShellFileInfoType Call SHGetFileInfo(sFileName, 0, ShellInfo, Len(ShellInfo), lIconSize) With Icon .cbSize = Len(Icon) .picType = 3 .hIcon = ShellInfo.hIcon End With With CLSID .id(8) = &HC0 .id(15) = &H46 End With ret = OleCreatePictureIndirect(Icon, CLSID, 1, Unkown) Set LoadIcon = Unkown End Function ' ----------------------------------------------------------------------------------------- ' \\ -- Devolver Colección con las unidades ( se llama desde el class_Init) ' ----------------------------------------------------------------------------------------- Private Function pvGetDrives() As Collection Dim LDs As Long Dim Cnt As Long Dim sDrive As String Dim tempCol As Collection ' -- Colección temporal Set tempCol = New Collection ' -- Obtener las unidades LDs = GetLogicalDrives ' -- Recorrer unidades y añadirlas a la colección For Cnt = 0 To 25 If (LDs And 2 ^ Cnt) <> 0 Then sDrive = CStr(Chr$(65 + Cnt)) If Right(sDrive, 2) <> ":\" Then sDrive = sDrive & ":\" tempCol.Add sDrive, sDrive End If Next Cnt ' -- Retornar colección a la función Set pvGetDrives = tempCol Set tempCol = Nothing End Function ' --------------------------------------------------------------------------------------- ' \\ -- Llena las colecciones con las rutas de las carpetas de sistema ( se llama desde el inicio ) ' --------------------------------------------------------------------------------------- Private Sub pvInitColPathsFolders() On Error GoTo error_handler Dim i As Long Dim sPathSpecialFolder As String Dim sPathCurrentUser As String Dim sPathAllUsers As String ' -- Inicio de variables Set mColSFolderCurrentUser = New Collection Set mColSFolderAllUsers = New Collection Set mColSystemPaths = New Collection ' -- Obtener ruta base del usuario actual sPathCurrentUser = Environ("USERPROFILE") ' -- Obtener ruta base de la carpeta de todos los usuarios sPathAllUsers = Environ("ALLUSERSPROFILE") ' -- Recorrer y Obtener las carpetas especiales de windows For i = 1 To 100 sPathSpecialFolder = GetPath(i) ' -- Comprobar el path If sPathSpecialFolder <> "" Then ' -- Si es el usuario actual agregarlo a la colección ... If InStr(sPathSpecialFolder, sPathCurrentUser) Then mColSFolderCurrentUser.Add sPathSpecialFolder ' -- Si es la de todos los usuarios ... ElseIf InStr(sPathSpecialFolder, sPathAllUsers) Then mColSFolderAllUsers.Add sPathSpecialFolder ' -- Sino otras carpetas ( windows, archivos de programa, ...) Else mColSystemPaths.Add sPathSpecialFolder, sPathSpecialFolder End If End If Next ' -- Errores ------------------------------------------------------------ Exit Sub error_handler: ' -- Error 457 - mismo elemento en la colección( no deberia dar error, pero por las dudas Ignorar) If Err.Number = 457 Then Resume Next Else MsgBox Err.Description, vbCritical, "N° de error: " & CStr(Err.Number) End If End Sub ' ------------------------------------------------------------------------------- '\\ -- Retorna la ruta de las carpetas especiales de windows ' ------------------------------------------------------------------------------- Function GetPath(SpecialFolder As eCSIDL_SPECIAL_FOLDERS) As String Dim lRet As Long Dim IDL As ITEMIDLIST Dim sPath As String ' -- Obtener el ID del path lRet = SHGetSpecialFolderLocation(100, SpecialFolder, IDL) If lRet = 0 Then ' -- Crear Buffer de caracteres para el path sPath$ = Space$(512) ' -- Recuperamos el path desde el ID lRet = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath$) ' -- Eliminr nulos y retornar GetPath = Left$(sPath, InStr(sPath, Chr$(0)) - 1) End If End Function ' --------------------------------------------------------------------------------------- ' \\ -- Propiedad que devuelve la colección de Drives ' --------------------------------------------------------------------------------------- Property Get ColDrives() As Collection Set ColDrives = mColDrives End Property ' ------------------------------------------------------------------------------- '\\ -- Propiedad/Colección - para las Carpetas del usuario actual ' ------------------------------------------------------------------------------- Property Get ColSFolderCurrentUser() As Collection Set ColSFolderCurrentUser = mColSFolderCurrentUser End Property ' ------------------------------------------------------------------------------- '\\ -- Propiedad/Colección - para las Carpetas de todos los usuarios ' ------------------------------------------------------------------------------- Property Get ColSFolderAllUsers() As Collection Set ColSFolderAllUsers = mColSFolderAllUsers End Property ' ------------------------------------------------------------------------------- '\\ -- Propiedad/Colección -- Otras carpetas de windows -- No implementado para listar en el Treeview ' ------------------------------------------------------------------------------- Property Get ColSystemPaths() As Collection Set ColSystemPaths = mColSystemPaths End Property ' --------------------------------------------------------------------------------------- ' \\ -- Evento que se dispara al hacer clic en un nodo ' --------------------------------------------------------------------------------------- Private Sub mTVDrives_NodeClick(ByVal Node As ComctlLib.Node) With Node Screen.MousePointer = vbHourglass ' -- Lanzar evento con la unidad o path RaiseEvent ItemClick(.Key) ' -- guardar path actual mPath = .Key Screen.MousePointer = vbDefault End With End Sub ' --------------------------------------------------------------------------------------- ' \\ -- Propiedades para retornar o establecer el path seleccionado en el Treeview ' --------------------------------------------------------------------------------------- Property Get Path() As String Path = mPath End Property Property Let Path(sPath As String) On Error GoTo error_handler mPath = Trim(UCase(sPath)) With mTVDrives ' -- seleccionar Set .SelectedItem = .Nodes(mPath) ' -- Pasarle el foco ( Opcional ) On Error Resume Next If .Visible Then .SetFocus On Error GoTo 0 End With Exit Property error_handler: MsgBox Err.Description, vbCritical End Property ' ---------------------------------------------------------------------------------------- ' \\ -- FIN ' ---------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------- ' \\ -- No implementado - Para cargar los drives en un nodo ( Nodo Drives) ' y otro nodo las carpetas especiales ' ---------------------------------------------------------------------------------------- 'Property Get LoadMode() As eLoadMode ' LoadMode = mLoadMode 'End Property 'Property Let LoadMode(lValue As eLoadMode) ' mLoadMode = lValue 'End Property ' ---------------------------------------------------------------------------------------- ' \\ -- FIN ' ---------------------------------------------------------------------------------------- ' ---------------------------------------------------------------------------------------- ' ----------------------------------------------------------------------------------------

Enlaces relacionados

Buscar en Recursos vb