Apagada docs

Renames a zipped abies database to abies-date.zip and unzips it on outputdir.

renombra_backup.cmd

set outputdir=D:\abies_backup\generador_listas
 
if %1.==-t1. goto :2
if %1.==-t2. goto :3
pause
set filetime=
if exist Abies20.bak for %%a in (abies20.bak) do call %0 -t1 %%~ta
set filetime=
if exist Abies20.zip for %%a in (abies20.zip) do call %0 -t2 %%~ta
goto :9999
 
 
 
:2
set filetime=%2
set %filetime:~6,4%-%filetime:~3,2%-%filetime:~0,2%
if exist abies20-%filetime%.zip del abies20-%filetime%.zip
ren abies20.bak abies20-%filetime%.zip
goto 9999
 
:3
set filetime=%2
set filetime=%filetime:~6,4%-%filetime:~3,2%-%filetime:~0,2%
copy abies20.zip abies20-%filetime%.zip
ECHO EXPANDIENDO EL ARCHIVO
cscript unzip.vbs Abies20.zip %outputdir%
 
goto 9999
 
:9999

name=unzip.vbs

'Modified from something I saw on the net.
 
Sub UnZip(ExtractTo,ZipFile)
WScript.echo "Entering Unzip ("& ExtractTo &","& ZipFile &")"
Set fso = CreateObject("Scripting.FileSystemObject") 
    If NOT fso.FolderExists(ExtractTo) Then 
       fso.CreateFolder(ExtractTo) 
End If 
 
Set objShell = CreateObject("Shell.Application") 
Set FilesInZip=objShell.NameSpace(ZipFile).items 
 
objShell.NameSpace(ExtractTo).CopyHere(FilesInZip) 
Set fso = Nothing 
Set objShell = Nothing 
End Sub
 
'Add current directory to route if needed.
'This is vital to get a valid filename we can use with nameSpace function.
Function DefaultDir (FileOrRoute , DefaultRoute )
Dim DD
	'Si el archivo contiene ":", tenemos la ruta completa.
	if instr(FileOrRoute,":")>0 then
		DefaultDir=FileOrRoute
		exit Function
	end if
	'Si el archivo comienza por "\", necesitamos la unidad
	if left (FileOrRoute,1)="\" then
		DD=Left(DefaultRoute,instr(DefaultRoute,":"))
		if right(DD,1)<>"\" then DD=DD+"\"
		DefaultDir = DD+FileOrRoute 
		exit Function
	end if
	'Caso contrario:
	'Añadir DefaultRoute entero.
	DD=DefaultRoute
	if right(DD,1)<>"\" then DD=DD+"\"
	DefaultDir = DD+FileOrRoute 
 
End Function
 
set WshShell = WScript.CreateObject("WScript.Shell")
strDesktop = WshShell.SpecialFolders("MyDocuments")
strCurrent=WshShell.CurrentDirectory
 
if  (Wscript.arguments.count=2) then
	strZipFile  = Wscript.arguments(0)
	strUnzipped = Wscript.arguments(1)
 
	strZipPath   = 	DefaultDir(strZipFile,strCurrent)
	strUnzipPath = 	DefaultDir(strUnzipped,strCurrent)
 
	UnZip strUnzipPath , strZipPath
else
Wscript.Echo ("Wrong number of arguments: INFILE OUTFILE")
end if

name=creatodo.bas

'PARA QUE ESTE SCRIPT FUNCIONE ES NECESARIO IMPORTAR LA REFERENCIA EXCEL
'  Menú Herramientas>>Referencias>>Microsoft Excel XX Object Library"
'  (xx=cualquier número)
'   Marcar la casilla y pulsar "Aceptar"
'
Dim generadorOKaTodo As Integer
 
Option Compare Database
'Comprueba si el option compare está en text o en database
Sub pruebaCompara()
    If "a" = "A" Then Debug.Print "Option compare text" Else Debug.Print "option compare database"
    Debug.Print "A like a:"; "A" Like "a"
    Debug.Print "A like Á:"; "A" Like "Á"
    Debug.Print "N like Ñ:"; "N" Like "Ñ"
End Sub
 
'Crea una hoja excel de libros por materia.
Sub CreaLibrosPorMateria()
 
    Dim MiRuta As String
 
    Dim xlApp As Excel.Application
    Dim Book As New Excel.Workbook
    Dim MySheet As Excel.Worksheet
    Dim db As Database
    Dim LibrosPorAutor As Object
    Dim existe As Boolean, f As Integer
 
    Set db = Access.CurrentDb
    Set xlApp = CreateObject("Excel.Application")
    Set Book = xlApp.Workbooks.Add
 
    'Libros por materia es una consulta definida como:
    'SELECT Descriptores.cDescriptor, Autores.a, Fondos.Titulo, Fondos.Subtitulo,
    'Editoriales.Editorial, Ejemplares.Sig1, Ejemplares.Sig2, Ejemplares.Sig3,
    'Ubicaciones.Ubicacion, Ejemplares.CodigoEjemplar, [Sig1] & " " & [Sig2]
    '& " " & [Sig3] AS Signatura, Fondos.AnoEdicion, Ejemplares.NumRegistro
    'FROM Descriptores INNER JOIN (((((Autores INNER JOIN Fondos ON
    'Autores.IdAtor=Fondos.IdAutor) INNER JOIN Ejemplares ON
    'Fondos.IdFondo=Ejemplares.IdFondo) INNER JOIN Editoriales ON
    'Fondos.IdEditorial=Editoriales.IdEditorial) INNER JOIN Ubicaciones ON
    'Ejemplares.IdUbicacion=Ubicaciones.IdUbicacion) INNER JOIN Fondos_Descriptores
    'ON Fondos.IdFondo=Fondos_Descriptores.IdFondo) ON
    'Descriptores.IdDescriptor=Fondos_Descriptores.IdDescriptor
    'ORDER BY Descriptores.cDescriptor;
 
    'Si no existe la consulta, la crea:
    creaQueries
 
 
    'La intercalación ("collate") de la base de datos no permite ordenar juntas Á y A a la
    'vez que separar N y Ñ. Por eso hacemos trampa...
    '
 
    Hojas = Array("A", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
                  "N", "Ñ", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
    Filtros = Array("!A-ZÁÂÀÂÃÄÇÉÊÈËÍÎÌÏÑÓÔÒÕÖØÚÛÙÜÝÿ", _
                    "AÁÂÀÂÃÄ", "B", "CÇ", "D", _
                    "EÉÊÈË", "F", "G", "H", "IÍÎÌÏ", _
                    "J", "K", "L", "M", "N", "Ñ", _
                    "OÓÔÒÕÖØ", "P", "Q", "R", "S", "T", _
                    "UÚÛÙÜ", "V", "W", "X", "YÝÿ", "Z")
    If generadorOKaTodo Then
        pregunta = vbNo
    Else
        pregunta = MsgBox( _
            "¿Desea ver la hoja de cálculo según se crea?" & vbCrLf & _
            "(Si elige 'No', verá la hoja cuando ya esté creada)", _
            vbQuestion + vbYesNo, _
            "Ver la hoja según se crea")
    End If
    If pregunta = vbYes Then xlApp.Visible = True
 
    filaact = 3
    For Ifiltro = 0 To UBound(Hojas)
        NombreLast = NombreHoja
        NombreHoja = Hojas(Ifiltro)
        filtro = "[" & Filtros(Ifiltro) & "]*"
        consulta = "SELECT * " & _
            "FROM [Libros por Materia] " & _
            "Where cDescriptor LIKE """ + filtro + "*"" " & _
            "ORDER BY cDescriptor "
 
        Set LibrosporMateria = db.OpenRecordset(consulta, _
            dbOpenDynaset)
 
        If NombreHoja <> NombreLast Then
            Book.Activate
 
            'Excel crea las nuevas hojas ANTES de la anterior.
            'para evitarlo, hay que decirle que añada cada hoja TRAS la anterior,
            'pelo la primera hoja no tiene ninguna "anterior".
 
            If NombreLast = "" Then
                Set MySheet = Book.Sheets.Add
            Else
                Set MySheet = Book.Sheets.Add(After:=Book.Sheets(NombreLast))
            End If
            With MySheet
                .Name = NombreHoja
                With .Range("A:G")
                    .HorizontalAlignment = xlLeft
                    .Font.Size = 10
                    .VerticalAlignment = xlTop
                    .WrapText = True
                End With
                With .Range("1:2")
                .Font.Size = 12
                .VerticalAlignment = xlTop
                .HorizontalAlignment = xlCenter
                End With
                .Cells(1, 1) = "LETRA " & NombreHoja
                .Cells(2, 1) = "Materia"
                .Cells(2, 2) = "Autor"
                .Cells(2, 3) = "Título"
                .Cells(2, 4) = "Editorial"
                .Cells(2, 5) = "Registro"
                .Cells(2, 6) = "Signatura"
                .Cells(2, 7) = "Ubicación"
                'Colorear las hojas con el color que tienen
                'las existentes en Google Spreadsheets
                .Range("A1:G1").Cells.Interior.Color = RGB(&HFF, &HCC, &H99)
                .Range("A1:E1").HorizontalAlignment = xlCenter
                .Range("A1:E1").Merge
                .Range("F1:G1").Cells.HorizontalAlignment = xlRight
                .Range("F1:G1").Merge
                .Range("A2:G2").Cells.Interior.Color = RGB(&HC0, &HC0, &HC0)
                .Cells(1, 6) = "" & Now()
                'Ancho para las columnas:
                '200,200,200,80,130 píxeles
                'Problema:Excel usa CM y no pixeles como Google Spreadsheet.
                .Columns(1).ColumnWidth = 20
                .Columns(2).ColumnWidth = 20
                .Columns(3).ColumnWidth = 20
                .Columns(4).ColumnWidth = 20
                .Columns(5).ColumnWidth = 8
                .Columns(6).ColumnWidth = 13
                .Columns(7).ColumnWidth = 13
                filaact = 3
                .Application.ActiveWindow.SplitRow = 2
                .Application.ActiveWindow.FreezePanes = True
 
            End With
        End If
        Debug.Print "----- HOJA: " & NombreHoja & " -----"
        While Not LibrosporMateria.EOF
                        mat$ = LibrosporMateria.Fields("cDescriptor")
            If mat$ <> mat2$ Then
                Debug.Print Chr$(13); LibrosporMateria.Fields("cDescriptor");
            Else
                Debug.Print ".";
            End If
            With MySheet
                .Cells(filaact, 1) = LibrosporMateria.Fields("cDescriptor")
                .Cells(filaact, 2) = LibrosporMateria.Fields("a")
                .Cells(filaact, 3) = LibrosporMateria.Fields("Titulo")
                .Cells(filaact, 4) = LibrosporMateria.Fields("Editorial")
                .Cells(filaact, 5) = LibrosporMateria.Fields("NumRegistro")
                .Cells(filaact, 6) = LibrosporMateria.Fields("Signatura")
                .Cells(filaact, 7) = LibrosporMateria.Fields("Ubicacion")
            End With
            filaact = filaact + 1
            LibrosporMateria.MoveNext
         Wend
         LibrosporMateria.Close
    Next
    'Borrar las hojas hoja1, hoja2, hoja3
      f = 1
    While f <= Book.Sheets.Count
        If Left(Book.Sheets(f).Name, 4) = "Hoja" Then
            Book.Sheets(f).Delete
        Else
            f = f + 1
        End If
    Wend
 
    On Error GoTo Errorgrabando
 
    MiRuta = (Environ$("Userprofile") + "\" + "Libros por Materia.xls")
    If generadorOKaTodo Then
        'Stop
        If ArchivoUnico(MiRuta) Then
            Kill MiRuta
        End If
        Book.SaveAs MiRuta, ConflictResolution:=xlLocalSessionChanges
    Else
        Book.SaveAs MiRuta, ConflictResolution:=xlUserResolution
    End If
 
    On Error GoTo 0
    If generadorOKaTodo Then
        response = vbYes
    Else
        response = MsgBox("¿Cerrar la hoja de Cálculo?", vbYesNo Or vbExclamation, "Confirme operación")
    End If
    If response = vbNo Then
        xlApp.Visible = True
        Book.Activate
    Else
        Book.Close
    End If
 
 
'Sale de la SUB
Final:
    Exit Sub
 
'Maneja un posible error si hemos cerrado la hoja excel antes de tiempo.
Errorgrabando:
    response = MsgBox("Aviso: No se grabó la hoja de cálculo", vbOKCancel Or vbExclamation, "AVISO")
    xlApp.Visible = True
    Book.Activate
    If response = vbCancel Then End
    Resume
 
End Sub
 
'Crea una hoja excel de libros por Autor.
Sub CreaLibrosPorAutor()
    Dim MiRuta As String
    Dim xlApp As Excel.Application
    Dim Book As New Excel.Workbook
    Dim MySheet As Excel.Worksheet
    Dim db As Database
    Dim LibrosPorAutor As Object
    Set db = Access.CurrentDb
    Set xlApp = CreateObject("Excel.Application")
    Set Book = xlApp.Workbooks.Add
 
    'Libros por autor está definido como:
    '
    'SELECT Autores.a, Fondos.Titulo, Fondos.Subtitulo, Editoriales.Editorial, Ejemplares.Sig1, Ejemplares.Sig2,
    ' Ejemplares.Sig3, Ubicaciones.Ubicacion, Ejemplares.CodigoEjemplar,
    ' [Sig1] & " " & [Sig2] & " " & [Sig3] AS Signatura, Fondos.AnoEdicion, Ejemplares.NumRegistro
    ' FROM ((((Autores INNER JOIN Fondos_Autores ON Autores.IdAutor = Fondos_Autores.IdAutor)
    ' INNER JOIN Fondos ON (Fondos_Autores.IdFondo = Fondos.IdFondo)
    ' AND (Autores.IdAutor = Fondos.IdAutor))
    ' INNER JOIN Ejemplares ON Fondos.IdFondo = Ejemplares.IdFondo)
    ' INNER JOIN Editoriales ON Fondos.IdEditorial = Editoriales.IdEditorial)
    ' INNER JOIN Ubicaciones ON Ejemplares.IdUbicacion = Ubicaciones.IdUbicacion;
    '
 
    'Si no existe la consulta, la crea:
    creaQueries
 
    'La intercalación ("collate") de la base de datos no permite ordenar juntas Á y A a la
    'vez que separar N y Ñ. Por eso hacemos trampa...
    '
 
    Hojas = Array("A", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
                  "N", "Ñ", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
    Filtros = Array("!A-ZÁÂÀÂÃÄÇÉÊÈËÍÎÌÏÑÓÔÒÕÖØÚÛÙÜÝÿ", _
                    "AÁÂÀÂÃÄ", "B", "CÇ", "D", _
                    "EÉÊÈË", "F", "G", "H", "IÍÎÌÏ", _
                    "J", "K", "L", "M", "N", "Ñ", _
                    "OÓÔÒÕÖØ", "P", "Q", "R", "S", "T", _
                    "UÚÛÙÜ", "V", "W", "X", "YÝÿ", "Z")
 
    If generadorOKaTodo Then
        pregunta = vbNo
    Else
        pregunta = MsgBox( _
            "¿Desea ver la hoja de cálculo según se crea?" & vbCrLf & _
            "(Si elige 'No', verá la hoja cuando ya esté creada)", _
            vbQuestion + vbYesNo, _
            "Ver la hoja según se crea")
    End If
    If pregunta = vbYes Then xlApp.Visible = True
 
    filaact = 3
    For Ifiltro = 0 To UBound(Hojas)
        NombreLast = NombreHoja
        NombreHoja = Hojas(Ifiltro)
        filtro = "[" & Filtros(Ifiltro) & "]*"
        consulta = "SELECT * " & _
            "FROM [Libros por Autor] " & _
            "Where a LIKE """ + filtro + "*"" " & _
            "ORDER BY a "
 
        Set LibrosPorAutor = db.OpenRecordset(consulta, _
            dbOpenDynaset)
 
        If NombreHoja <> NombreLast Then
 
            Book.Activate
            'Excel crea las nuevas hojas ANTES de la anterior.
            'para evitarlo, hay que decirle que añada cada hoja TRAS la anterior,
            'pelo la primera hoja no tiene ninguna "anterior".
 
            If NombreLast = "" Then
                Set MySheet = Book.Sheets.Add
            Else
                Set MySheet = Book.Sheets.Add(After:=Book.Sheets(NombreLast))
            End If
            With MySheet
                .Name = NombreHoja
                With .Range("A:F")
                    .HorizontalAlignment = xlLeft
                    .Font.Size = 10
                    .VerticalAlignment = xlTop
                    .WrapText = True
                End With
                With .Range("1:2")
                .Font.Size = 12
                .VerticalAlignment = xlTop
                .HorizontalAlignment = xlCenter
                End With
                .Cells(1, 1) = "LETRA " & NombreHoja
                .Cells(2, 1) = "Autor"
                .Cells(2, 2) = "Título"
                .Cells(2, 3) = "Editorial"
                .Cells(2, 4) = "Registro"
                .Cells(2, 5) = "Signatura"
                .Cells(2, 6) = "Ubicacion"
                'Colorear las hojas con el color que tienen
                'las existentes en Google Spreadsheets
                .Range("A1:F1").Cells.Interior.Color = RGB(&HFF, &HCC, &H99)
                .Range("A1:E1").HorizontalAlignment = xlCenter
                .Range("A1:D1").Merge
                .Range("E1:F1").Cells.HorizontalAlignment = xlRight
                .Range("E1:F1").Merge
                .Cells(1, 5) = "" & Now()
                .Range("A2:F2").Cells.Interior.Color = RGB(&HC0, &HC0, &HC0)
                'Ancho para las columnas:
                '200,200,200,80,130 píxeles
                'Problema:Excel usa CM y no pixeles como Google Spreadsheet.
                .Columns(1).ColumnWidth = 20
                .Columns(2).ColumnWidth = 20
                .Columns(3).ColumnWidth = 20
                .Columns(4).ColumnWidth = 8
                .Columns(5).ColumnWidth = 13
                .Columns(6).ColumnWidth = 13
                filaact = 3
                .Application.ActiveWindow.SplitRow = 2
                .Application.ActiveWindow.FreezePanes = True
 
            End With
        End If
        Debug.Print "----- HOJA: " & NombreHoja & " -----"
        While Not LibrosPorAutor.EOF
        aut$ = LibrosPorAutor.Fields("a")
            If aut$ <> aut2$ Then
                Debug.Print Chr$(13); aut$;
            Else
                Debug.Print ".";
            End If
            aut2$ = aut$
 
 
            With MySheet
                .Cells(filaact, 1) = LibrosPorAutor.Fields("a")
                .Cells(filaact, 2) = LibrosPorAutor.Fields("Titulo")
                .Cells(filaact, 3) = LibrosPorAutor.Fields("Editorial")
                .Cells(filaact, 4) = LibrosPorAutor.Fields("NumRegistro")
                .Cells(filaact, 5) = LibrosPorAutor.Fields("Signatura")
                .Cells(filaact, 6) = LibrosPorAutor.Fields("Ubicacion")
            End With
            filaact = filaact + 1
            LibrosPorAutor.MoveNext
         Wend
         LibrosPorAutor.Close
    Next
    'Borrar las hojas hoja1, hoja2, hoja3
     f = 1
    While f < Book.Sheets.Count
        If Left(Book.Sheets(f).Name, 4) = "Hoja" Then
            Book.Sheets(f).Delete
        Else
            f = f + 1
        End If
    Wend
    On Error GoTo Errorgrabando
 
    MiRuta = (Environ$("Userprofile") + "\" + "Libros por Autor.xls")
    If generadorOKaTodo Then
        If ArchivoUnico(MiRuta) Then
            Kill MiRuta
        End If
        Book.SaveAs MiRuta, ConflictResolution:=xlLocalSessionChanges
    Else
        Book.SaveAs MiRuta, ConflictResolution:=xlUserResolution
    End If
 
    'Maneja un posible error grabando la hoja de cálculo
    On Error GoTo 0
    If generadorOKaTodo Then
        response = vbYes
    Else
        response = MsgBox("¿Cerrar la hoja de Cálculo?", vbYesNo Or vbExclamation, "Confirme operación")
    End If
    If response = vbNo Then
        xlApp.Visible = True
        Book.Activate
    Else
        Book.Close
    End If
 
 
'Sale de la SUB
Final:
    Exit Sub
 
'Maneja un posible error si hemos cerrado la hoja excel antes de tiempo.
Errorgrabando:
    response = MsgBox("Aviso: No se grabó la hoja de cálculo", vbOKCancel Or vbExclamation, "AVISO")
    xlApp.Visible = True
    Book.Activate
    If response = vbCancel Then End
    Resume
 
 
End Sub
 
'Crea la hoja excel de libros por autor, la de libros por título y la de libros por materia.
Sub creaTodo()
    refreshAll
    If generadorOKaTodo Then
        pregunta = vbNo
    Else
        pregunta = MsgBox( _
            "¿Desea que el programa le pida confirmaciones?", _
            vbQuestion + vbYesNo, _
            "Elija modo activo o pasivo")
    End If
    If pregunta = vbYes Then generadorOKaTodo = False Else generadorOKaTodo = True
 
    CreaLibrosPorTitulo
    CreaLibrosPorAutor
    CreaLibrosPorMateria
    CreaLibrosPorTituloCanonico
End Sub
'Crea la hoja excel de libros por título.
Sub CreaLibrosPorTitulo()
    Dim MiRuta As String
    Dim xlApp As Excel.Application
    Dim Book As New Excel.Workbook
    Dim MySheet As Excel.Worksheet
    Dim db As Database
    Dim LibrosPorTitulo As Object
    Set db = Access.CurrentDb
    Set xlApp = CreateObject("Excel.Application")
    Set Book = xlApp.Workbooks.Add
 
    'Libros Por Titulo está definido como:
    'SELECT Fondos.Titulo, Fondos.Subtitulo, Editoriales.Editorial, Autores.a, Ejemplares.Sig1, Ejemplares.Sig2, Ejemplares.Sig3, Ubicaciones.Ubicacion, Ejemplares.CodigoEjemplar, [Sig1] & " " & [Sig2] & " " & [Sig3] AS Signatura, Fondos.AnoEdicion, Ejemplares.NumRegistro, InStr([Titulo],[Sig3]) AS Expr1, IIf([Expr1]>1,Mid([Titulo],[Expr1]) & ", " & Left([Titulo],[Expr1]-1),[Titulo]) AS Canonico
    'FROM (((Fondos INNER JOIN Ejemplares ON Fondos.IdFondo = Ejemplares.IdFondo) INNER JOIN Editoriales ON Fondos.IdEditorial = Editoriales.IdEditorial) INNER JOIN Ubicaciones ON Ejemplares.IdUbicacion = Ubicaciones.IdUbicacion) LEFT JOIN Autores ON Fondos.IdAutor = Autores.IdAutor;
 
 
    'Si no existe la consulta, la crea:
    creaQueries
 
    'La intercalación ("collate") de la base de datos no permite ordenar juntas Á y A a la
    'vez que separar N y Ñ. Por eso hacemos trampa...
    '
 
    Hojas = Array("A", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
                  "N", "Ñ", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
    Filtros = Array("!A-ZÁÂÀÂÃÄÇÉÊÈËÍÎÌÏÑÓÔÒÕÖØÚÛÙÜÝÿ", _
                    "AÁÂÀÂÃÄ", "B", "CÇ", "D", _
                    "EÉÊÈË", "F", "G", "H", "IÍÎÌÏ", _
                    "J", "K", "L", "M", "N", "Ñ", _
                    "OÓÔÒÕÖØ", "P", "Q", "R", "S", "T", _
                    "UÚÛÙÜ", "V", "W", "X", "YÝÿ", "Z")
 
    filaact = 3
 
    If generadorOKaTodo Then
        pregunta = vbNo
    Else
        pregunta = MsgBox( _
            "¿Desea ver la hoja de cálculo según se crea?" & vbCrLf & _
            "(Si elige 'No', verá la hoja cuando ya esté creada)", _
            vbQuestion + vbYesNo, _
            "Ver la hoja según se crea")
    End If
    If pregunta = vbYes Then xlApp.Visible = True
 
    For Ifiltro = 0 To UBound(Hojas)
        NombreLast = NombreHoja
        NombreHoja = Hojas(Ifiltro)
        filtro = "[" & Filtros(Ifiltro) & "]*"
        consulta = "SELECT * " & _
            "FROM [Libros por Titulo] " & _
            "Where Titulo LIKE """ + filtro + "*"" " & _
            "ORDER BY Titulo "
 
        Set LibrosPorTitulo = db.OpenRecordset(consulta, _
            2)
 
        If NombreHoja <> NombreLast Then
                Book.Activate
 
            'Excel crea las nuevas hojas ANTES de la anterior.
            'para evitarlo, hay que decirle que añada cada hoja TRAS la anterior,
            'pelo la primera hoja no tiene ninguna "anterior".
 
            If NombreLast = "" Then
                Set MySheet = Book.Sheets.Add
            Else
                Set MySheet = Book.Sheets.Add(After:=Book.Sheets(NombreLast))
            End If
            With MySheet
                .Name = NombreHoja
                With .Range("A:F")
                    .HorizontalAlignment = xlLeft
                    .Font.Size = 10
                    .VerticalAlignment = xlTop
                    .WrapText = True
                End With
                With .Range("1:2")
                .Font.Size = 12
                .VerticalAlignment = xlTop
                .HorizontalAlignment = xlCenter
                End With
                .Cells(1, 1) = "LETRA " & NombreHoja
                .Cells(2, 1) = "Título"
                .Cells(2, 2) = "Autor"
                .Cells(2, 3) = "Editorial"
                .Cells(2, 4) = "Registro"
                .Cells(2, 5) = "Signatura"
                .Cells(2, 6) = "Ubicacion"
                'Colorear las hojas con el color que tienen
                'las existentes en Google Spreadsheets
                .Range("A1:F1").Cells.Interior.Color = RGB(&HFF, &HCC, &H99)
                .Range("A1:F1").HorizontalAlignment = xlCenter
                .Range("A1:D1").Merge
                .Range("E1:F1").Cells.HorizontalAlignment = xlRight
                .Range("E1:F1").Merge
                .Cells(1, 5) = "" & Now()
                .Range("A2:F2").Cells.Interior.Color = RGB(&HC0, &HC0, &HC0)
                'Ancho para las columnas:
                '200,200,200,80,130 píxeles
                'Problema:Excel usa CM y no pixeles como Google Spreadsheet.
                .Columns(1).ColumnWidth = 20
                .Columns(2).ColumnWidth = 20
                .Columns(3).ColumnWidth = 20
                .Columns(4).ColumnWidth = 8
                .Columns(5).ColumnWidth = 13
                .Columns(6).ColumnWidth = 13
                filaact = 3
                .Application.ActiveWindow.SplitRow = 2
                .Application.ActiveWindow.FreezePanes = True
            End With
        End If
        Debug.Print "----- HOJA: " & NombreHoja & " -----"
        While Not LibrosPorTitulo.EOF
            tit$ = LibrosPorTitulo.Fields("Titulo")
            If tit$ <> tit2$ Then
                Debug.Print Chr$(13); tit$;
            Else
                Debug.Print ".";
            End If
            tit2$ = tit$
 
            With MySheet
                .Cells(filaact, 1) = LibrosPorTitulo.Fields("Titulo")
                .Cells(filaact, 2) = LibrosPorTitulo.Fields("a")
                .Cells(filaact, 3) = LibrosPorTitulo.Fields("Editorial")
                .Cells(filaact, 4) = LibrosPorTitulo.Fields("NumRegistro")
                .Cells(filaact, 5) = LibrosPorTitulo.Fields("Signatura")
                .Cells(filaact, 6) = LibrosPorTitulo.Fields("Ubicacion")
            End With
            filaact = filaact + 1
            LibrosPorTitulo.MoveNext
         Wend
         LibrosPorTitulo.Close
    Next
    'Borrar las hojas hoja1, hoja2, hoja3
    f = 1
    While f <= Book.Sheets.Count
        If Left(Book.Sheets(f).Name, 4) = "Hoja" Then
            Book.Sheets(f).Delete
        Else
            f = f + 1
        End If
    Wend
 
    On Error GoTo Errorgrabando
    MiRuta = (Environ$("Userprofile") + "\" + "Libros por Titulo.xls")
    If generadorOKaTodo Then
        If ArchivoUnico(MiRuta) Then
            Kill MiRuta
        End If
        Book.SaveAs MiRuta, ConflictResolution:=xlLocalSessionChanges
    Else
        Book.SaveAs MiRuta, ConflictResolution:=xlUserResolution
    End If
    On Error GoTo 0
    If generadorOKaTodo Then
        response = vbYes
    Else
        response = MsgBox("¿Cerrar la hoja de Cálculo?", vbYesNo Or vbExclamation, "Confirme operación")
    End If
    If response = vbNo Then
        Book.Activate
        xlApp.Visible = True
    Else
        Book.Close
    End If
 
Final:
        Exit Sub
 
Errorgrabando:
    response = MsgBox("Aviso: No se grabó la hoja de cálculo", vbOKCancel Or vbExclamation, "AVISO")
    xlApp.Visible = True
    Book.Activate
    If response = vbCancel Then End
    Resume
 
End Sub
'Crea un listado por título, cambiando "El ingenioso hidalgo" por "Ingenioso Hidalgo, El"
'Esto es posible gracias a que la tercera sección de la signatura suele contener el
'inicio del nombre canónico.
'(Excepto en biografías)
Sub CreaLibrosPorTituloCanonico()
    Dim MiRuta As String
    Dim xlApp As Excel.Application
    Dim Book As New Excel.Workbook
    Dim MySheet As Excel.Worksheet
    Dim db As Database
    Dim LibrosPorTitulo As Object
    Set db = Access.CurrentDb
    Set xlApp = CreateObject("Excel.Application")
    Set Book = xlApp.Workbooks.Add
 
    'Libros Por Titulo está definido como:
    'SELECT Fondos.Titulo, Fondos.Subtitulo, Editoriales.Editorial, Autores.a, Ejemplares.Sig1, Ejemplares.Sig2, Ejemplares.Sig3, Ubicaciones.Ubicacion, Ejemplares.CodigoEjemplar, [Sig1] & " " & [Sig2] & " " & [Sig3] AS Signatura, Fondos.AnoEdicion, Ejemplares.NumRegistro, InStr([Titulo],[Sig3]) AS Expr1, IIf([Expr1]>1,Mid([Titulo],[Expr1]) & ", " & Left([Titulo],[Expr1]-1),[Titulo]) AS Canonico
    'FROM (((Fondos INNER JOIN Ejemplares ON Fondos.IdFondo = Ejemplares.IdFondo) INNER JOIN Editoriales ON Fondos.IdEditorial = Editoriales.IdEditorial) INNER JOIN Ubicaciones ON Ejemplares.IdUbicacion = Ubicaciones.IdUbicacion) LEFT JOIN Autores ON Fondos.IdAutor = Autores.IdAutor;
 
 
    'Si no existe la consulta, la crea:
    creaQueries
 
    'La intercalación ("collate") de la base de datos no permite ordenar juntas Á y A a la
    'vez que separar N y Ñ. Por eso hacemos trampa...
    '
 
    Hojas = Array("A", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
                  "N", "Ñ", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
    Filtros = Array("!A-ZÁÂÀÂÃÄÇÉÊÈËÍÎÌÏÑÓÔÒÕÖØÚÛÙÜÝÿ", _
                    "AÁÂÀÂÃÄ", "B", "CÇ", "D", _
                    "EÉÊÈË", "F", "G", "H", "IÍÎÌÏ", _
                    "J", "K", "L", "M", "N", "Ñ", _
                    "OÓÔÒÕÖØ", "P", "Q", "R", "S", "T", _
                    "UÚÛÙÜ", "V", "W", "X", "YÝÿ", "Z")
 
    filaact = 3
 
    If generadorOKaTodo Then
        pregunta = vbNo
    Else
        pregunta = MsgBox( _
            "¿Desea ver la hoja de cálculo según se crea?" & vbCrLf & _
            "(Si elige 'No', verá la hoja cuando ya esté creada)", _
            vbQuestion + vbYesNo, _
            "Ver la hoja según se crea")
    End If
    If pregunta = vbYes Then xlApp.Visible = True
 
    For Ifiltro = 0 To UBound(Hojas)
        NombreLast = NombreHoja
        NombreHoja = Hojas(Ifiltro)
        filtro = "[" & Filtros(Ifiltro) & "]*"
        consulta = "SELECT * " & _
            "FROM [Libros por Titulo] " & _
            "Where Canonico LIKE """ + filtro + "*"" " & _
            "ORDER BY Canonico "
 
        Set LibrosPorTitulo = db.OpenRecordset(consulta, _
            dbOpenDynaset)
 
        If NombreHoja <> NombreLast Then
                Book.Activate
 
            'Excel crea las nuevas hojas ANTES de la anterior.
            'para evitarlo, hay que decirle que añada cada hoja TRAS la anterior,
            'pelo la primera hoja no tiene ninguna "anterior".
 
            If NombreLast = "" Then
                Set MySheet = Book.Sheets.Add
            Else
                Set MySheet = Book.Sheets.Add(After:=Book.Sheets(NombreLast))
            End If
            With MySheet
                .Name = NombreHoja
                With .Range("A:F")
                    .HorizontalAlignment = xlLeft
                    .Font.Size = 10
                    .VerticalAlignment = xlTop
                    .WrapText = True
                End With
                With .Range("1:2")
                .Font.Size = 12
                .VerticalAlignment = xlTop
                .HorizontalAlignment = xlCenter
                End With
                .Cells(1, 1) = "LETRA " & NombreHoja
                .Cells(2, 1) = "Título"
                .Cells(2, 2) = "Autor"
                .Cells(2, 3) = "Editorial"
                .Cells(2, 4) = "Registro"
                .Cells(2, 5) = "Signatura"
                .Cells(2, 6) = "Ubicacion"
                'Colorear las hojas con el color que tienen
                'las existentes en Google Spreadsheets
                .Range("A1:F1").Cells.Interior.Color = RGB(&HFF, &HCC, &H99)
                .Range("A1:F1").HorizontalAlignment = xlCenter
                .Range("A1:D1").Merge
                .Range("E1:F1").Cells.HorizontalAlignment = xlRight
                .Range("E1:F1").Merge
                .Cells(1, 5) = "" & Now()
                .Range("A2:F2").Cells.Interior.Color = RGB(&HC0, &HC0, &HC0)
                'Ancho para las columnas:
                '200,200,200,80,130 píxeles
                'Problema:Excel usa CM y no pixeles como Google Spreadsheet.
                .Columns(1).ColumnWidth = 20
                .Columns(2).ColumnWidth = 20
                .Columns(3).ColumnWidth = 20
                .Columns(4).ColumnWidth = 8
                .Columns(5).ColumnWidth = 13
                .Columns(6).ColumnWidth = 13
                filaact = 3
                .Application.ActiveWindow.SplitRow = 2
                .Application.ActiveWindow.FreezePanes = True
 
            End With
        End If
        Debug.Print "----- HOJA: " & NombreHoja & " -----"
        While Not LibrosPorTitulo.EOF
            tit$ = LibrosPorTitulo.Fields("Canonico")
            If tit$ <> tit2$ Then
                Debug.Print Chr$(13); tit$;
            Else
                Debug.Print ".";
            End If
            tit2$ = tit$
 
            With MySheet
                .Cells(filaact, 1) = LibrosPorTitulo.Fields("Canonico")
                .Cells(filaact, 2) = LibrosPorTitulo.Fields("a")
                .Cells(filaact, 3) = LibrosPorTitulo.Fields("Editorial")
                .Cells(filaact, 4) = LibrosPorTitulo.Fields("NumRegistro")
                .Cells(filaact, 5) = LibrosPorTitulo.Fields("Signatura")
                .Cells(filaact, 6) = LibrosPorTitulo.Fields("Ubicacion")
            End With
            filaact = filaact + 1
            LibrosPorTitulo.MoveNext
         Wend
         LibrosPorTitulo.Close
    Next
    'Borrar las hojas hoja1, hoja2, hoja3
  f = 1
    While f <= Book.Sheets.Count
        If Left(Book.Sheets(f).Name, 4) = "Hoja" Then
            Book.Sheets(f).Delete
        Else
            f = f + 1
        End If
    Wend
 
    On Error GoTo Errorgrabando
 
    MiRuta = (Environ$("Userprofile") + "\" + "Libros por Titulo Canonico.xls")
    If generadorOKaTodo Then
        If ArchivoUnico(MiRuta) Then
            Kill MiRuta
        End If
        Book.SaveAs MiRuta, ConflictResolution:=xlLocalSessionChanges
    Else
        Book.SaveAs MiRuta, ConflictResolution:=xlUserResolution
    End If
 
    On Error GoTo 0
 
    If generadorOKaTodo Then
        response = vbYes
    Else
        response = MsgBox("¿Cerrar la hoja de Cálculo?", vbYesNo Or vbExclamation, "Confirme operación")
    End If
    If response = vbNo Then
        Book.Activate
        xlApp.Visible = True
    Else
        Book.Close
    End If
 
Final:
        Exit Sub
 
Errorgrabando:
    response = MsgBox("Aviso: No se grabó la hoja de cálculo", vbOKCancel Or vbExclamation, "AVISO")
    xlApp.Visible = True
    Book.Activate
    If response = vbCancel Then End
    Resume
 
End Sub
 
'Crea las consultas libros por materia y libros por autor, en caso de que
'no existan en la base de datos
Sub creaQueries()
    Dim existeLPA As Boolean, existeLPM As Boolean, existeLPT As Boolean, f As Integer
    existe = False
    f = 0
    For f = 0 To CurrentDb.QueryDefs.Count - 1
        'Comprobar si Libros por Autor está definido
        If CurrentDb.QueryDefs(f).Name = "Libros por Autor" Then existeLPA = True
 
        'Comprobar si Libros por Materia está definido
        If CurrentDb.QueryDefs(f).Name = "Libros por Materia" Then existeLPM = True
    'Comprobar si Libros por Materia está definido
        If CurrentDb.QueryDefs(f).Name = "Libros por Titulo" Then existeLPT = True
 
    Next
    If Not existeLPA Then
        LibrosporAutorSql = "" + _
            "SELECT Autores.a, Fondos.Titulo, Fondos.Subtitulo, Editoriales.Editorial, " + _
            "Ejemplares.Sig1, Ejemplares.Sig2, " + _
            "Ejemplares.Sig3, Ubicaciones.Ubicacion, Ejemplares.CodigoEjemplar, " + _
            "[Sig1] & " + Chr(34) + " " + Chr(34) + " & [Sig2] & " + Chr(34) + " " + Chr(34) + _
            " & [Sig3] AS Signatura, Fondos.AnoEdicion, Ejemplares.NumRegistro FROM " + _
            "((((Autores INNER JOIN Fondos_Autores ON Autores.IdAutor = " + _
            "Fondos_Autores.IdAutor) INNER JOIN Fondos ON (Fondos_Autores.IdFondo = " + _
            "Fondos.IdFondo)AND (Autores.IdAutor = Fondos.IdAutor)) INNER JOIN Ejemplares " + _
            "ON Fondos.IdFondo = Ejemplares.IdFondo) INNER JOIN Editoriales ON  " + _
            "Fondos.IdEditorial = Editoriales.IdEditorial) INNER JOIN Ubicaciones ON " + _
            "Ejemplares.IdUbicacion = Ubicaciones.IdUbicacion;"
 
            CurrentDb.CreateQueryDef "Libros por Autor", LibrosporAutorSql
    End If
    If Not existeLPM Then
 
            LibrosporMateriaSql = "" + _
            "SELECT Descriptores.cDescriptor, Autores.a, Fondos.Titulo, " + _
            "Fondos.Subtitulo, Editoriales.Editorial, Ejemplares.Sig1, " + _
            "Ejemplares.Sig2, Ejemplares.Sig3, Ubicaciones.Ubicacion, " + _
            "Ejemplares.CodigoEjemplar, [Sig1] & " + Chr(34) + " " + Chr(34) + " & [Sig2] & " + _
            Chr(34) + " " + Chr(34) + " & " + _
            "[Sig3] AS Signatura, Fondos.AnoEdicion, Ejemplares.NumRegistro" + _
            " FROM Descriptores INNER JOIN (((((Autores RIGHT JOIN Fondos " + _
            "ON Autores.IdAutor=Fondos.IdAutor) INNER JOIN Ejemplares ON " + _
            "Fondos.IdFondo=Ejemplares.IdFondo) LEFT JOIN Editoriales ON " + _
            "Fondos.IdEditorial=Editoriales.IdEditorial) INNER JOIN " + _
            "Ubicaciones ON Ejemplares.IdUbicacion=Ubicaciones.IdUbicacion) " + _
            "INNER JOIN Fondos_Descriptores ON Fondos.IdFondo=Fondos_Descriptores.IdFondo) " + _
            "ON Descriptores.IdDescriptor=Fondos_Descriptores.IdDescriptor " + _
            "ORDER BY Descriptores.cDescriptor;"
 
'        LibrosporMateriaSql = _
'        " SELECT Descriptores.cDescriptor, Autores.a, Fondos.Titulo, Fondos.Subtitulo," + _
'        " Editoriales.Editorial, Ejemplares.Sig1, Ejemplares.Sig2, Ejemplares.Sig3," + _
'        " Ubicaciones.Ubicacion, Ejemplares.CodigoEjemplar, [Sig1] & " + _
'        Chr(34) + " " + Chr(34) + " & [Sig2] & " + Chr(34) + " " + Chr(34) + " & [Sig3]" + _
'        " AS Signatura, Fondos.AnoEdicion, Ejemplares.NumRegistro" + _
'        " FROM Descriptores INNER JOIN (((((Autores INNER JOIN Fondos ON" + _
'        " Autores.IdAutor=Fondos.IdAutor) INNER JOIN Ejemplares ON" + _
'        " Fondos.IdFondo=Ejemplares.IdFondo) INNER JOIN Editoriales ON" + _
'        " Fondos.IdEditorial=Editoriales.IdEditorial) INNER JOIN Ubicaciones ON" + _
'        " Ejemplares.IdUbicacion=Ubicaciones.IdUbicacion) INNER JOIN Fondos_Descriptores" + _
        " ON Fondos.IdFondo=Fondos_Descriptores.IdFondo) ON" + _
        " Descriptores.IdDescriptor=Fondos_Descriptores.IdDescriptor" + _
        " ORDER BY Descriptores.cDescriptor;"
        CurrentDb.CreateQueryDef "Libros por Materia", LibrosporMateriaSql
 
    End If
    If Not existeLPT Then
        LibrosPorTituloSQL = _
        "SELECT Fondos.Titulo, Fondos.Subtitulo, Editoriales.Editorial, Autores.a, Ejemplares.Sig1, Ejemplares.Sig2, " + _
        "Ejemplares.Sig3, Ubicaciones.Ubicacion, Ejemplares.CodigoEjemplar, [Sig1] & "" "" & [Sig2] & "" "" & [Sig3] " + _
        "AS Signatura, Fondos.AnoEdicion, Ejemplares.NumRegistro, InStr([Titulo],[Sig3]) AS Expr1, " + _
        "IIf([Expr1]>1,Mid([Titulo],[Expr1]) & "", "" & Left([Titulo],[Expr1]-1),[Titulo]) AS Canonico " + _
        "FROM (((Fondos INNER JOIN Ejemplares ON Fondos.IdFondo = Ejemplares.IdFondo) INNER JOIN Editoriales ON " + _
        "Fondos.IdEditorial = Editoriales.IdEditorial) INNER JOIN Ubicaciones ON Ejemplares.IdUbicacion = " + _
        "Ubicaciones.IdUbicacion) LEFT JOIN Autores ON Fondos.IdAutor = Autores.IdAutor;"
        CurrentDb.CreateQueryDef "Libros por Titulo", LibrosPorTituloSQL
    End If
 
 
End Sub
'Comprueba que MiRuta sea un solo archivo, de modo que se pueda borrar, es decir:
'  no debe contener caracteres comodín
'  no debe acabar en \ (nombre de directorio)
'  al ejecutar DIR$(Miruta) dos veces, la segunda vez se retorna una cadena vacía.
Function ArchivoUnico(MiRuta As String) As Boolean
ArchivoUnico = False
If (InStr(MiRuta, "*") > 1) Or (InStr(MiRuta, "?") > 1) Then Exit Function
If Right$(Trim$(MiRuta), 1) = "\" Then Exit Function
If Right$(Trim$(MiRuta), 1) = ":" Then Exit Function
a$ = Dir(MiRuta)
b$ = Dir()
If b$ = "" Then ArchivoUnico = True
End Function
Sub refreshAll()
    Dim t As TableDef
    hourdiff = 0
    For Each t In CurrentDb.TableDefs
        If InStr(1, t.Connect, "abies", vbTextCompare) > 0 Then
            hourdiff = max(hourdiff, Int(24 * (Now - t.LastUpdated)))
            Debug.Print "Created " & hourdiff & "hours ago "
        End If
 
    Next
    If hourdiff > 12 Then
        respuesta = MsgBox( _
            "La base de datos fue creada hace " & _
            Int(hourdiff / 24) & " días y " & _
            hourdiff Mod 24 & "horas. " & vbCrLf & _
            "¿Actualizar?", vbYesNo _
            )
        If respuesta = vbYes Then
            For Each t In CurrentDb.TableDefs
                If InStr(1, t.Connect, "abies", vbTextCompare) > 0 Then
                t.RefreshLink
                End If
            Next
        End If
    End If
 
 
End Sub
Function max(a As Variant, b As Variant) As Variant
    If a > b Then max = a Else max = b
End Function