domingo, 1 de mayo de 2011

VBA: cómo generar una carpeta o directorio

Tiempo atrás me llegó una consulta de un usuario donde me pedía que comprobara un código en VBA cuya finalidad era crear una carpeta:

...Tenemos un código para crear una carpeta si no existe y da error. La verdad que es la primera vez que me enfrento a esto porque el error que da no tiene sentido:
Set DIRECTORIO_COMPLETO = CreateObject("Scripting.FileSystemObject")
If Not DIRECTORIO_COMPLETO.FolderExists(RUTA_COMPLETA) Then
DIRECTORIO_COMPLETO.CreateFolder (RUTA_COMPLETA)
End If
El error lo da el create folder ya que dice que no puede encontrar la ruta. Sin embargo la ruta existe (Excepto el final)
La RUTA_COMPLETA es algo asi como 'C:\PEDRO\15254\' Existe C:\PEDRO y debería crear 15254.
¿Está mal el código? (Es que en otras versiones si funcina, grrrr)...


Existen varias formas de crear carpetas/directorios e incluso archivos, una es la que planteaba el lector; sin embargo yo voy a explicar una distinta que genera menos errores. Se trata de emplear la función VBA Dir y la instrucción MkDir.
Plantearé un ejemplo sencillo con una macro donde hemos definido las variables necsarias, tales como la ruta o Path donde crear el directorio y el nombre que asignaremos a la carpeta o NombreCarpeta:


Nuestro código VBA a incluir en un módulo del Explorador del proyecto dentro del Editor de VBA es:

Sub GenerarCarpeta()
Dim Path As String, NombreCarpeta As String

Path = "C:\"
NombreCarpeta = "Archivos\Nueva"
'Verificamos si la carpeta existe ya...
If Dir(Path, vbDirectory) <> "" Then
'Comprueba que la carpeta no existe para crearla.
If Dir(Path & NombreCarpeta, vbDirectory) = "" Then MkDir Path & NombreCarpeta
'MkDir se emplea para crear un directorio/carpeta.
'Si no se especifica la unidad de disco, el directorio/carpeta se crea en la unidad actual.
End If

End Sub


Si ejecutamos dicha macro 'GenerarCarpeta comprobaremos como se crea dicho directorio en la ruta definida, así como el subdirectorio; igualmente si ya estuviera generado el primer nivel de directorio (que he llamado 'Archivos') añade el subdirectorio correspondiente.

9 comentarios:

  1. Hola soy nuevo en esto de compartir información en un blog desde ya mis disculpas si no soy lo suficientemente prolijo.
    Me quedé con la creación de una carpeta y encontré que una posible dificultad que habría sería que si el usuario tuviera la unidad del sistema con otra letra diferente a la “C” adiós al código, nos daría un error.
    Pense en subsanarlo mediante una verificación previa de cuáles son las letras asignadas a las unidades lógicas usando algunas funciones de Windows.

    Una de ellas es la función GetLogicalDriveStrings

    Declare Function GetLogicalDriveStrings Lib "Kernel32" Alias "GetLogicalDriveStringsA" _
    (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

    Public Sub ObtenerUnidadesLogicas()
    Dim Texto As String
    Dim Longitud As Long
    Dim CadenaResultante As Long
    Dim i As Integer
    'Inicializamos las variables
    Texto = String(255, 0) 'Generamos una cadena de 255 caracteres de valor nulo
    Longitud = Len(Texto)
    CadenaResultante = GetLogicalDriveStrings(Longitud, Texto)
    'CadenaResultante = Devuelve el numero de caracteres no vacíos. Cero en caso de error.

    Texto = Left(Texto, CadenaResultante) 'Truncamos la cadena al valor de CadenaResultante eliminando así los caracteres vacíos a la derecha de texto
    Debug.Print Texto
    For i = 1 To CadenaResultante Step 4
    Debug.Print Mid(Texto, i, 3)
    Next i

    End Sub

    Otra posible solución sería preguntarle a Windows cuál es su directorio, el cual ya tendría asignada la letra correspondiente.

    Declare Function GetWindowsDirectory Lib "Kernel32" Alias "GetWindowsDirectoryA" _
    (ByVal f As String, ByVal fLen As Long) As Long

    Sub DirectorioWindows()
    Dim DirWin As String
    Dim TamañoDevuelto As Long

    'Generamos una cadena de 255 caracteres de valor nulo para que la función
    deposite el valor del directorio de windows
    DirWin = String(255, 0)

    'Llamado a la función GetWindowsDirectory para obtener información del directorio.
    'TamañoDevuelto=longitud de la cadena devuelta por la DLL
    'DirWin=cadena con el directorio de windows

    TamañoDevuelto = GetWindowsDirectory(DirWin, Len(DirWin))

    'Ajustamos la cadena al tamaño devuelto
    DirWin = Left(DirWin, TamañoDevuelto)
    Debug.Print DirWin
    End Sub

    La función retornará: >> C:\WINDOWS
    Recortamos la cadena y ya está.

    ResponderEliminar
  2. Muchas gracias Ricardo por compartirlo...
    desde luego todas las colaboraciones son bienvenidas... por mi parte lo revisaré y aprenderé todo lo que pueda de tu código.
    Un saludo

    ResponderEliminar
  3. hola, he tratado de hacer que esta macro aparte de crear una carpeta con el nombre de la celda especificada, me genere un hipervinculo al interior de la carpeta creada. no se que poner en address...

    Sub Crear_carpetas()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    ruta = "C:\Documents and Settings\rodrigo.sims\Escritorio\Ficha Proveedor\Base Datos (Hipervinculos)\Proveedores"
    Range("A10").Select

    If Not fso.FolderExists(ruta & "\" & ActiveCell.Value) Then
    fso.CreateFolder (ruta & "\" & ActiveCell.Value)
    End If

    ActiveSheet.Hyperlinks.Add _
    Anchor:=Range("B10"), _
    Address:="C:\Documents and Settings\rodrigo.sims\Escritorio\Ficha Proveedor\Base Datos (Hipervinculos)\Proveedores\", _
    TextToDisplay:="Documentos del Proveedor", _
    ScreenTip:="Enlace a Carpeta Proveedor"

    Set fso = Nothing

    Application.ScreenUpdating = True
    End Sub


    ojala me puedan ayudar me tiene super complicado esto, saludos

    ResponderEliminar
    Respuestas
    1. Hola Rodrigo,
      he probado tu código, con una ruta de mi PC un poco más corta, y funciona perfectamente tal cual lo tienes, lo único que en el cósdigo del Hyperlink el Anchor lo he diridgido a la misma celda activa desde la que has creado la carpeta, esto es
      Anchor:=Range("A10")
      lo demás lo veo bien y además funciona...
      ¿que es lo que te falla???
      Slds

      Eliminar
    2. Gracias por la respuesta bajo el Procedimiento o macro GenerarCarpeta(), el procedimiento es corto y sustancioso y funciona perfectly, la unica duda es porque cierras con un solo End if si existen 2 If's abiertos
      Gracias
      Arthur

      Eliminar
    3. Hola Arthur,
      efectivamente hay dos IF, pero uno de ellos está completo en una misma linea, es decir,
      IF.. THEN ... ELSE
      sólo se requiere un END IF cuando lo partes, por motivos varios, en varias líneas
      IF ... THEN
      código
      código
      [ELSE
      código X]
      END IF

      Dependiendo de qué necesitemos incorporar al condicional interesa una forma u otra.
      Un saludo!!

      Eliminar
  4. Me pueden apoyar con este codigo, el cual me marca un error de "Error 70, Permiso Denegador"
    le muestro el codigo a continuacion

    Private Sub CommandButton2_Click()
    Dim objFSO
    Dim objTF
    Dim i As Integer
    Dim Nombre, Archivo As String
    Nombre = InputBox("Ingrese Nombre del Archivo a Generar")
    Set objFSO = CreateObject("scripting.filesystemobject")
    ' 'create a txt file
    Set objTF = objFSO.CreateTextFile("F:\" & Nombre & ".txt", True)

    Open "F:\" & Nombre & ".txt" For Output As #1
    For i = 0 To ListBox1.ListCount
    Print #1, ListBox1.List(i)
    Next i
    Close #1
    End Sub

    Y revice la seguridad del archivo y no tiene ningun problema para abrirlo manual, pero al querer abrirlo por el codigo no me deja, me aparece el error de permiso denegado.

    Gracias cualquier aporte es bien venido
    saludos a todos.

    ResponderEliminar
    Respuestas
    1. Amigos solucionado, solo me falta cerrar el objeto de creacion
      abajo de la linea "Set ObjTF= objFSO.CreateTextFile("F:\" & Nombre & ".txt", True)
      "
      falta esta linea
      objTF.close
      Y lsisto

      Eliminar