** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Access y VBA
  Mensajes nuevos Mensajes nuevos RSS - Renombrar varios ficheros de una carpeta
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoRenombrar varios ficheros de una carpeta

 Responder Responder
Autor
Mensaje
mdominguez Ver desplegable
Habitual
Habitual
Avatar

Unido: 25/Junio/2010
Localización: España
Estado: Sin conexión
Puntos: 112
Enlace directo a este mensaje Tema: Renombrar varios ficheros de una carpeta
    Enviado: 21/Mayo/2020 a las 00:03
Buenas tardes:

Estoy creando una función que renombre los ficheros de una carpeta, con un criterio que le envío (número de registro).


Function Renombra_FicherO(RutApltlL, RegistrO)    
Dim carpeta As Object, FSO As Object
Dim StrArchivo As String
Dim ExtensioN
Dim Wexped, f1
Dim CuantoS

'busco cuantos archivos hay en la ruta que comienzan por el registro
CuantoS = BuscaArchivo(RutApltlL, RegistrO)  '
 
RutApltlL = RutApltlL & "\" ' le añado "\" a la ruta porque si no strArchivo me devuelve ""
 
Set FSO = CreateObject("Scripting.FileSystemObject")
Set carpeta = FSO.GetFolder(RutApltlL)
StrArchivo = Dir(RutApltlL, 0) 'hasta aquí todo bien  de aquí en adelante no hace dada.
For Each f1 In carpeta.Files
    Do Until StrArchivo <> vbNullString
        Wexped = RegistrO & "-" & Format(CuantoS, "000") & Mid(StrArchivo, ".")
        Name RutApltlL & StrArchivo As RutApltlL & Wexped
        StrArchivo = Dir
        CuantoS = CuantoS + 1 ' subo el contador.
    Loop
Next
Set FSO = Nothing
Set carpeta = Nothing

End Function



Public Function BuscaArchivo(RutA, EmpiezaPor) As Integer
    Dim ObjetoFSO As Object
    Dim carpeta As Object
    Dim archivos As Object
    Dim ArchivO As Object
    Dim CuantosHay As Integer
    
    Set ObjetoFSO = CreateObject("Scripting.FileSystemObject")
    Set carpeta = ObjetoFSO.GetFolder(RutA)
    Set archivos = carpeta.Files
    CuantosHay = 1
    For Each ArchivO In archivos
        'Buscamos en los archivos de la carpeta
        If Left(ArchivO.Name, Len(EmpiezaPor)) = EmpiezaPor Then
            CuantosHay = CuantosHay + 1
        End If
    Next
    BuscaArchivo = CuantosHay
    Set archivos = Nothing
    Set carpeta = Nothing
    Set ObjetoFSO = Nothing
 End Function


hasta la línea    StrArchivo = Dir(RutApltlL, 0) funciona, porque me devuelve el nombre del fichero, pero no consigo que me renombre el archivo.

¿Que código me falta o sobra?

Gracias.






Editado por mdominguez - 21/Mayo/2020 a las 00:07
Arriba
mounir Ver desplegable
Colaborador
Colaborador


Unido: 09/Febrero/2009
Localización: Asturias-España
Estado: Sin conexión
Puntos: 6479
Enlace directo a este mensaje Enviado: 21/Mayo/2020 a las 00:28
Hola!

Sin analizar tu código, tienes la Instrucción Name que podría servirte.

Un Saludo.
Arriba
xavi Ver desplegable
Administrador
Administrador
Avatar
Terrassa-BCN

Unido: 10/Mayo/2005
Localización: Catalunya ||||
Estado: Sin conexión
Puntos: 14720
Enlace directo a este mensaje Enviado: 21/Mayo/2020 a las 00:46
Hola

Me temo que estas "redundando" el código. Si recorres la colección Files, ¿porque preguntar por los ficheros?

Te presento una alternativa. La única duda es la linea que genera el Wexped. ¿Que es Mid(strArchivo, ".")? Como he asumido que querías pasarle la extensión, lo he cambiado

Function Renombra_FicherO(RutApltlL As String, RegistrO As String)

Dim FSO     As Object       ' As Scripting.FileSystemObject
Dim Carpeta As Object       ' As Folder
Dim Wexped  As String
Dim f1      As Object       ' As File
Dim CuantoS As Integer

CuantoS = BuscaArchivo(RutApltlL, RegistrO)

Set FSO = CreateObject("Scripting.FileSystemObject")
Set Carpeta = FSO.GetFolder(RutApltlL)
For Each f1 In Carpeta.Files
    If Left(f1.Name, Len(RegistrO)) = RegistrO Then
        Wexped = RegistrO & "-" & Format(CuantoS, "000") & "." & FSO.GetExtensionName(f1.Path)
        Name f1.Path As Replace(f1.Path, f1.Name, Wexped)
    End If
Next
Set FSO = Nothing
Set Carpeta = Nothing

End Function

Escrito al vuelo

Xavi, un minyó de Terrassa

Mi web
Arriba
mdominguez Ver desplegable
Habitual
Habitual
Avatar

Unido: 25/Junio/2010
Localización: España
Estado: Sin conexión
Puntos: 112
Enlace directo a este mensaje Enviado: 21/Mayo/2020 a las 09:28


Buenos días:

Xavi, me he permitido adaptar la función corregida porque no me funcionaba.

Function Renombra_FicherO(RutApltlL As String, RegistrO As String)

Dim FSO     As Object       ' As Scripting.FileSystemObject
Dim carpeta As Object       ' As Folder
Dim Wexped  As String
Dim f1      As Object       ' As File
Dim cuantos As Integer

    cuantos = BuscaArchivo(RutApltlL, RegistrO)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set carpeta = FSO.GetFolder(RutApltlL)
    For Each f1 In carpeta.Files
        Wexped = RutApltlL & "\" & RegistrO & "-" & Format(cuantos, "000") & "." & FSO.GetExtensionName(f1.Path)
        Name f1.Path As Wexped
        cuantos = cuantos + 1
    Next

Set FSO = Nothing
Set carpeta = Nothing

End Function

efectivamente Mid(StrArchivo, ".") es un apaño que tengo para averiguar la extensión de un archivo.

La función, tal como está, funciona, pero siempre hay un peeeero,
y ese pero no es otro que en ocasiones el fichero origen
tiene un carácter "raro" como por ejemplo 'veh├¡culo', y cuando llega ese fichero
deja de hacer su trabajo la función.


Tengo una función de Texto_raro pero no se como poner añadir el caracter ascii 195

Public Function TextO_RarO(OriginalText As String) As String
   
    Const Str1 = "á¡éíóúýàèìòùâêîôûäëïöüÿñºªÁÉÍÓÚÝÀÈÌÒÙÂÊÎÔÛÄËÏÖÜÑ¡¿çÇ"
   
    Const Str2 = "a_eiouyaeiouaeiouaeiouyn..AEIOUYAEIOUAEIOUAEIOUN!?cC"
   
    Const StrElse = "_"
     
    Dim i As Integer, NewText As String, c As String * 1
    Dim Pos As Integer
 
    For i = 1 To Len(OriginalText) 
        c = Mid(OriginalText, i, 1)
        Pos = InStr(1, Str1, c)     
        If Pos > 0 Then             
            NewText = NewText & Mid(Str2, Pos, 1)   
        ElseIf Asc(c) > 128 Then   
            NewText = NewText & StrElse         
        Else
            NewText = NewText & c   '
        End If
    Next
    TextO_RarO = NewText     
 
End Function





Editado por mdominguez - 21/Mayo/2020 a las 09:40
Arriba
xavi Ver desplegable
Administrador
Administrador
Avatar
Terrassa-BCN

Unido: 10/Mayo/2005
Localización: Catalunya ||||
Estado: Sin conexión
Puntos: 14720
Enlace directo a este mensaje Enviado: 21/Mayo/2020 a las 09:51
Pregunta: ¿ese carácter extraño debe ser sustituido o bastaría con ser obviado?

veh├¡culo --> vehículo o vehculo

Si puede ser obviado, yo utilizaría una función para dejar solo letras/numeros

Function LimpiaTexto(strTexto As String) As String
    Dim l               As Long
    Dim strTmp          As String
    Dim strTextoLimpio  As String
    
    strTextoLimpio = ""
    For l = 1 To Len(strTexto)
        strTmp = Mid(strTexto, l, 1)
        Select Case Asc(strTmp)
            Case 48 To 57, 65 To 90, 97 To 122
                strTextoLimpio = strTextoLimpio & strTmp
            Case Else
        End Select
    Next
    LimpiaTexto = strTextoLimpio
End Function

Combinando ambas funciones obtendrías el cambio de acentos y raros con TextO_RarO y la limpieza de los MUY RARO con LimpiaTexto


Xavi, un minyó de Terrassa

Mi web
Arriba
mdominguez Ver desplegable
Habitual
Habitual
Avatar

Unido: 25/Junio/2010
Localización: España
Estado: Sin conexión
Puntos: 112
Enlace directo a este mensaje Enviado: 26/Mayo/2020 a las 22:43
Buenas noches 

Xavi.

He estado ausente unos días, muchas gracias.

Ya está solucionado.

Se puede cerrar el hilo.

Saludos
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable