Código fuente dbGrid, clase para acceso a bses de datos

Código fuente de dbgrid.asp
<%
Class dbGrid
  
  Private m_Carpeta
  Private m_Base
  Private m_Tabla
  Private m_Clave
  Private m_TipoClave
  Private m_ID
  Private m_Link
  Private m_DSN
  Private m_NomDSN
  Private m_Add
  Private m_Del
  Private m_Edit
  Private m_Campos
  Private m_Tbl
  Private m_Res
  Private m_Busca
  Private m_CampSel
  Private m_GrSQL
  Private m_GrQSParams
  Private m_GrEstilo
  Private m_GrWidth
  Private m_GrNumRes
  Private tmpNumRes
  Private m_GrCorte
  Private m_GrOrden
  Private m_GrTipoCol
  Private m_VerTipos
  Private oConn
  Private RS
  Private SQL
  Private aTiposNum
  Private aColors
  Private aRes
  Private aBases()
  Private aTablas()
  Private aCampos()
  Private x
  Private i
  Private Thing
  Private m_ErrMsg
  Private adSchemaTables
  Private adSchemaPrimaryKeys
  Private adUseClient
  Private adOpenForwardOnly
  Private adLockReadOnly
  Private adCmdText
  Private adOpenStatic
  Private adOpenKeyset
  Private adLockPessimistic
    
  Private Sub Class_Initialize()
    m_Carpeta = Server.MapPath(".")
    m_Base = ""
    m_Tabla = ""
    m_Clave = ""
    m_TipoClave = ""
    m_ID = ""
    m_DSN = false
    m_NomDSN = ""
    m_Add = false
    m_Del = false
    m_Edit = false
    m_Campos = false
    m_Tbl = false
    m_Res = false
    m_Busca = false
    m_CampSel = "*"
    m_GrQSParams = ""
    m_GrSQL = ""
    m_GrEstilo = "dbg01"
    m_GrWidth = 612
    m_GrNumRes = 15
    tmpNumRes = 15
    m_GrCorte = 50
    m_GrOrden = false
    m_GrTipoCol = false
    m_VerTipos = false
    aTiposNum = Array(2,3,4,5,16,17,18,19,20,21)
    aColors = Array("B0B8C0","000000","E0EAF4","000000","FFFFFF","ECF4EC","F0ECF4","FFD8D0")
    aRes = Array(10,15,20,30,50)
    i = 0
    ReDim aBases(0)
    ReDim aTablas(0)
    m_ErrMsg = ""
    adSchemaTables = 20
    adSchemaPrimaryKeys = 28
    adUseClient = 3
    adOpenForwardOnly = 0
    adLockReadOnly = 1
    adCmdText = &H0001
    adOpenStatic = 3
    adOpenKeyset = 1
    adLockPessimistic = 2
  End Sub
    
  Private Sub Class_Terminate()
  End Sub
  
  Public Property Get Carpeta()
    Carpeta = m_Carpeta
  End Property
  Public Property Let Carpeta(x)
    m_Carpeta = x
  End Property
  
  Public Property Get Base()
    Base = m_Base
  End Property
  Public Property Let Base(x)
    If UsaDSN = false and Carpeta > "" and inStr( x, Carpeta ) = 0 Then
      x = Carpeta & "\" & x
      If inStr( x, "." ) = 0 Then x = x & ".mdb"
    End If
    m_Base = x
  End Property
  
  Public Property Get Tabla()
    Tabla = m_Tabla
  End Property
  Public Property Let Tabla(x)
    m_Tabla = x
  End Property
  
  Public Property Get Clave()
    Clave = m_Clave
  End Property
  Public Property Let Clave(x)
    m_Clave = x
  End Property
  
  Public Property Get TipoClave()
    TipoClave = m_TipoClave
  End Property
  Public Property Let TipoClave(x)
    m_TipoClave = x
  End Property
  
  Public Property Get UsaDSN()
    UsaDSN = m_DSN
  End Property
  Public Property Let UsaDSN(x)
    m_DSN = x
  End Property
    
  Public Property Get NomDSN()
    NomDSN = m_NomDSN
  End Property
  Public Property Let NomDSN(x)
    m_NomDSN = x
  End Property

  Public Property Get GrAdd()
    GrAdd = m_Add
  End Property
  Public Property Let GrAdd(x)
    m_Add = x
  End Property
  
  Public Property Get GrDel()
    GrDel = m_Del
  End Property
  Public Property Let GrDel(x)
    m_Del = x
  End Property
  
  Public Property Get GrEdit()
    GrEdit = m_Edit
  End Property
  Public Property Let GrEdit(x)
    m_Edit = x
  End Property

  Public Property Get GrCampos()
    GrCampos = m_Campos
  End Property
  Public Property Let GrCampos(x)
    m_Campos = x
  End Property

  Public Property Get GrTbl()
    GrTbl = m_Tbl
  End Property
  Public Property Let GrTbl(x)
    m_Tbl = x
  End Property
  
  Public Property Get GrRes()
    GrRes = m_Res
  End Property
  Public Property Let GrRes(x)
    m_Res = x
  End Property

  Public Property Get GrBusca()
    GrBusca = m_Busca
  End Property
  Public Property Let GrBusca(x)
    m_Busca = x
  End Property

  Public Property Get GrCampSel()
    GrCampSel = m_CampSel
  End Property
  Public Property Let GrCampSel(x)
    m_CampSel = x
  End Property
  
  Public Property Get GrQSParams()
    GrQSParams = m_GrQSParams
  End Property
  Public Property Let GrQSParams(x)
    m_GrQSParams = x
  End Property
  
  Public Property Get GrUsaSQL()
    GrUsaSQL = m_GrSQL
  End Property
  Public Property Let GrUsaSQL(x)
    m_GrSQL = x
  End Property
  
  Public Property Get GrEstilo()
    GrEstilo = m_GrEstilo
  End Property
  Public Property Let GrEstilo(x)
    m_GrEstilo = x
  End Property

  Public Property Get GrWidth()
    GrWidth = m_GrWidth
  End Property
  Public Property Let GrWidth(x)
    If x > 0 and x < 300 Then x = 300
    m_GrWidth = x
  End Property
  
  Public Property Get GrNumRes()
    GrNumRes = m_GrNumRes
  End Property
  Public Property Let GrNumRes(x)
    If x < 3 Then x = 3
    m_GrNumRes = x
  End Property

  Public Property Get GrCorte()
    GrCorte = m_GrCorte
  End Property
  Public Property Let GrCorte(x)
    If x < 15 Then x = 15
    m_GrCorte = x
  End Property
  
  Public Property Get GrOrden()
    GrOrden = m_GrOrden
  End Property
  Public Property Let GrOrden(x)
    m_GrOrden = x
  End Property
  
  Public Property Get GrTipoCol()
    GrTipoCol = m_GrTipoCol
  End Property
  Public Property Let GrTipoCol(x)
    m_GrTipoCol = x
  End Property

  Public Property Get VerTipos()
    VerTipos = m_VerTipos
  End Property
  Public Property Let VerTipos(x)
    m_VerTipos = x
  End Property

  Public Property Get Colors()
    Colors = aColors
  End Property
  Public Property Let Colors(x)
    If isArray(x) Then aColors = x
  End Property

  Public Property Get ErrMsg()
    ErrMsg = m_ErrMsg
  End Property
  Public Property Let ErrMsg(x)
    m_ErrMsg = x
  End Property
  
  Public Property Get Credits()
    Credits = "Ramon Molins, 2003<br>ramon@fotonostra.com" 
  End Property
  
  Public Function Archivos(m_Carpeta)
    On Error Resume Next
    LimpiaError
    Dim TmpCnt, FSO, oFolder, file, folder
    Set FSO = Server.CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(m_Carpeta) Then
      Set oFolder = FSO.GetFolder(m_Carpeta)
      For each file in oFolder.Files
        If Right(file.name, 4) = ".mdb" Then
          If Ubound(aBases)=0 and aBases(0) = "" Then
            aBases(0) = oFolder & "\" & file.Name
          else
            TmpCnt = (Ubound(aBases)+1)
            ReDim Preserve aBases(TmpCnt)
            For i = LBound(aBases) to UBound(aBases)
              If aBases(i) = "" Then aBases(i) = oFolder & "\" & file.Name
            Next
            TmpCnt = ""
          End if 
        End if
      next
      For each folder in oFolder.SubFolders
        Archivos(folder)
      Next
    else
      ErrMsg = "La ruta de acceso es incorrecta"
    End If
    set oFolder = nothing
    Set FSO = nothing
    Archivos = aBases 
    TmpCnt = ""
    MkError
  End Function

  Public Function Tablas()
    On Error Resume Next
    LimpiaError
    Dim TmpCnt
    AbreMDB
    If isObject(oConn) Then 
      Set RS = oConn.OpenSchema(adSchemaTables)
      With RS
        Do While Not .EOF
        If .Fields("TABLE_TYPE") = "TABLE" Then
          If Ubound(aTablas)=0 and aTablas(0) = "" Then
            aTablas(0) = .Fields("TABLE_NAME")
          else
            TmpCnt = (Ubound(aTablas)+1)
            ReDim Preserve aTablas(TmpCnt)
            For i = LBound(aTablas) to UBound(aTablas)
              If aTablas(i) = "" Then aTablas(i) = .Fields("TABLE_NAME")
            Next
          End if 
        End If 
        .MoveNext
        Loop
      End With
      RS.Close
      Set RS = nothing
    End if
    CierraMDB
    Tablas = aTablas
    TmpCnt = ""
    MkError
  End Function

  Public Sub Campos()
    On Error Resume Next
    LimpiaError
    AbreMDB
    If isObject(oConn) Then 
      Set RS = Server.CreateObject("ADODB.Recordset")
      RS.Open "SELECT * FROM " & Tabla & ";", oConn, adOpenStatic, adLockReadOnly, adCmdText
      ReDim Preserve aCampos(Rs.fields.count-1,3)
      i = 0
      For Each Thing in RS.Fields
        aCampos(i,0) = Thing.name
        aCampos(i,1) = Thing.type
        aCampos(i,2) = Thing.definedsize
        i = i + 1
      Next
      RS.Close
      Set RS = nothing
    End if
    CierraMDB
    MkError
  End Sub

  Public Function Registros()
    On Error Resume Next
    LimpiaError
    SQL = "SELECT * FROM " & Tabla
    If GrUsaSQL<>"" Then SQL = SQL & " WHERE " & GrUsaSQL
    AbreMDB
    If isObject(oConn) Then 
      Set RS = Server.CreateObject("ADODB.Recordset")
      RS.Open SQL, oConn, adOpenStatic, adLockReadOnly, adCmdText
      If RS.EOF Then
        ErrMsg = "No hay registros que mostrar"
      End If
      Set Registros = RS
      Set RS = nothing
    End if
    MkError
  End Function

  Public Function MkHtml()
    On Error Resume Next
    LimpiaError
    Dim c, v, nom, lnk, m_Clave, m_pAct, m_pCnt, m_pSize, m_Mostrar, m_Estilo, m_Orden, m_TipCol, tmpCol
    m_Clave = true
    m_Mostrar = 0
    m_Estilo = ""
    If GrEstilo <> "" Then m_Estilo = " class=""" & GrEstilo & """"
    m_TipCol = GrTipoCol
    If Request("tc")<>"" Then m_TipCol = Request("tc")
    m_pSize = GrNumRes
    HayClave
    If GrCampSel<>"*" and inStr( lCase(GrCampSel), lCase(Clave) ) = 0 Then
      m_Clave = false
      SQL = "SELECT " & Clave & "," & GrCampSel & " FROM " & Tabla
    Else
      SQL = "SELECT " & GrCampSel & " FROM " & Tabla
    End If
    If GrUsaSQL<>"" Then SQL = SQL & " WHERE " & GrUsaSQL
    m_Orden = Request("ord")
    If m_Orden <> "" Then SQL = SQL & " ORDER BY " & m_Orden
    If inStr( lCase(GrUsaSQL), "order by" )>0 Then
      m_Orden = mid( GRUsaSQL, inStr( lCase(GrUsaSQL), "order by" )+9 )
      c = c & "<script>f1.ord.value='" & m_Orden & "'</script>" & vbCrLf
    End IF
    AbreMDB
    If isObject(oConn) Then
      Set RS = Server.CreateObject("ADODB.Recordset")
      RS.Open SQL, oConn, adOpenStatic, adLockReadOnly, adCmdText
      If RS.EOF = true Then
        ErrMsg = "No hay registros que mostrar"
      Else with RS
        If Request("pag") = "" Then
          m_pAct = 1
        Else
          m_pAct = CInt(Request("pag"))
        End If
        .PageSize = m_pSize
        m_pCnt = .PageCount
        If m_pAct > m_pCnt Then m_pAct = m_pCnt
        If m_pAct < 1 Then m_pAct = 1
        .CacheSize = m_pSize
        If m_pCnt = 0 Then
          ErrMsg = "No hay registros que mostrar"
        Else
          .AbsolutePage = m_pAct
          c = c & "<script>function confirma(x){cnf=confirm('Se eliminará el registro \n"
          c = c & Clave & " = '+x);if(cnf==true){f1.rtn.value='del';f1.id.value=x;f1.submit();}}</script>" & VbCrLf
          c = c & "<table cellspacing='1' cellpadding='0' bgcolor='#" & aColors(0) & "' width='" & GrWidth & "'>" & vbCrLf
          If GrBusca or GrRes Then
            c = c & "<tr" & m_Estilo & ">"
            If GrTbl Then c = c & "<td align='center' style='padding-top:1px' nowrap>" & MkTbl & "&nbsp;</td>" & vbCrLf
            If GrRes Then c = c & "<td align='center' style='padding-top:1px' nowrap>" & MkRes & "&nbsp;</td>" & vbCrLf
            If GrBusca Then c = c & "<td align='center' style='padding-top:1px' nowrap>" & MkBusca & "</td>"
          End If
          c = c & "</tr></table>" & vbCrLf
          If GrWidth>0 Then
            c = c & "<div align='left'" & vbCrLf
            c = c & "style='width:" & GrWidth & "px;overflow:scroll;background-color:#" & aColors(4)
            c = c & ";border-style:solid;border-width:1px;border-top-width:0px;border-color:#" & aColors(0) & "'>"
          End If
          c = c & "<table cellspacing='1' bgcolor='#" & aColors(0) & "'>" & vbCrLf
          c = c & "<tr bgcolor='#" & aColors(2) & "'>" & VbCrLf
          If GrEdit Then
            c = c & "<td" & m_Estilo & ">"
            If GrOrden Then
              c = c & BtnImg( "Orden Natural", "ord", "", -1, "natural.gif" )
            End If
            c = c & "</td>" & VbCrLf
            If m_TipCol Then tmpCol = tmpCol & "<td" & m_Estilo & "></td>" & VbCrLf
          End If
          For Each Thing in .Fields
            If m_Clave or Thing.Name <> Clave Then
              c = c &  "<td" & m_Estilo & " nowrap"
              If Thing.Name = Clave Then c = c & " bgColor='#" & aColors(7) & "'"
              c = c &  "><font color='#" & aColors(1) & "'>"
              If GrOrden Then
                c = c & BtnImg( "Orden ascendente", "ord", Thing.Name & " ASC;", -1, "up.gif" )
                c = c & BtnImg( "Orden descendente", "ord", Thing.Name & " DESC;", -1, "down.gif" ) & vbCrLf
              End If
              c = c & "<b>" & Thing.Name & "</b>&nbsp;</td>" & VbCrLf
              If m_TipCol Then
                tmpCol = tmpCol & "<td" & m_Estilo
                If GrWidth>0 Then tmpCol = tmpCol & " nowrap"
                tmpCol = tmpCol & "><font size='-2'>" & TipoCampo(Thing) & "</font></td>"
              End If
            End If
          Next
          If GrDel or VerTipos Then
            c = c &  "<td" & m_Estilo & ">"
            If VerTipos Then
              c = c & BtnImg( "Mostrar/ocultar tipos", "tc", (not m_TipCol), -1, "types.gif" )
            End If
            c = c & "</td>" & VbCrLf
            If m_TipCol Then tmpCol = tmpCol & "<td" & m_Estilo & "></td>" & VbCrLf
          End If
          c = c & "</tr>" & VbCrLf
          If m_TipCol Then
            c = c & "<tr bgcolor='#" & mid(aColors(4),3) & left(aColors(2),2) & "'>" & tmpCol & "</tr>" & VbCrLf
          End If
          Do While m_Mostrar < m_pSize And Not .EOF
            c = c & "<tr bgcolor='#" & aColors(4) & "'>" & VbCrLf
            If GrEdit Then
              c = c & "<td" & m_Estilo & " valign='top'>"
              c = c & BtnImg( "Editar registro " & RS(Clave), "rtn", "edit", RS(Clave), "edit.gif" )
              c = c & "</td>" & VbCrLf
            End if
            For Each Thing in .Fields
              nom = lCase( Thing.name )
              lnk = false
              v = Thing.value
              If m_Clave or Thing.name <> Clave Then
                c = c & "<td" & m_Estilo & " valign='top'"
                for i = 0 to UBound(aTiposNum)
                  If aTiposNum(i) = Thing.Type Then
                    c = c & " align='right'"
                  End If
                Next
                If Thing.name = Replace( Replace( m_Orden, " ASC;", "" ), " DESC;", "" ) Then
                  If inStr(m_Orden, " DESC")=0 Then
                    c = c & " bgColor='#" & aColors(5) & "'"
                  Else
                    c = c & " bgColor='#" & aColors(6) & "'"
                  End If
                End If
                If GrWidth>0 and GrCorte=cInt(GrCorte) Then c = c & " nowrap"
                c = c & ">"
                If Thing.Type = "202" or Thing.Type = "203" Then
                  If left(v,4)="http" or left(v,4)="ftp:" or left(v,7)="mailto:" Then
                    lnk = true
                    c = c & "<a href='" & v & "' target='_new'>"
                  ElseIf inStr( nom, "url" )>0  or inStr( nom, "web" )>0 or inStr( nom, "link" )>0 Then
                    lnk = true
                    c = c & "<a href='http://" & v & "' target='_new'>"
                  ElseIf inStr( nom, "ftp" )>0 Then
                    lnk = true
                    c = c & "<a href='ftp://" & v & "' target='_new'>"
                  ElseIf inStr( v, "@" )>0  or inStr( nom, "mail" )>0 Then
                    lnk = true
                    c = c & "<a href='mailto:" & v & "'>"
                  End If
                End If
                c = c & "<font color='#" & aColors(3) & "'>"
                If inStr( v, "<" ) > 0 Then
                  c = c & Server.HTMLEncode( Left(v,GrCorte) )
                Else
                  c = c & Left(v,GrCorte)
                End If
                If Len(v) > GrCorte Then c = c &  "..."
                c = c & "&nbsp;</font>"
                If lnk Then c = c & "</a>"
                c = c & "</td>" & VbCrLf
              End If
            Next
            If GrDel or VerTipos Then
              c = c & "<td" & m_Estilo & ">"
              If GrDel Then
                c = c & "<a href='javascript:confirma(" & chr(34) & RS(Clave) & chr(34) & ");'>"
                c = c & "<img src='images/del.gif' width='12' heigh='12' border='0'" & VbCrLf
                c = c & "alt='Borrar registro " & RS(Clave) & "' vspace='1' hspace='1'></a>"
              End If
              c = c & "</td>" & VbCrLf
            End if
            c = c & "</tr>" & VbCrLf
          m_Mostrar = m_Mostrar + 1
          .MoveNext
          Loop
        End if
        If m_Mostrar < GrNumRes Then
          for i = m_Mostrar + 1 to GrNumRes
            c = c & "<tr" & m_Estilo & "><td height='16'>&nbsp;</td></tr>" & vbCrLf
          Next
        End If
        c = c & "</table>" & vbCrLf
        If GrWidth>0 Then c = c & "</div>" & vbCrLf
        c = c & "<table cellspacing='1' cellpadding='0' bgcolor='#" & aColors(0) & "' width='" & GrWidth & "'>" & vbCrLf
        c = c & "<tr" & m_Estilo & "><td align='center' bgcolor='#" & aColors(7) & "' width=48 nowrap>" & vbCrLf
        c = c & "<a href='https://www.fotonostra.com/dbgrid' target='_blank'>dbGrid</a></td>" & vbCrLf
        c = c & "<td align='center' bgcolor='#" & aColors(6) & "' nowrap>" & vbCrLf
        c = c & "&nbsp;Regs:<b> " & .RecordCount & "&nbsp;</b></td>" & vbCrLf
        c = c & "<td align='center' bgcolor='#" & aColors(5) & "' nowrap>" & vbCrLf
        c = c & "&nbsp;Págs:<b> " & m_pCnt & "&nbsp;</b></td>" & vbCrLf
        c = c & "<td align='center' width='50%' nowrap>&nbsp;" & vbCrLf
        End With
        RS.Close
        Set RS = nothing
        CierraMDB
        If m_pAct > 1 Then
          c = c & BtnImg( "Primera", "pag", 1, -1, "pgin1.gif" ) & vbCrLf
          c = c & BtnImg( "Anterior", "pag", m_pAct - 1, -1, "pgup1.gif" ) & vbCrLf
        Else
          c = c & BtnImg( "Primera", "", 0, -1, "pgin2.gif" ) & vbCrLf
          c = c & BtnImg( "Anterior", "", 0, -1, "pgup2.gif" ) & vbCrLf
        End If
        c = c & "&nbsp; <SELECT name='pag' style='font-size:10px;font-family:Verdana'" & vbCrLf
        c = c & "onChange='f1.submit()'>" & vbCrLf
        For i = 1 to m_pCnt
          c = c & "<OPTION value='" & i & "'"
          If i = m_pAct Then c = c & " SELECTED"
          c = c & ">" & i & "&nbsp; </OPTION>" & vbCrLf
        Next
        c = c & "</SELECT> &nbsp;" & vbCrLf
        If m_pAct < m_pCnt Then
          c = c & BtnImg( "Siguiente", "pag", m_pAct + 1, -1, "pgdn1.gif" ) & vbCrLf
          c = c & BtnImg( "Última", "pag", m_pCnt, -1, "pgfi1.gif" ) & vbCrLf
        Else
          c = c & BtnImg( "Siguiente", "", 0, -1, "pgdn2.gif" ) & vbCrLf
          c = c & BtnImg( "Última", "", 0, -1, "pgfi2.gif" ) & vbCrLf
        End If
        c = c & "&nbsp;</td><td align='right' valign='bottom' nowrap>" & vbCrLf
        If GrAdd Then
          c = c & Boton( "Añadir", "rtn", "add" ) & vbCrLf
        End if
        If GrCampos Then
          c = c & Boton( "Columnas", "rtn", "camp" ) & vbCrLf
        End if
        c = c & "</td></tr></table>" & vbCrLf
      End If
    else
      If UsaDSN Then
        ErrMsg = "Falló la conexión con la Base de Datos (DSN)"
      else
        ErrMsg = "Falló la conexión con la Base de Datos (Ruta)"
      End if
    End if
    MkHtml = c
    MkError
  End Function

  Public Function HayClave()
    On Error Resume Next
    LimpiaError
    Dim c, PKSQL, PKRS, oPKConn
    Clave = ""
    HayClave = false
    If Tabla = "" Then Exit Function
    Set oPKConn = Server.CreateObject("ADODB.Connection")
    If UsaDSN Then
      oPKConn.Open NomDSN
      Set PKRS = Server.CreateObject("ADODB.Recordset")
      PKRS.Open "SELECT * FROM " & Tabla, oPKConn, adOpenStatic, adLockReadOnly, adCmdText
      With PKRS
        For each Thing in .Fields
          if Thing.Type = "2" or Thing.Type = "3" Then
            Clave = Thing.Name
            HayClave = true
            Exit For
          End If
        Next
        If Clave = "" Then
          Clave = .Fields(0).Name
          HayClave = true
        End If
      End With
    Else
      oPKConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Base
      If isObject(oPKConn) Then
        Set PKRS = oPKConn.OpenSchema(adSchemaPrimaryKeys)
        With PKRS
          Do While Not .EOF
            If lCase(.Fields("TABLE_NAME")) = lCase(Tabla) Then
              Clave = .Fields("COLUMN_NAME")
              HayClave = true
            End If
          .MoveNext
          Loop 
        End With
      End If
    End If
    PKRS.Close
    Set PKRS = nothing
    If HayClave Then
      PKSQL = "SELECT * FROM " & Tabla & ";"
      Set PKRS = Server.CreateObject("ADODB.RecordSet")
      PKRS.Open PKSQL,oPKConn
      With PKRS
        For each Thing in .Fields
          if lCase(Thing.Name) = lCase(Clave) Then c = Thing.Type
        Next
      End With
      PKRS.Close
      Set PKRS = nothing
      for i = 0 to UBound(aTiposNum)
        If aTiposNum(i) = c Then c = "numeric"
      Next
      If c <> "numeric" Then c = "text"
      TipoClave = c
    else
      ErrMsg = "No hay clave primaria"
    End If
    If not isObject(oPKConn) Then
      If UsaDSN = true Then
        ErrMsg = "Falló la conexión DSN"
      else
        ErrMsg = "Falló la conexión con la Base de Datos"
      End if
    End If
    oPKConn.Close
    Set oPKConn = nothing
    MkError
  End Function

  Public Function Editar(Tipo)
    On Error Resume Next
    LimpiaError
    Dim c, m_Estilo
    m_Estilo = ""
    HayClave
    if GrEstilo <> "" Then m_Estilo = " class=""" & GrEstilo & """"
    If Tipo = "add" Then
      SQL = "SELECT * FROM " & Tabla
    elseif TipoClave = "numeric" Then
      SQL = "SELECT * FROM " & Tabla & " WHERE " & Clave & "= " & m_ID & ";"
    elseif TipoClave = "text" Then
      SQL = "SELECT * FROM " & Tabla & " WHERE " & Clave & "= '" & m_ID & "';"
    elseif Clave = "" Then
      ErrMsg = "No se ha encontrado una clave primaria"
      Exit Function
    End if
    AbreMDB
    If isObject(oConn) Then 
      Set RS = Server.CreateObject("ADODB.Recordset")
      RS.Open SQL, oConn, adOpenStatic, adLockReadOnly, adCmdText
      With RS
        If .EOF and Tipo = "edit" Then
          ErrMsg = "No hay datos que mostrar"
        End If
        IF Tipo = "add" and HayClave and TipoClave = "numeric" Then
          If .EOF Then
            m_ID = 1
          Else
            .moveLast
            m_ID = RS(Clave) + 1
            .moveFirst
          End If
        End If
        c = c & "<table cellspacing='1' cellpadding='1' bgcolor='#" & aColors(2) & "'>" & VbCrLf
        c = c & "<tr><td" & m_Estilo & " align='center' colspan='2' bgcolor='#" & aColors(7) & "'>" & VbCrLf
        c = c & "<font color='#" & aColors(1) & "'>Tabla: <b>" & Tabla & " &nbsp; </b>| &nbsp;" & VbCrLf
        If Tipo = "add" Then
          c = c & "Añadir"
        Else
          c = c & "Modificar"
        End If
        c = c & " Registro</font></td></tr>" & VbCrLf
        For each Thing in .Fields
          c = c & "<tr><td" & m_Estilo & " align='right' height='22'>"
          c = c & "<font color='#" & aColors(1) & "'>&nbsp;"
          c = c & Thing.name & "&nbsp;</td>" & VbCrLf & "<td" & m_Estilo & ">"
          If Thing.Name = Clave Then
            If Tipo = "add" and TipoClave = "numeric" Then
              c = c & "<b> Clave: (autonumérico)</b>" & VbCrLf
              c = c & "<input type='hidden' name='x_" & Thing.Name & "' id='x_" & Thing.Name
              c = c & "' value='" & m_ID & "'>"
            Else
              c = c & MkCampo(Thing,Tipo) & "<b> Clave: " & Thing.Value & "</b>" & VbCrLf
            End If
          Else
            c = c & MkCampo(Thing,Tipo)            
          End if
          c = c & "</td></tr>" & VbCrLf
        Next
        c = c & "<tr><td" & m_Estilo & " colspan='2' align='center' height='32'>"
        c = c & Boton( "Volver", "rtn", "tbl" ) & "&nbsp;" & VbCrLf
        c = c & "<input type='reset' value='Deshacer'> &nbsp; &nbsp; &nbsp; &nbsp;" & VbCrLf
        If Tipo = "add" Then
          c = c & Boton( "Guardar cambios", "rtn", "eau" ) & VbCrLf
        Else
          c = c & Boton( "Guardar cambios", "rtn", "eu" ) & VbCrLf
        End If
        c = c & "</td></tr></table>" & VbCrLf
        c = c & "<script>f1.x_" & RS.Fields(1).Name & ".focus();</script>" & vbCrLf
      End with
      RS.Close
      Set RS = nothing
    End if
    CierraMDB
    Editar = c
    MkError
  End Function  

  Public Function Salvar(Tipo)
    Dim c, cTxt
    HayClave
    AbreMDB
    If isObject(oConn) Then
      If Tipo = "add" Then
        SQL = "SELECT * FROM " & Tabla
      ElseIf TipoClave = "numeric" Then
        SQL = "SELECT * FROM " & Tabla & " WHERE " & Clave & "= " & m_ID & ";"
      ElseIf TipoClave = "text" Then
        SQL = "SELECT * FROM " & Tabla & " WHERE " & Clave & "= '" & m_ID & "';"
      End if
      Set RS = Server.CreateObject("ADODB.Recordset")
      RS.Open SQL, oConn, adOpenKeyset, adLockPessimistic
      With RS
        If Tipo = "add" Then
          .AddNew
        End if
        For each Thing in .Fields
          If Thing.Name <> Clave or (Tipo = "add" and TipoClave = "numeric") Then
            cTxt = Request("x_" & Thing.Name)
            On Error Resume Next
            If cTxt<>"" Then
              If Thing.Type = "202" or Thing.Type = "203" Then
                If len( cTxt ) > Thing.DefinedSize Then cTxt = left( cTxt, Thing.DefinedSize )
              End If
              RS(Thing.Name) = cTxt
            Else
              RS(Thing.Name) = null
            End If
            On Error Goto 0
          End if
        Next
        .UpDate  
      End with
      RS.Close
      Set RS = nothing
    End If
    CierraMDB
    If Tipo ="add" and ErrMsg = "" Then
      c = c & "El registro se ha añadido correctamente" & Volver
    elseif ErrMsg = "" Then
      c = c & "El registro se ha modificado correctamente" & Volver
    end if
    Salvar = "<font size='2'>" & c & "</font>"
  End Function

  Public Function MkCampo(m_Campo,Tipo)
    Dim c, v, xy
    c = "x_" & m_Campo.Name
    v = ""
    If Tipo="edit" Then v = m_Campo.Value
    If m_Campo.Name = Clave Then
      If Tipo="edit" Then
        MkCampo = "<input type='hidden' name='" & c & "' id='" & c & "' value='" & v & "'>"
      End if
    else
      If m_Campo.Type = "203" Then
        MkCampo = "<textarea cols='71' rows='5' name='" & c & "' id='" & c & "'>"  
        If Tipo="edit" Then MkCampo = MkCampo & v
        MkCampo = MkCampo & "</textarea>&nbsp;" & vbCrLf
      else
        xy = cInt( cStr( m_Campo.DefinedSize * 1.1 ) ) + 5
        If xy > 71 Then xy = 71 End If
        MkCampo = "<input type='text' size=" & xy & " name='" & c & "' id=" & chr(34) & c
        If Tipo="edit" Then MkCampo = MkCampo & chr(34) & " value=" & chr(34) & v
        MkCampo = MkCampo & chr(34) & ">&nbsp;"  
      End if
    End if
  End Function

  Public Function Borrar(m_ID)
    LimpiaError
    HayClave
    If TipoClave = "numeric" Then
      SQL = "DELETE FROM " & Tabla & " WHERE " & Clave & "= " & m_ID & ";"
    elseif TipoClave = "text" Then
      SQL = "DELETE FROM " & Tabla & " WHERE " & Clave & "= '" & m_ID & "';"
    End if
    AbreMDB
    If isObject(oConn) Then 
      oConn.Execute(SQL)
    End if
    CierraMDB
    Borrar = "<font size='2'>Se ha borrado el registro: " & Clave & " = " & m_ID & "</font>" & Volver & vbCrLf
  End Function

  Public Function TipoCampo(m_Campo)
    Dim t, n
    n = m_Campo.Type
    select case n
      case 0:    t = "Empty"
      case 2:    t = "Pequeño"
      case 3:    t = "Entero"
      case 4:    t = "Single"
      case 5:    t = "Doble"
      case 6:    t = "Moneda"
      case 7:    t = "Fecha"
      case 8:    t = "BSTR"
      case 9:    t = "IDispatch"
      case 10:   t = "Error"
      case 11:   t = "Booleano"
      case 12:   t = "Variant"
      case 13:   t = "IUnknown"
      case 14:   t = "Decimal"
      case 16:   t = "TinyInt"
      case 17:   t = "UnsignedTinyInt"
      case 18:   t = "UnsignedSmallInt"
      case 19:   t = "UnsignedInt"
      case 20:   t = "BigInt"
      case 21:   t = "UnsignedBigInt"
      case 72:   t = "GUID"
      case 128:  t = "Binario"
      case 129:  t = "Caracter"
      case 130:  t = "WChar"
      case 131:  t = "Numérico"
      case 132:  t = "UserDefined"
      case 133:  t = "DBDate"
      case 134:  t = "DBTime"
      case 135:  t = "Fecha"
      case 200:  t = "VarChar"
      case 201:  t = "LongVarChar"
      case 202:  t = "Texto"
      case 203:  t = "Memo"
      case 204:  t = "VarBinary"
      case 205:  t = "LongVarBinary"
      case else: t = "(" & f & ")"
      end select
      n =  m_Campo.Precision
      if n>0 and n<99 Then
      t = t & " | " & n
      n = m_Campo.NumericScale
      if n>0 and n<99 Then t = t & n
    end if
    n =  m_Campo.DefinedSize
    if n>0 and n<9999 Then t = t & " (" & n & ")"
    TipoCampo = t
  End Function

  Public Function MkCampSel()
    Dim c, s
    Campos
    HayClave
    s = uBound( aCampos ) + 1
    If s > 20 Then s = 20
    If s < 10 Then s = 10
    c = "<table width='242' cellpadding='2' cellspacing='3' bgcolor='#" & aColors(2) & "'><tr>" & vbCrLf
    If GrTbl Then
      c = c & "<td align='center' bgcolor='#" & aColors(7) & "'>" & VbCrLf
      c = c & "<font size='2' color='#" & aColors(1) & "'>Tabla: <b>" & Tabla & "</font></td></tr><tr>" & VbCrLf
    End If
    c = c & "<td align='center' nowrap><font color='#" & aColors(1) & "'>Seleccionar columnas" & VbCrLf
    c = c & "<font face ='Arial' size='1'><br>Control o Mayúsculas para selección múltiple</font></font>" & VbCrLf
    c = c & "<br><SELECT name='cFld' multiple style='font-size:12px;width:216;margin:6px' size='" & s & "'>" & vbCrLf
    For i = 0 to UBound(aCampos)
      c = c & "<OPTION value='" & aCampos(i,0) & "'"
      If inStr( GrCampSel, aCampos(i,0) ) >0 Then c = c & " SELECTED"
      c = c & ">" & aCampos(i,0) & "&nbsp; </OPTION>" & vbCrLf
    Next
    c = c & "</SELECT><br><br>" & vbCrLf
    c = c & "<input type='button' value='Todas' onClick=" & chr(34) & "f1.cFld.selectedIndex=-1;"
    c = c & "f1.rtn.value='tbl';f1.submit()" & chr(34) & "> &nbsp; &nbsp;" & VbCrLf
    c = c & Boton( "Aplicar selección", "rtn", "tbl" ) & "</td></tr></table>" & VbCrLf
    MkCampSel = c
  End Function

  Public Function MkTbl()
    Dim c
    c = "Tabla:" & VbCrLf
    c = c & "<SELECT name='Tbl' onChange=" & chr(34) & "f1.ord.value='';"
    c = c & "f1.cSql.value='';f1.cFld.value='';f1.pag.value=1;f1.submit()" & chr(34) & ">" & vbCrLf
    For i = 0 to UBound(aTablas)
      c = c & "<OPTION value='" & aTablas(i) & "'"
      If lCase( aTablas(i) ) = lCase( Tabla ) Then c = c & " SELECTED"
      c = c & ">" & aTablas(i) & "&nbsp; </OPTION>" & vbCrLf
    Next
    c = c & "</SELECT>" & vbCrLf
    MkTbl = c
  End Function

  Public Function MkRes()
    Dim c, predet
    predet = true
    For i = 0 to UBound(aRes)
      If aRes(i) = tmpNumRes Then predet = false
    Next
    If predet Then
      Redim preserve aRes( uBound(aRes)+1 )
      aRes( uBound(aRes) ) = tmpNumRes
      For i = uBound(aRes) to 0 step -1
        If tmpNumRes>aRes(i) Then
          aRes(i+1) = tmpNumRes
          Exit For
        Else
          if i>0 Then
            aRes(i) = aRes(i-1)
          Else
            aRes(0) = tmpNumRes
          End If
        End If
      Next
    End If
    c = "Mostrar:" & VbCrLf
    c = c & "<SELECT name='nRes' onChange='f1.submit()'>" & vbCrLf
    For i = 0 to uBound(aRes)
      c = c & "<OPTION value=" & aRes(i)
      If aRes(i) = GrNumRes Then c = c & " SELECTED"
      c = c & ">" & aRes(i) & "&nbsp;</OPTION>" & vbCrLf
    Next
    c = c & "</SELECT>" & vbCrLf
    MkRes = c
  End Function

  Public Function MkBusca()
    Dim c, n
    n = Int(GrWidth/15)
    If n > 36 Then n = 36
    c = c & "<INPUT type='text' name='cSql' size='" & n & "' value='" & Request("cSql") & "'>&nbsp;" & vbCrLf
    c = c & "<INPUT type='submit' name='buscar' value='Buscar'>&nbsp;" & vbCrLf
    If GrUsaSQL<>"" and left( GrUsaSQL, 4 )<>"true" Then
      c = c & "<INPUT type='button' name='todos' value='Todos'"
      c = c & "onClick='f1.cSql.value=" &chr(34) & chr(34) & ";f1.submit()'>"
    End If
    MkBusca = c
  End Function

  Private Function Boton(nombre,objeto,valor)
    Dim c
    c = "<input type='button' name='" & nombre & "' value='" & nombre & "' "
    c = c & "onClick='f1." & objeto & ".value=" & chr(34) & valor & chr(34) & ";f1.submit()'>"
    Boton = c
  End Function

  Private Function BtnTxt(nombre,objeto,valor)
    Dim c
    c = "<a href='' onClick='f1." & objeto & ".value=" & chr(34) & valor & chr(34)
    c = c & ";f1.submit();return false'>" & nombre & "</a>"
    BtnTxt = c
  End Function

  Private Function BtnImg(nombre,objeto,valor,id,imagen)
    Dim c
    c = ""
    If objeto<>"" Then
      c = c & "<a href='' onClick='f1." & objeto & ".value=" & chr(34) & valor &chr(34)
      c = c & ";f1.id.value=" & chr(34) & id &chr(34) & ";f1.submit();return false'>"
    End If
    c = c & "<img src='images/" & imagen & "' width='12' heigh='12' border='0'" & VbCrLf
    If left( imagen, 2 ) = "pg" Then
      c = c & "align='middle'"
    Else
      c = c & "align='absmiddle'"
    End If
    c = c & " alt='" & nombre & "' vspace='1' hspace='1'>"
    If objeto<>"" Then c = c & "</a>"
    BtnImg = c
  End Function

  Private Function Volver()
    Dim c
    c = "<script>setTimeout('f1.rtn.value=" & chr(34) & "tbl" & chr(34) & ";f1.submit()',1200 )</script>" & vbCrLf
    c = c & "<br>[ <a href='' onClick='f1.rtn.value=" & chr(34) & "tbl" & chr(34) & ";f1.submit();return false'>"
    c = c & "<b>Volver</b></a> ]" & vbCrLf
    Volver = c
  End Function

  Public Sub AbreMDB()
    Set oConn = Server.CreateObject("ADODB.Connection")
    If UsaDSN = true and NomDSN <> "" Then
      oConn.Open "DSN=" & NomDSN
    else
      oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Base
    End If
  End Sub

  Public Sub CierraMDB()
    oConn.Close
    Set oConn = nothing
  End Sub

  Public Sub MkSql(cSql)
    Dim c, cmp, aCmp
    c = ""
    cmp = false
    aCmp = array( "LIKE ", "=", ">", "<", ">=", "<=", "<>", "IsNull" )
    Campos
    If cSql <> "" Then
      for i = 1 to uBound( aCmp )
        If inStr( cSql, aCmp(i) ) > 0 Then cmp = true
      Next
      If cmp Then
        c = c & Replace( cSql, chr(34), "'" )
      Else
        for i = 0 to ubound(aCampos) - 1
          c = c & aCampos(i,0) & "&'-'&"
        next
        c = c & aCampos(i,0) & " LIKE '%" & cSql & "%'"
      End If
    End If
    GrUsaSQL = c
  End Sub

  Public Sub Activar()
    Dim c, aBas, aTbl, rtn, ord, pag, tc, cSel, cFld, nRes, cSql
    If GrQSParams <> "" and Not Left(GrQSParams,0) = "?" Then GrQSParams = "?" & GrQSParams
    m_Link = Request.ServerVariables("SCRIPT_NAME") & GrQSParams
    m_ID = Request("id")
    rtn = Request("rtn")
    If Request("Base")<>"" Then Base = Request("Base")
    If Request("Tabla")<>"" Then Tabla = Request("Tabla")
    If Request("Tbl")<>"" Then Tabla = Request("Tbl")
    If Tabla <> "" and rtn = "" Then rtn = "tbl"
    ord = Request( "ord" )
    pag = Request( "pag" )
    tc = Request( "tc" )
    If GrBusca or rtn="ext" Then
      If Request("cSql")<>"" Then
        cSql = Request("cSql")
        MkSql( cSql )
      End If
    End If
    If not UsaDSN and Carpeta <> "" Then
      If Base = "" Then
        rtn = "fld"
      ElseIf Tabla = "" and rtn<>"eu" and rtn<>"eau" Then
        rtn = ""
      End If
    End If
    If GrEstilo = "dbg01" Then
      c = c & "<style type='text/css'>" & vbCrLf
      c = c & ".dbg01 { font-size: 12px; font-family: Arial, Helvetica, sans-serif}" & vbCrLf
      c = c & "</style>" & vbCrLf
    End If
    c = c & "<span style='display:none'><form action='" & m_Link & "' method='POST' name='f1' id='f1'>"
    If GrCampos or rtn="ext" Then
      cFld = Request("cFld")
      If cFld<>"" Then GrCampSel = cFld
    End If
    If GrCampSel = "" Then GrCampSel = "*"
    tmpNumRes = GrNumRes
    If GrRes Then
      If Request("nRes")<>"" Then
        nRes = Request("nRes")
        GrNumRes = cInt(nRes)
      End If
    End If
    If rtn<>"" and rtn<>"tbl" and rtn<>"ext" Then
      c = c & "<input type='hidden' name='pag' id='pag' value='" & pag & "'>" & VbCrLf
    End If
    If ( rtn<>"" and rtn<>"tbl" ) Then
      c = c & "<input type='hidden' name='nRes' id='nRes' value=" & nRes & ">" & VbCrLf
      c = c & "<input type='hidden' name='cSql' id='cSql' value='" & cSql & "'>" & VbCrLf
    End If
    c = c & "<input type='hidden' name='Id' id='id' value='" & m_ID & "'>" & VbCrLf
    c = c & "<input type='hidden' name='Base' id='Base' value='" & Base & "'>" & VbCrLf
    c = c & "<input type='hidden' name='Tabla' id='Tabla' value='" & Tabla & "'>" & VbCrLf
    c = c & "<input type='hidden' name='rtn' id='rtn' value='" & rtn & "'>" & VbCrLf
    c = c & "<input type='hidden' name='ord' id='ord' value='" & ord & "'>" & VbCrLf
    If rtn<>"camp" Then c = c & "<input type='hidden' name='cFld' id='cFld' value='" & cFld & "'>" & VbCrLf
    c = c & "<input type='hidden' name='tc' id='tc' value='" & tc & "'></span>" & VbCrLf
    Select Case rtn
      case "del":  c = c & Borrar(m_ID)
      case "add":  c = c & Editar("add")
      case "edit": c = c & Editar("edit")
      case "eau":  c = c & Salvar("add")
      case "eu":   c = c & Salvar("edit")
      case "camp": c = c & MkCampSel
      case "tbl", "ext":
        aTbl = Tablas
        c = c & MkHtml
      case "fld":
        aBas = Archivos(Carpeta)
        c = c & "Archivos en carpeta <b>" & mid( Carpeta, InStrRev( Carpeta, "\" ) + 1 ) & "</b><br><br>" & vbCrLf
        For i = 0 to UBound(aBas)
          aBas(i) = Replace( Replace(aBas(i),Carpeta & "\",""), "\", "/" )
          c = c & "&#149; " & BtnTxt( aBas(i), "Base", aBas(i) ) & "<br>" & vbCrLf
        Next
      case else
        aTbl = Tablas
        If GrTbl Then
          Tabla = aTbl(0)
          c = c & MkHtml
        Else
          If UsaDSN Then
            c = c & "<br><b>Tablas:</b><br><br>" & vbCrLf
          Else
            c = c & "Tablas en <b>" & mid( Base, InStrRev( Base, "/" ) + 1 ) & "</b><br><br>" & vbCrLf
          End If
          For i = 0 to UBound(aTbl)
            c = c & "&#149; " & BtnTxt( aTbl(i), "Tabla", aTbl(i) ) & "<br>" & vbCrLf
          Next
        End If
    End Select
    If ErrMsg = "" then
      Response.Write c
    else
      c = c & ErrMsg
      If inStr( ErrMsg, "No hay registros" ) > 0 Then
        If GrAdd Then c = c & " &nbsp; " & Boton( "Añadir", "rtn", "add" ) & vbCrLf
        If GrTbl Then
          c = c & "<br>Elegir otra <input type='hidden' name='cSql'>"
          c = c & "<input type='hidden' name='pag'>" & MkTbl & vbCrLf
        End If
      End if
      Response.Write "<font size='2'>" & c & "<br><br><br>" & vbCrLf
      LimpiaError
      Response.write "[ <a href='' onClick='history.go(-1);return false;'>Volver</a> ]</font><br>" & vbCrLf
    End if
    c = c & "<span style='display:none'></form></span>" & vbCrLf
  End Sub

  Public Sub LimpiaError()
    ErrMsg = ""
  End Sub

  Private Sub MkError()
    If Err.Number<>0  or ErrMsg <> "" Then
      if Err.Number<>0  Then
        ErrMsg = ErrMsg & "<br><b>Se ha producido un error.</b>" & VbCrLf
        ErrMsg = ErrMsg & "<br><br>Descripción:<br>" & VbCrLf & Err.Description & VbCrLf
        ErrMsg = ErrMsg & "<br><br>Número:<br>" & VbCrLf & Err.Number & VbCrLf
        ErrMsg = ErrMsg & "<br><br>Origen:<br>" & VbCrLf & Err.Source & VbCrLf
      End if
      Err.Clear
    End if
  End Sub
 
End Class
%>