Apagada docs

Módulos extra para Abies

Abies es un programa de gestión de bibliotecas escolares mantenido por el Ministerio de Educación de España. Actualmente, es una aplicación en web que se ejecuta en las webs de las distintas consejerías de Educación (una por región) de España, pero en el pasado era una aplicación visual basic que empleaba archivos .mdb (formato Microsoft Access).

Los siguientes son módulos extra para Abies, usando versiones de Abies anteriores a Abies-web (creo que la última fue Abies2000). Es decir, se trata de versiones *obsoletas* de Abies.

Estas versiones obsoletas tenían la ventaja de ejecutarse en local en el ordenador, dando, por tanto, control total sobre los datos al administrador de ese ordenado, aunque para ello había que escribir una contraseña.

Mi modo de operar era el siguiente:

Crear un archivo access que importara (como importación dinámica) el contenido de Abies.mdb
Añadir mis propias consultas y macros a ese archivo access para buscar los datos que a mí me interesaban (y que la aplicación de Abies no proporcionaba) o para ejecutar consultas de modificación.

Buscar errores en la tabla de autores

Abies2000 usaba dos registros de autores:

Una tabla que enlazaba cada volumen con una lista de autores, atribuyendo a cada uno una diferente responsabilidad (ejemplo: contenía los tripletes (“Astérix el Galo”,“Guionista:”, “Uderzo”) y (“Astérix el Galo”, “Ilustrador:”, “Gosciny”).
Otra tabla que contenía una lista de datos básicos de libros, entre ellos el autor.

Si el autor no estaba en la primera tabla, no era mostrado en las estadísticas.

Este script crea una tabla excel que indica a qué libros les afecta ese problema.

Comprobar_autores.bas

 Option Compare Database
 
'Buscar ejemplares sin autor en la tabla fondos_autores
'(Ejemplares con autor declarado en fondos pero sin autor en fondos_autores)
' Creo que esa es la causa de que "Réquiem por un campesino español" de Ramón J. Sender no aparezca
' en Abies, a pesar de que aparece en la tabla "ejemplares" y en la tabla "fondos".
 
Sub buscaEjemplaresSinAutor()
Dim Fondos As Recordset
Dim FondosAutor As Recordset
Dim xlApp As Excel.Application
Dim Book As New Excel.Workbook
Dim MySheet As Excel.Worksheet
 
Dim Db As Database
 
Set Db = Access.CurrentDb
 
Set xlApp = CreateObject("Excel.Application")
Set Book = xlApp.Workbooks.Add
Set MySheet = Book.Sheets(1)
        Book.Activate
        With MySheet
            With .Range("A:D")
                .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) = "Fondos sin autor en IDAutores"
            .Cells(2, 1) = "IDFondo"
            .Cells(2, 2) = "IDAutor"
            .Cells(2, 3) = "A"
            .Cells(2, 4) = "Titulo"
            .Cells(2, 5) = "CodigoEjemplar"
            .Cells(2, 6) = "NumRegistro"
            .Cells(2, 7) = "[Signatura]"
            .Cells(2, 8) = "FechaAlta"
            .Cells(2, 9) = "[Arreglado?]"
 
            'Colorear el encabezado
            .Range("A1:G1").Cells.Interior.Color = RGB(&HFF, &HCC, &H99)
            .Range("A1:G1").HorizontalAlignment = xlCenter
            .Range("A1:G1").Merge
            .Range("A2:G2").Cells.Interior.Color = RGB(&HC0, &HC0, &HC0)
            .Columns(1).ColumnWidth = 8
            .Columns(2).ColumnWidth = 8
            .Columns(3).ColumnWidth = 20
            .Columns(4).ColumnWidth = 20
            .Columns(5).ColumnWidth = 8
            .Columns(6).ColumnWidth = 8
            .Columns(7).ColumnWidth = 8
            .Columns(8).ColumnWidth = 8
        FilaAct = 3
        End With
 
 
  consulta = "SELECT Ejemplares.CodigoEjemplar,Autores.a, Fondos.Titulo, Ejemplares.Sig1, " + _
             "Ejemplares.Sig2, Ejemplares.Sig3, Fondos.IdFondo,Fondos.IdAutor, " + _
             "Ejemplares.FechaAlta, Ejemplares.NumRegistro " + _
             "FROM (Fondos INNER JOIN Ejemplares ON Fondos.IdFondo = Ejemplares.IdFondo)" + _
             "INNER JOIN Autores ON Fondos.IdAutor = Autores.IdAutor " + _
             "ORDER BY Fondos.IdFondo"
 
    Set Fondos = Db.OpenRecordset(consulta, dbOpenDynaset)
    Fondos.MoveFirst
    Do Until Fondos.EOF
        While Fondos.Fields("idfondo") = "": Fondos.MoveNext: Wend
        idfondo = Fondos.Fields("IdFondo")
        consulta2 = "SELECT * FROM [Fondos_Autores] Where [IdFondo]=" & idfondo & " ORDER By IdFondo"
        Set FondosAutor = CurrentDb.OpenRecordset(consulta2, dbOpenDynaset)
        cuenta = FondosAutor.RecordCount
        'If idfondo = 3294 Then Stop
       If cuenta = 0 Then
            With MySheet
                .Cells(FilaAct, 1) = Fondos.Fields("idFondo")
                .Cells(FilaAct, 2) = Fondos.Fields("idAutor")
                .Cells(FilaAct, 3) = Fondos.Fields("A")
                .Cells(FilaAct, 4) = Fondos.Fields("Titulo")
                .Cells(FilaAct, 5) = Fondos.Fields("CodigoEjemplar")
                .Cells(FilaAct, 6) = Fondos.Fields("NumRegistro")
                .Cells(FilaAct, 6) = Fondos.Fields("Sig1") + " " + Fondos.Fields("Sig2") + " " + Fondos.Fields("Sig3")
                .Cells(FilaAct, 7) = Fondos.Fields("FechaAlta")
            End With
            FilaAct = FilaAct + 1
            respuesta = MsgBox( _
                    "El libro " + vbCrLf + Chr(34) + _
                    Fondos.Fields("Titulo") + Chr(34) + vbCrLf + _
                    "(autor: " + Fondos.Fields("A") + ")" + vbCrLf + _
                    "no tiene entrada de autor en la tabla Fondos_Autores." + vbCrLf + _
                    "¿Crear entrada?", _
                    vbYesNo + vbQuestion, _
                    "Arreglar Autor")
            If respuesta = vbYes Then
                'Stop
                ' Inserta una línea en la hoja de cálculo avisando del arreglo.
                MySheet.Cells(FilaAct - 1, 9) = "ARREGLADO"
                'Inserta un registro nuevo en Fondos_Autores
                FondosAutor.AddNew
                FondosAutor.Fields("idAutor") = Fondos.Fields("idAutor")
                FondosAutor.Fields("idFondo") = Fondos.Fields("idFondo")
                Rem FondosAutor.Fields("idFuncion")= Vacío
                FondosAutor.Fields("Principal") = True
                FondosAutor.Update
            End If
 
        End If
        FondosAutor.Close
        Fondos.MoveNext
        Debug.Print ".";
    Loop
    Book.Application.Visible = True
End Sub

GeneraLibrosPorAutor era el script que yo usaba para generar las estadísticas, que luego subía a una web donde tenía un script processing Estadística Biblio BDO que convertía esas estadísticas en hermosos gráficos donde las barras estaban representadas con libros.

GeneraLibrosPorAutor.bas

'Para usar este archivo:
' 1) Use una copia de la base de datos, no actúe directamente sobre los datos de abies.
' 2) Añada las consultas "Libros por autor" y "Libros por materia" si no existen (ver abajo).
' 3) Añada referencias a la biblioteca de Excel.
'
'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;
'
'Ejemplares por descriptor está definido como:
'
'    SELECT Descriptores.cDescriptor, Autores.a, Fondos.Titulo, Editoriales.Editorial, Fondos.AnoEdicion, Ubicaciones.Ubicacion,
'     Ejemplares.Sig1, Ejemplares.Sig2, Ejemplares.Sig3, [Sig1] & " " & [Sig2] & " " & [Sig3] AS Signatura
'     FROM (Ubicaciones INNER JOIN (((Autores INNER JOIN (Fondos_Descriptores
'     INNER JOIN Fondos ON Fondos_Descriptores.IdFondo = Fondos.IdFondo) ON Autores.IdAutor = Fondos.IdAutor)
'     INNER JOIN Editoriales ON Fondos.IdEditorial = Editoriales.IdEditorial)
'     INNER JOIN Ejemplares ON Fondos.IdFondo = Ejemplares.IdFondo) ON Ubicaciones.IdUbicacion = Ejemplares.IdUbicacion)
'     INNER JOIN Descriptores ON Fondos_Descriptores.IdDescriptor = Descriptores.IdDescriptor
'     ORDER BY Descriptores.cDescriptor;
'
 
Option Compare Database
'IMPORTAR LA REFERENCIA EXCEL
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 un fichero de libros por título.
Sub CreaLibrosPorTitulo()
Dim xlApp As Excel.Application
Dim Book As New Excel.Workbook
Dim MySheet As Excel.Worksheet
Dim Db As Database
Dim LibrosPorAutor As Recordset
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;
'
'Ejemplares por descriptor está definido como:
'
'    SELECT Descriptores.cDescriptor, Autores.a, Fondos.Titulo, Editoriales.Editorial, Fondos.AnoEdicion, Ubicaciones.Ubicacion,
'     Ejemplares.Sig1, Ejemplares.Sig2, Ejemplares.Sig3, [Sig1] & " " & [Sig2] & " " & [Sig3] AS Signatura
'     FROM (Ubicaciones INNER JOIN (((Autores INNER JOIN (Fondos_Descriptores
'     INNER JOIN Fondos ON Fondos_Descriptores.IdFondo = Fondos.IdFondo) ON Autores.IdAutor = Fondos.IdAutor)
'     INNER JOIN Editoriales ON Fondos.IdEditorial = Editoriales.IdEditorial)
'     INNER JOIN Ejemplares ON Fondos.IdFondo = Ejemplares.IdFondo) ON Ubicaciones.IdUbicacion = Ejemplares.IdUbicacion)
'     INNER JOIN Descriptores ON Fondos_Descriptores.IdDescriptor = Descriptores.IdDescriptor
'     ORDER BY Descriptores.cDescriptor;
 
'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
For Ifiltro = 0 To UBound(Hojas)
    NombreLast = NombreHoja
    NombreHoja = Hojas(Ifiltro)
    filtro = "[" & Filtros(Ifiltro) & "]*"
    consulta = "SELECT * " & _
        "FROM [Libros por Autor] " & _
        "Where Titulo LIKE """ + filtro + "*"" " & _
        "ORDER BY Titulo "
 
    Set LibrosPorAutor = Db.OpenRecordset(consulta, _
        dbOpenDynaset)
 
    xlApp.Visible = True
 
    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:D")
                .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"
            'Colorear las hojas con el color que tienen
            'las existentes en Google Spreadsheets
            .Range("A1:E1").Cells.Interior.Color = RGB(&HFF, &HCC, &H99)
            .Range("A1:E1").HorizontalAlignment = xlCenter
            .Range("A1:E1").Merge
            .Range("A2:E2").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
            FilaAct = 3
        End With
    End If
    Debug.Print "----- HOJA: " & NombreHoja & " -----"
    While Not LibrosPorAutor.EOF
        Debug.Print LibrosPorAutor.Fields("Titulo")
        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")
        End With
        FilaAct = FilaAct + 1
        LibrosPorAutor.MoveNext
     Wend
     LibrosPorAutor.Close
Next
 
On Error GoTo Errorgrabando
Book.SaveAs (Environ$("Userprofile") + "\" + "Libros por Titulo.xls")
 
On Error GoTo 0
response = MsgBox("¿Cerrar la hoja de Cálculo?", vbYesNo Or vbExclamation, "Confirme operación")
If response = vbNo Then
        Book.Activate
Else
    Book.Close
End If
 
Final:
    Exit Sub
 
Errorgrabando:
    response = MsgBox("Aviso: No se grabó la hoja de cálculo", vbOK Or vbExclamation, "AVISO")
    Book.Activate
    Resume
 
End Sub
 
'Crea un fichero de libros por Autor.
Sub CreaLibrosPorAutor()
Dim xlApp As Excel.Application
Dim Book As New Excel.Workbook
Dim MySheet As Excel.Worksheet
Dim Db As Database
Dim LibrosPorAutor As Recordset
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;
'
 
'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
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)
 
    xlApp.Visible = True
 
    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:D")
                .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"
            'Colorear las hojas con el color que tienen
            'las existentes en Google Spreadsheets
            .Range("A1:E1").Cells.Interior.Color = RGB(&HFF, &HCC, &H99)
            .Range("A1:E1").HorizontalAlignment = xlCenter
            .Range("A1:E1").Merge
            .Range("A2:E2").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
            FilaAct = 3
        End With
    End If
    Debug.Print "----- HOJA: " & NombreHoja & " -----"
    While Not LibrosPorAutor.EOF
        Debug.Print LibrosPorAutor.Fields("a")
        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")
        End With
        FilaAct = FilaAct + 1
        LibrosPorAutor.MoveNext
     Wend
     LibrosPorAutor.Close
Next
 
On Error GoTo Errorgrabando
Book.SaveAs (Environ$("Userprofile") + "\" + "Libros por Autor.xls")
 
On Error GoTo 0
response = MsgBox("¿Cerrar la hoja de Cálculo?", vbYesNo Or vbExclamation, "Confirme operación")
If response = vbNo Then
        Book.Activate
Else
    Book.Close
End If
 
Final:
    Exit Sub
 
Errorgrabando:
    response = MsgBox("Aviso: No se grabó la hoja de cálculo", vbOK Or vbExclamation, "AVISO")
    Book.Activate
    Resume
 
End Sub
 
 
'Crea un fichero de libros por Materia.
Sub CreaLibrosPorMateria()
Dim xlApp As Excel.Application
Dim Book As New Excel.Workbook
Dim MySheet As Excel.Worksheet
Dim Db As Database
Dim LibrosPorAutor As Recordset
Set Db = Access.CurrentDb
Set xlApp = CreateObject("Excel.Application")
Set Book = xlApp.Workbooks.Add
 
'Ejemplares por descriptor está definido como:
'
'SELECT Descriptores.cDescriptor, Autores.a, Fondos.Titulo, Editoriales.Editorial, Fondos.AnoEdicion, Ubicaciones.Ubicacion,
' Ejemplares.Sig1, Ejemplares.Sig2, Ejemplares.Sig3, [Sig1] & " " & [Sig2] & " " & [Sig3] AS Signatura
' FROM (Ubicaciones INNER JOIN (((Autores INNER JOIN (Fondos_Descriptores
' INNER JOIN Fondos ON Fondos_Descriptores.IdFondo = Fondos.IdFondo) ON Autores.IdAutor = Fondos.IdAutor)
' INNER JOIN Editoriales ON Fondos.IdEditorial = Editoriales.IdEditorial)
' INNER JOIN Ejemplares ON Fondos.IdFondo = Ejemplares.IdFondo) ON Ubicaciones.IdUbicacion = Ejemplares.IdUbicacion)
' INNER JOIN Descriptores ON Fondos_Descriptores.IdDescriptor = Descriptores.IdDescriptor
' ORDER BY Descriptores.cDescriptor;
'
'
 
'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
For Ifiltro = 0 To UBound(Hojas)
    NombreLast = NombreHoja
    NombreHoja = Hojas(Ifiltro)
    filtro = "[" & Filtros(Ifiltro) & "]*"
    consulta = "SELECT * " & _
        "FROM [Ejemplares por Descriptor] " & _
        "Where cDescriptor LIKE """ + filtro + "*"" " & _
        "ORDER BY cDescriptor "
 
    Set LibrosPorMateria = Db.OpenRecordset(consulta, _
        dbOpenDynaset)
 
    xlApp.Visible = True
 
    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) = "Materia"
            .Cells(2, 2) = "Autor"
            .Cells(2, 3) = "Título"
            .Cells(2, 4) = "Editorial"
            .Cells(2, 5) = "Ubicacion"
            .Cells(2, 6) = "Signatura"
            '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:F1").Merge
            .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 = 20
            .Columns(5).ColumnWidth = 13
            .Columns(5).ColumnWidth = 13
            FilaAct = 3
        End With
    End If
    Debug.Print "----- HOJA: " & NombreHoja & " -----"
    While Not LibrosPorMateria.EOF
        Debug.Print LibrosPorMateria.Fields("a")
        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("Ubicacion")
            .Cells(FilaAct, 6) = LibrosPorMateria.Fields("Signatura")
        End With
        FilaAct = FilaAct + 1
        LibrosPorMateria.MoveNext
     Wend
     LibrosPorMateria.Close
Next
 
On Error GoTo Errorgrabando
Book.SaveAs (Environ$("Userprofile") + "\" + "Libros por Materia.xls")
 
On Error GoTo 0
response = MsgBox("¿Cerrar la hoja de Cálculo?", vbYesNo Or vbExclamation, "Confirme operación")
If response = vbNo Then
        Book.Activate
Else
    Book.Close
End If
 
Final:
    Exit Sub
 
Errorgrabando:
    response = MsgBox("Aviso: No se grabó la hoja de cálculo", vbOK Or vbExclamation, "AVISO")
    Book.Activate
    Resume
 
End Sub

Apagada docs

Herramientas de usuario

Herramientas del sitio

Módulos extra para Abies

Buscar errores en la tabla de autores

Herramientas de la página