Error con permisos de access?

Tengo inconvenientes con los permisos, me indica que vba no acepta este tipo de automatización ¿Alguna idea?

CREATE TABLE tblNormalizacionDef (

TablaOrigen TEXT(128) NOT NULL,

TablaDestino TEXT(128) NOT NULL,

Delimitador TEXT(5) NULL,

CopiarSiSinExpansion YESNO NOT NULL

);

CREATE TABLE tblMapeoCampos (

TablaOrigen TEXT(128) NOT NULL,

CampoLista TEXT(64) NOT NULL,

CampoComentario TEXT(64) NULL,

Orden LONG NOT NULL

);

CREATE TABLE tblTokensIgnorados (

TablaOrigen TEXT(128) NOT NULL,

Token TEXT(64) NOT NULL

);

INSERT INTO tblNormalizacionDef (TablaOrigen, TablaDestino, Delimitador, CopiarSiSinExpansion) VALUES ("TuTablaOrigen", "NORM_TuTablaOrigen", ",", False);

INSERT INTO tblMapeoCampos (TablaOrigen, CampoLista, CampoComentario, Orden) VALUES ("TuTablaOrigen", "documento1", "comentario1", 1);

INSERT INTO tblMapeoCampos (TablaOrigen, CampoLista, CampoComentario, Orden) VALUES ("TuTablaOrigen", "documento2", "comentario2", 2);

INSERT INTO tblTokensIgnorados (TablaOrigen, Token) VALUES ("TuTablaOrigen", "/n");

INSERT INTO tblTokensIgnorados (TablaOrigen, Token) VALUES ("TuTablaOrigen", "n/a");

INSERT INTO tblTokensIgnorados (TablaOrigen, Token) VALUES ("TuTablaOrigen", "-");

Option Compare Database

Option Explicit

' ====== VALORES POR DEFECTO ======

' Si se llama al procedimiento sin parámetros,

' se usarán estos valores.

Public Const DEF_TABLA_ORIGEN As String = "TuTablaOrigen"

Public Const DEF_TABLA_DESTINO As String = "NORM_TuTablaOrigen"

Public Const DEF_TABLA_CONFIG_DEF As String = "tblNormalizacionDef"

Public Const DEF_TABLA_CONFIG_MAPEO As String = "tblMapeoCampos"

Public Const DEF_TABLA_CONFIG_TOKENS As String = "tblTokensIgnorados"

' ===============================================================

' FUNCIONES DE UTILIDAD

' ===============================================================

' Verifica si existe una tabla en la base de datos actual

Private Function ExisteTabla(ByVal nombreTabla As String) As Boolean

Dim t As DAO.TableDef

ExisteTabla = False

For Each t In CurrentDb.TableDefs

' Ignorar tablas del sistema

If t.Attributes = 0 Or (t.Attributes And dbSystemObject) = 0 Then

If t.Name = nombreTabla Then ExisteTabla = True: Exit Function

End If

Next t

End Function

' Verifica si un campo existe dentro de una tabla

Private Function ExisteCampo(ByVal nombreTabla As String, ByVal nombreCampo As String) As Boolean

Dim t As DAO.TableDef

Dim f As DAO.Field

ExisteCampo = False

For Each t In CurrentDb.TableDefs

If t.Name = nombreTabla Then

For Each f In t.Fields

If f.Name = nombreCampo Then ExisteCampo = True: Exit Function

Next f

Exit For

End If

Next t

End Function

' Crea la tabla destino copiando todos los campos de la tabla origen

' y agregando tres campos adicionales:

' - CampoDocumentoOrigen

' - ValorDocumento

' - ComentarioAsociado

Private Sub CrearTablaDestinoComoOrigenMasExtras(ByVal tablaOrigen As String, ByVal tablaDestino As String)

Dim db As DAO.Database

Dim tSrc As DAO.TableDef

Dim tNew As DAO.TableDef

Dim f As DAO.Field

Dim fNew As DAO.Field

Set db = CurrentDb

' Si ya existe la tabla destino, no la volvemos a crear

If ExisteTabla(tablaDestino) Then Exit Sub

Set tNew = db.CreateTableDef(tablaDestino)

' Copiar campos de la tabla origen

For Each tSrc In db.TableDefs

If tSrc.Name = tablaOrigen Then

For Each f In tSrc.Fields

' Si es texto o binario, se conserva el tamaño

If f.Type = dbText Or f.Type = dbBinary Then

Set fNew = tNew.CreateField(f.Name, f.Type, f.Size)

Else

Set fNew = tNew.CreateField(f.Name, f.Type)

End If

tNew.Fields.Append fNew

Next f

Exit For

End If

Next tSrc

' Agregar campos adicionales para normalización

tNew.Fields.Append tNew.CreateField("CampoDocumentoOrigen", dbText, 128)

tNew.Fields.Append tNew.CreateField("ValorDocumento", dbText, 255)

tNew.Fields.Append tNew.CreateField("ComentarioAsociado", dbMemo)

db.TableDefs.Append tNew

End Sub

' Devuelve "" si el valor es NULL

Private Function LimpiarNull(ByVal v As Variant) As String

If IsNull(v) Then LimpiarNull = "" Else LimpiarNull = CStr(v)

End Function

' Limpia espacios y comas extra en los tokens

Private Function TrimToken(ByVal s As String) As String

Dim r As String

r = Trim$(s)

If Left$(r, 1) = "," Then r = Mid$(r, 2)

If Right$(r, 1) = "," Then r = Left$(r, Len(r) - 1)

TrimToken = Trim$(r)

End Function

' Lee configuración en tblNormalizacionDef para una tabla origen

Private Function LeerDef(ByVal tablaOrigen As String, ByVal tablaConfigDef As String, ByRef tablaDestino As String, ByRef delim As String, ByRef copiarSiSin As Boolean) As Boolean

Dim rs As DAO.Recordset

Dim sql As String

LeerDef = False

' Valores predeterminados

tablaDestino = "NORM_" & tablaOrigen

delim = ","

copiarSiSin = False

' Si no existe la tabla de configuración, salimos

If Not ExisteTabla(tablaConfigDef) Then Exit Function

sql = "SELECT TOP 1 TablaDestino, Nz(Delimitador, ',') AS Delim, CopiarSiSinExpansion FROM [" & tablaConfigDef & "] WHERE TablaOrigen = '" & Replace(tablaOrigen, "'", "''") & "'"

Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)

If Not rs.EOF Then

tablaDestino = rs!TablaDestino

delim = rs!Delim

copiarSiSin = rs!CopiarSiSinExpansion

LeerDef = True

End If

rs.Close

End Function

' Lee pares de campos (documento - comentario) de tblMapeoCampos

Private Function LeerMapeos(ByVal tablaOrigen As String, ByVal tablaConfigMapeo As String) As Collection

Dim col As New Collection

Dim rs As DAO.Recordset

Dim sql As String

Dim item As String

If Not ExisteTabla(tablaConfigMapeo) Then Set LeerMapeos = col: Exit Function

sql = "SELECT CampoLista, CampoComentario FROM [" & tablaConfigMapeo & "] WHERE TablaOrigen = '" & Replace(tablaOrigen, "'", "''") & "' ORDER BY Orden"

Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)

Do While Not rs.EOF

item = LimpiarNull(rs!CampoLista) & "|" & LimpiarNull(rs!CampoComentario)

col.Add item

rs.MoveNext

Loop

rs.Close

Set LeerMapeos = col

End Function

' Carga la lista de tokens ignorados de tblTokensIgnorados

Private Function CargarTokensIgnorados(ByVal tablaOrigen As String, ByVal tablaConfigTokens As String) As Collection

Dim col As New Collection

Dim rs As DAO.Recordset

Dim sql As String

If Not ExisteTabla(tablaConfigTokens) Then Set CargarTokensIgnorados = col: Exit Function

sql = "SELECT Token FROM [" & tablaConfigTokens & "] WHERE TablaOrigen = '" & Replace(tablaOrigen, "'", "''") & "'"

Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)

Do While Not rs.EOF

col.Add LCase$(Trim$(LimpiarNull(rs!Token)))

rs.MoveNext

Loop

rs.Close

Set CargarTokensIgnorados = col

End Function

' Verifica si un token está en la lista de ignorados

Private Function TokenIgnorado(ByVal token As String, ByVal tokens As Collection) As Boolean

Dim t As Variant

Dim k As String

k = LCase$(Trim$(token))

If k = "" Then TokenIgnorado = True: Exit Function

On Error Resume Next

For Each t In tokens

If k = t Then TokenIgnorado = True: Exit Function

Next t

End Function

' ===============================================================

' PROCEDIMIENTO PRINCIPAL

' ===============================================================

Public Sub Normalizar_Expandir(Optional ByVal tablaOrigen As String = DEF_TABLA_ORIGEN, Optional ByVal tablaDestino As String = DEF_TABLA_DESTINO, Optional ByVal tablaConfigDef As String = DEF_TABLA_CONFIG_DEF, Optional ByVal tablaConfigMapeo As String = DEF_TABLA_CONFIG_MAPEO, Optional ByVal tablaConfigTokens As String = DEF_TABLA_CONFIG_TOKENS)

Dim db As DAO.Database

Dim rsSrc As DAO.Recordset

Dim rsDst As DAO.Recordset

Dim delim As String

Dim copiarSiSin As Boolean

Dim tieneDef As Boolean

Dim mapeos As Collection

Dim tokensIgn As Collection

Dim par As String

Dim nombreLista As String

Dim nombreComentario As String

Dim valorLista As String

Dim comentarioVal As String

Dim tokens() As String

Dim tok As Variant

Dim huboExp As Boolean

Dim f As DAO.Field

Dim i As Long

Set db = CurrentDb

' 1. Leer configuración general (si existe)

tieneDef = LeerDef(tablaOrigen, tablaConfigDef, tablaDestino, delim, copiarSiSin)

If Not tieneDef Then

' Si no hay config, usar valores por defecto

tablaDestino = IIf(Len(Trim$(tablaDestino)) = 0, "NORM_" & tablaOrigen, tablaDestino)

delim = ","

copiarSiSin = False

End If

' 2. Leer pares documento-comentario

Set mapeos = LeerMapeos(tablaOrigen, tablaConfigMapeo)

' 3. Cargar tokens a ignorar

Set tokensIgn = CargarTokensIgnorados(tablaOrigen, tablaConfigTokens)

' 4. Crear tabla destino si no existe

Call CrearTablaDestinoComoOrigenMasExtras(tablaOrigen, tablaDestino)

' 5. Vaciar la tabla destino antes de insertar nuevos datos

db.Execute "DELETE FROM [" & tablaDestino & "]", dbFailOnError

' 6. Abrir recordsets

Set rsSrc = db.OpenRecordset("SELECT * FROM [" & tablaOrigen & "]", dbOpenSnapshot)

Set rsDst = db.OpenRecordset("SELECT * FROM [" & tablaDestino & "]", dbOpenDynaset)

' 7. Procesar cada registro de la tabla origen

Do While Not rsSrc.EOF

huboExp = False

' Recorrer los pares configurados

For i = 1 To mapeos.Count

par = mapeos(i)

nombreLista = Split(par, "|")(0)

nombreComentario = ""

If UBound(Split(par, "|")) >= 1 Then nombreComentario = Split(par, "|")(1)

' Verificar que el campo de documentos exista en la tabla

If ExisteCampo(tablaOrigen, nombreLista) Then

valorLista = LimpiarNull(rsSrc.Fields(nombreLista).Value)

' Si hay datos en el campo documento

If valorLista <> "" Then

tokens = Split(valorLista, delim)

comentarioVal = ""

' Traer comentario si existe

If nombreComentario <> "" And ExisteCampo(tablaOrigen, nombreComentario) Then comentarioVal = LimpiarNull(rsSrc.Fields(nombreComentario).Value)

' Recorrer cada token

For Each tok In tokens

tok = TrimToken(CStr(tok))

' Insertar solo si no está en la lista de ignorados

If Not TokenIgnorado(CStr(tok), tokensIgn) Then

rsDst.AddNew

' Copiar todos los campos originales

For Each f In rsSrc.Fields

rsDst.Fields(f.Name).Value = rsSrc.Fields(f.Name).Value

Next f

' Agregar campos extra

rsDst.Fields("CampoDocumentoOrigen").Value = nombreLista

rsDst.Fields("ValorDocumento").Value = tok

rsDst.Fields("ComentarioAsociado").Value = comentarioVal

rsDst.Update

huboExp = True

End If

Next tok

End If

End If

Next i

' Si no hubo expansiones y la config lo permite, copiar el registro tal cual

If Not huboExp And copiarSiSin Then

rsDst.AddNew

For Each f In rsSrc.Fields

rsDst.Fields(f.Name).Value = rsSrc.Fields(f.Name).Value

Next f

rsDst.Fields("CampoDocumentoOrigen").Value = ""

rsDst.Fields("ValorDocumento").Value = ""

rsDst.Fields("ComentarioAsociado").Value = ""

rsDst.Update

End If

rsSrc.MoveNext

Loop

' 8. Cerrar recordsets

rsSrc.Close

rsDst.Close

MsgBox "Normalización completada. Tabla destino: " & tablaDestino, vbInformation

End Sub