Attribute VB_Name = "modRenombrarPDFs" Option Explicit ' ===================================================================== ' modRenombrarPDFs - Dar nombre a una carpeta de PDF numerados ' ' QUE HACE ' Tienes una carpeta con PDF numerados ("pagina-1.pdf", "pagina-2.pdf"... ' por ejemplo el resultado de dividir un documento grande) y una hoja ' con dos columnas (codigo + nombre, numero + concepto...) en el mismo ' orden. La macro copia cada PDF a una carpeta nueva con el nombre ' formado por esas dos columnas y deja un archivo correspondencia.tsv ' (pagina -> fila -> archivo). COPIA, nunca mueve: los originales quedan ' intactos. Antes de copiar comprueba que no falta ninguna pagina, que ' ningun nombre se repite y que cada PDF esta completo. ' ' COMO USARLA ' 1. Importa modUtilidades.bas y este modulo (Alt+F11 > Importar). ' 2. Ejecuta RecuperarPDFsPorNombre (Alt+F8). Sin configuracion, la ' macro pregunta con dialogos: carpeta de PDF, numero esperado de ' paginas, rango de 2 columnas y carpeta de destino. ' 3. Para no preguntar nada (lotes repetidos), hoja "Config": ' CarpetaOrigenPDF C:\Escaneos\paginas ' PaginasEsperadas 25 ' RangoDatos Nombres!A2:B26 (2 columnas, sin cabecera) ' CarpetaDestinoPDF C:\Escaneos ' PrefijoPDF pagina- (vacio = "pagina-") ' ' PARA ADAPTARLA (busca ">> ADAPTAR") ' - Otro patron de nombre de origen (p. ej. "escaneo_001.pdf"). ' - Tres columnas en el nombre, o un separador distinto del espacio. ' - Mover en lugar de copiar (no recomendado sin copia de seguridad). ' Requiere: modUtilidades. ' ===================================================================== Private mEnCurso As Boolean Public Sub RecuperarPDFsPorNombre() Dim fso As Object, patron As Object, m As Object, archivos As Object, archivo As Object, nombresVistos As Object Dim seleccion As Range, datos As Variant, nombres() As String Dim origen As String, baseDestino As String, destino As String, ruta As String, errorTexto As String, respuesta As String Dim total As Long, esperado As Long, numero As Long, p As Long, copiados As Long Dim registro As Object, est As EstadoExcel, completo As Boolean If mEnCurso Then Exit Sub mEnCurso = True On Error GoTo Fallo Set fso = CreateObject("Scripting.FileSystemObject") ' Si la hoja Config tiene CarpetaOrigenPDF, RangoDatos y CarpetaDestinoPDF no se pregunta nada. origen = LeerConfig("CarpetaOrigenPDF", False) If Len(origen) = 0 Then origen = ElegirCarpeta("Selecciona la carpeta con los PDF numerados") If Len(origen) = 0 Then GoTo Salida ' 1) Inventario de N.pdf ' >> ADAPTAR: el patron del nombre de origen. Por defecto "pagina-1.pdf", "pagina-2.pdf"... ' El prefijo se puede cambiar en Config (PrefijoPDF). Para otro esquema cambia la ' expresion regular: p. ej. "^escaneo_0*([0-9]{1,7})\.pdf$" admite "escaneo_001.pdf". Set patron = CreateObject("VBScript.RegExp") patron.Pattern = "^" & EscaparRegExp(LeerConfig("PrefijoPDF", False, "pagina-")) & "0*([0-9]{1,7})\.pdf$" patron.IgnoreCase = True Set archivos = CreateObject("Scripting.Dictionary") For Each archivo In fso.GetFolder(origen).Files Set m = patron.Execute(archivo.Name) If m.Count > 0 Then numero = CLng(m(0).SubMatches(0)) If numero < 1 Then Err.Raise vbObjectError + 201, , "Numero de pagina no valido: " & archivo.Name If archivos.Exists(numero) Then Err.Raise vbObjectError + 202, , "Dos archivos con el numero " & numero archivos.Add numero, archivo.Path If numero > total Then total = numero ElseIf LCase$(fso.GetExtensionName(archivo.Name)) = "pdf" Then Err.Raise vbObjectError + 203, , "PDF con nombre inesperado: " & archivo.Name & ". Deja en la carpeta solo los PDF numerados." End If Next archivo If total = 0 Then Err.Raise vbObjectError + 204, , "No se encontraron archivos pagina-N.pdf." For p = 1 To total If Not archivos.Exists(p) Then Err.Raise vbObjectError + 205, , "Falta la pagina " & p & ". No se ha copiado nada." Next p ' 2) Confirmar el numero esperado (antes era una constante fija) respuesta = LeerConfig("PaginasEsperadas", False) If Len(respuesta) = 0 Then respuesta = InputBox("Se han encontrado " & total & " PDF numerados del 1 al " & total & "." & vbCrLf & _ "Escribe el numero de paginas que esperas para confirmar:", "Confirmar paginas", CStr(total)) If Len(respuesta) = 0 Then GoTo Salida If Not IsNumeric(respuesta) Then Err.Raise vbObjectError + 216, , "Numero no valido." esperado = CLng(respuesta) If esperado <> total Then Err.Raise vbObjectError + 216, , "Esperabas " & esperado & " y hay " & total & ". Revisa la carpeta." ' 3) Rango del Excel ORIGINAL (el usuario lo elige; nunca se toma el libro activo a ciegas) On Error Resume Next If Len(LeerConfig("RangoDatos", False)) > 0 Then Set seleccion = ThisWorkbook.Worksheets(Split(LeerConfig("RangoDatos", False), "!")(0)).Range(Split(LeerConfig("RangoDatos", False), "!")(1)) Else Set seleccion = Application.InputBox( _ Prompt:="Selecciona A2:B" & total + 1 & " con los datos, en el mismo orden que los PDF.", _ Title:="Datos para nombrar los PDF", Type:=8) End If On Error GoTo Fallo If seleccion Is Nothing Then GoTo Salida If seleccion.Areas.Count <> 1 Or seleccion.Columns.Count <> 2 Or seleccion.Rows.Count <> total Then Err.Raise vbObjectError + 206, , "Selecciona exactamente " & total & " filas y 2 columnas, sin cabeceras." End If datos = seleccion.Value ReDim nombres(1 To total) Set nombresVistos = CreateObject("Scripting.Dictionary") nombresVistos.CompareMode = vbTextCompare baseDestino = LeerConfig("CarpetaDestinoPDF", False) If Len(baseDestino) = 0 Then baseDestino = ElegirCarpeta("Elige donde crear la carpeta de PDF recuperados") If Len(baseDestino) = 0 Then GoTo Salida destino = fso.BuildPath(baseDestino, "Recuperados_" & Format$(Now, "yyyymmdd_hhnnss")) For p = 1 To total If IsError(datos(p, 1)) Or IsError(datos(p, 2)) Then Err.Raise vbObjectError + 207, , "Error de Excel en la fila " & p + 1 If Len(Trim$(CStr(datos(p, 1)))) = 0 Or Len(Trim$(CStr(datos(p, 2)))) = 0 Then Err.Raise vbObjectError + 208, , "Celda vacia en la fila " & p + 1 ' >> ADAPTAR: el nombre final. NombreArchivoSeguro une las partes con un espacio y ' quita los caracteres no validos. Para tres columnas, selecciona 3 columnas ' (cambia el "Columns.Count <> 2" de arriba) y pasa datos(p, 3) como tercera parte. ' Para un separador distinto: NombreArchivoSeguro("pdf", datos(p, 1) & "_" & datos(p, 2)) nombres(p) = NombreArchivoSeguro("pdf", datos(p, 1), datos(p, 2)) If nombresVistos.Exists(nombres(p)) Then Err.Raise vbObjectError + 209, , "Nombre repetido en filas " & nombresVistos(nombres(p)) & " y " & p + 1 & ": " & nombres(p) End If nombresVistos.Add nombres(p), p + 1 If Len(fso.BuildPath(destino, nombres(p))) > 240 Then Err.Raise vbObjectError + 210, , "Ruta demasiado larga para: " & nombres(p) ComprobarPDF CStr(archivos(p)) Next p p = 0 If Not Confirmar("Se copiaran " & total & " PDF conservando los originales." & vbCrLf & vbCrLf & _ "Pagina 1 -> " & Left$(nombres(1), 90) & vbCrLf & _ "Pagina " & (total + 1) \ 2 & " -> " & Left$(nombres((total + 1) \ 2), 90) & vbCrLf & _ "Pagina " & total & " -> " & Left$(nombres(total), 90) & vbCrLf & vbCrLf & _ "Confirma que las muestras corresponden a esos PDF.", "Comprobar") Then GoTo Salida GuardarEstado est fso.CreateFolder destino Set registro = fso.CreateTextFile(fso.BuildPath(destino, "correspondencia.tsv"), False, True) registro.WriteLine "Pagina" & vbTab & "FilaExcel" & vbTab & "Original" & vbTab & "Nombrado" For p = 1 To total ruta = fso.BuildPath(destino, nombres(p)) ' >> ADAPTAR: se COPIA para conservar los originales. Si de verdad quieres moverlos, ' sustituye por fso.MoveFile y quita la comprobacion de tamano de la linea siguiente. fso.CopyFile CStr(archivos(p)), ruta, False If fso.GetFile(ruta).Size <> fso.GetFile(CStr(archivos(p))).Size Then Err.Raise vbObjectError + 211, , "La copia tiene un tamano distinto al original." copiados = copiados + 1 registro.WriteLine p & vbTab & p + 1 & vbTab & CStr(archivos(p)) & vbTab & ruta Progreso "PDF recuperados", p, total Next p completo = True GoTo Salida Fallo: errorTexto = "Error " & Err.Number & ": " & Err.Description If p >= 1 And p <= total Then errorTexto = errorTexto & vbCrLf & "Pagina " & p & " (fila " & p + 1 & " de la hoja)." Salida: On Error Resume Next If Not registro Is Nothing Then registro.Close RestaurarEstado est On Error GoTo 0 mEnCurso = False If completo Then Aviso copiados & " PDF copiados con su nombre en:" & vbCrLf & destino, vbInformation ElseIf Len(errorTexto) > 0 Then Aviso errorTexto & vbCrLf & "Copias completadas: " & copiados & vbCrLf & "Los originales no se han tocado.", vbExclamation End If End Sub ' Escapa los caracteres especiales de una expresion regular ("." "-" "(" ...). Private Function EscaparRegExp(ByVal s As String) As String Dim c As Variant For Each c In Array("\", ".", "+", "*", "?", "^", "$", "(", ")", "[", "]", "{", "}", "|", "-") s = Replace(s, CStr(c), "\" & CStr(c)) Next c EscaparRegExp = s End Function