Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Foros » Access » VBA Access y resultado llevarlo a fichero plano

Access - VBA Access y resultado llevarlo a fichero plano

Volver
Nuevo Tema
<<>>
 
Vista:

VBA Access y resultado llevarlo a fichero plano

Publicado por rrodsal (1 intervención) el 26/04/2017 17:50:37
Buenas tardes.

He leído la última semana bastante estse foro pues neceisto de vuestra ayuda. Mis conocimientos de VBA son nulos. Os comento:

El código que pego en este mensaje genera las propiedades de las tablas de la BD Access con la que trabajo. La idea es conseguir un diccionario de datos de todas las BBDD que hay en el sistema, son más de 70. Ejecutaré este códiog una a una pues tengo que realizar cambios y añadir descripciones, etc...

La cuestión es que este código lo he generado a partir de cortar y pegar y prueba y error pero aunque en la 'venta inmediato' me aparece el resultado aparece cortado pues son muchos registros y necesito llevarmelo a Excel, o fichero plano e importarlo luego en Excel.

E nresume, si ejecuto el código el resultado neceisto llevarlo a un fichero, a poder ser Excel.

Gracias por la ayuda!!!



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
Function TableInfo(strTableName As String)
 
On Error GoTo TableInfoErr
   ' Purpose:   Display the field names, types, sizes and descriptions for a table.

   ' Argument:  Name of a table in the current database.

   Dim db As DAO.Database
   Dim tdf As DAO.TableDef
   Dim fld As DAO.Field
   Dim instruccion As String
 
   Set db = CurrentDb()
   Set tdf = db.TableDefs(strTableName)
 
 
 
   Debug.Print "PATH NAME", "TABLE NAME", "FIELD NAME", "FIELD TYPE", "SIZE", "DESCRIPTION"
   Debug.Print "==========", "==========", "==========", "==========", "====", "==========="
 
   For Each fld In tdf.Fields
      Debug.Print db.Name,
      Debug.Print tdf.Name,
      Debug.Print fld.Name,
      Debug.Print FieldTypeName(fld),
      Debug.Print fld.Size,
      Debug.Print GetDescrip(fld)
 
 
 
    Next
   Debug.Print "==========", "==========", "==========", "====", "==========="
 
TableInfoExit:
   Set db = Nothing
   Exit Function
 
TableInfoErr:
   Select Case Err
   Case 3265&  'Table name invalid

      MsgBox strTableName & " table doesn't exist"
   Case Else
      Debug.Print "TableInfo() Error " & Err & ": " & Error
   End Select
   Resume TableInfoExit
End Function
 
 
Function GetDescrip(obj As Object) As String
    On Error Resume Next
    GetDescrip = obj.Properties("Description")
End Function
 
 
Function FieldTypeName(fld As DAO.Field) As String
    'Purpose: Converts the numeric results of DAO Field.Type to text.

    Dim strReturn As String    'Name to return

 
    Select Case CLng(fld.Type) 'fld.Type is Integer, but constants are Long.

        Case dbBoolean: strReturn = "Yes/No"            ' 1

        Case dbByte: strReturn = "Byte"                 ' 2

        Case dbInteger: strReturn = "Integer"           ' 3

        Case dbLong                                     ' 4

            If (fld.Attributes And dbAutoIncrField) = 0& Then
                strReturn = "Long Integer"
            Else
                strReturn = "AutoNumber"
            End If
        Case dbCurrency: strReturn = "Currency"         ' 5

        Case dbSingle: strReturn = "Single"             ' 6

        Case dbDouble: strReturn = "Double"             ' 7

        Case dbDate: strReturn = "Date/Time"            ' 8

        Case dbBinary: strReturn = "Binary"             ' 9 (no interface)

        Case dbText                                     '10

            If (fld.Attributes And dbFixedField) = 0& Then
                strReturn = "Text"
            Else
                strReturn = "Text (fixed width)"        '(no interface)

            End If
        Case dbLongBinary: strReturn = "OLE Object"     '11

        Case dbMemo                                     '12

            If (fld.Attributes And dbHyperlinkField) = 0& Then
                strReturn = "Memo"
            Else
                strReturn = "Hyperlink"
            End If
        Case dbGUID: strReturn = "GUID"                 '15

 
        'Attached tables only: cannot create these in JET.

        Case dbBigInt: strReturn = "Big Integer"        '16

        Case dbVarBinary: strReturn = "VarBinary"       '17

        Case dbChar: strReturn = "Char"                 '18

        Case dbNumeric: strReturn = "Numeric"           '19

        Case dbDecimal: strReturn = "Decimal"           '20

        Case dbFloat: strReturn = "Float"               '21

        Case dbTime: strReturn = "Time"                 '22

        Case dbTimeStamp: strReturn = "Time Stamp"      '23

 
        'Constants for complex types don't work prior to Access 2007 and later.

        Case 101&: strReturn = "Attachment"         'dbAttachment

        Case 102&: strReturn = "Complex Byte"       'dbComplexByte

        Case 103&: strReturn = "Complex Integer"    'dbComplexInteger

        Case 104&: strReturn = "Complex Long"       'dbComplexLong

        Case 105&: strReturn = "Complex Single"     'dbComplexSingle

        Case 106&: strReturn = "Complex Double"     'dbComplexDouble

        Case 107&: strReturn = "Complex GUID"       'dbComplexGUID

        Case 108&: strReturn = "Complex Decimal"    'dbComplexDecimal

        Case 109&: strReturn = "Complex Text"       'dbComplexText

        Case Else: strReturn = "Field type " & fld.Type & " unknown"
    End Select
 
    FieldTypeName = strReturn
End Function
 
 
Public Sub ShowTableFields()
 
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Set db = CurrentDb
For Each tdf In db.TableDefs
    ' ignore system and temporary tables

    If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then
        TableInfo (tdf.Name)
    End If
Next
Set tdf = Nothing
Set db = Nothing
 
 
End Sub
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
Imágen de perfil de Norberto
Val: 1.094
Oro
Ha mantenido su posición en Access (en relación al último mes)
Gráfica de Access

VBA Access y resultado llevarlo a fichero plano

Publicado por Norberto (753 intervenciones) el 27/04/2017 16:21:36
Hola.

Añade/cambia tu código por este otro:

Para texto plano:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
    Dim nArchivo As Long
 
 
    nArchivo = FreeFile 'Buscamos el primer número de archivo libre

 
    Open "Propiedades.log" For Output As nArchivo   'Abrimos para escritura el archivo Propiedades.log

 
    'Escribimos el encabezado

    Print #nArchivo, "PATH NAME", "TABLE NAME", "FIELD NAME", "FIELD TYPE", "SIZE", "DESCRIPTION"

    Print #nArchivo, "==========", "==========", "==========", "==========", "====", "==========="

 
    'Para cada campo de la tabla

    For Each fld In Tbl.Fields
        'Escribimos la información del campo

        Print #nArchivo, Db.Name, _

                         tdf.Name, _
                         fld.Name, _
                         FielTypeName(fld), _
                         fld.Size, _
                         GetDescrip(fld)
    Next
 
    'Escribimos el pie

    Print #nArchivo, "==========", "==========", "==========", "====", "==========="

 
    'Cerramos el archivo

    Close nArchivo
...

Para excel:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
...
    '

    'Añadir la referencia Microsoft Excel xx.x Object Library

    '

 
    Dim xApp As Excel.Application, xLibro As Excel.Workbook
    Dim xHoja As Excel.Worksheet, xCelda As Excel.Range
    Dim I As Integer
 
    'Abrimos Excel y creamos un nuevo libro

    Set xApp = CreateObject("Excel.Application")
    xApp.Visible = True 'Si queremos ver lo que va ocurriendo

 
    Set xLibro = xApp.Workbooks.Add
    'Asignamos la hoja y celdas activas

    Set xHoja = xLibro.Worksheets(1)
    Set xCelda = xHoja.Range("A1")
    'Escribimos el encabezado

 
    With xCelda
        .Formula = "PATH NAME": I = I + 1   'Escribimos y pasamos a la siguiente columna

        .Offset(0, I) = "TABLE NAME": I = I + 1
        .Offset(0, I) = "FIELD NAME": I = I + 1
        .Offset(0, I) = "FIELD TYPE": I = I + 1
        .Offset(0, I) = "SIZE": I = I + 1
        .Offset(0, I) = "DESCRIPTION"
        Set xCelda = .Offset(1) 'Pasamos a la siguiente fila

        I = 0
        .Formula = "==========": I = I + 1
        .Offset(0, I) = "==========": I = I + 1
        .Offset(0, I) = "==========": I = I + 1
        .Offset(0, I) = "==========": I = I + 1
        .Offset(0, I) = "====": I = I + 1
        .Offset(0, I) = "==========="
        Set xCelda = .Offset(1)
 
        'Para cada campo de la tabla

        For Each fld In Tbl.Fields
            I = 0
            'Escribimos la información del campo

            .Formula = Db.Name: I = I + 1
            .Offset(0, I) = tdf.Name: I = I + 1
            .Offset(0, I) = fld.Name: I = I + 1
            .Offset(0, I) = FielTypeName(fld): I = I + 1
            .Offset(0, I) = fld.Size: I = I + 1
            .Offset(0, I) = GetDescrip(fld)
            Set xCelda = .Offset(1)
            DoEvents
        Next
        .Formula = "==========": I = I + 1
        .Offset(0, I) = "==========": I = I + 1
        .Offset(0, I) = "==========": I = I + 1
        .Offset(0, I) = "==========": I = I + 1
        .Offset(0, I) = "====": I = I + 1
        .Offset(0, I) = "==========="
        Set xCelda = .Offset(1)
    End With
 
    'Guardamos y cerramos el archivo

    xLibro.SaveAs "Propideades.xlsx"
    xLibro.Close
    xApp.Quit
 
    'Vaciamos la variables de objeto

    Set xCelda = Nothing
    Set xHoja = Nothing
    Set xLibro = Nothing
    Set xApp = Nothing
...

Pruébalos y si falla algo me lo dices ya que no lo he probado.

Un saludo,

Norberto.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar