Atualização automatica de tabelas

Option Compare Database
Option Explicit

Sub testeAtualizar()

   Call atualizar

End Sub

Function atualizar() As Boolean
   
'Tipos de dados SQL
'String = VARCHAR(Tamanho)
'Memo = MEMO
'Object = IMAGE
'Integer = SMALLINT
'Long = INTEGER
'Single = REAL
'Double = FLOAT
'Currency = MONEY
'Boolean = BIT
'Date/Time = DATETIME

'Variáveis=================================================

   Dim objCon As New classeConexao
   Dim objAtlz As New classeConexao
   Dim rstCon As ADODB.Recordset
   Dim strSql As String
   Dim proximoCodigo As Long
   
'Código====================================================
       
       'Busca do usuário administrador para atualização do novo campo
       
           Dim strUsuarioAdm As String
       
           strSql = "Select usuario From Usuario Where ordem=1"
           Set rstCon = objCon.consultaBanco(strSql)
           
           If rstCon.RecordCount = 1 Then
               strUsuarioAdm = rstCon("usuario")
           End If
           
           rstCon.Close
       '====================================================
   
   '1ª Atualização de tabelas - 11/05/08
   'Inclusão do campo confirmada na tabela Receita
   Call atualizaTabela("Receita", "confirmada", "I", "BIT")
   '2ª Atualização de tabelas - 13/05/08
   'Inclusão do campo conta na tabela FormaPagamento
   'Inclusão do campo conta na tabela TipoReceita
   Call atualizaTabela("FormaPagamento", "conta", "I", "INTEGER", "Conta", "codConta")
   Call atualizaTabela("TipoReceita", "conta", "I", "INTEGER", "Conta", "codConta")
   '3ª Atualização de tabelas - 26/11/08
   'Inclusão do campo usuario na tabela FormaPagamento
   Call atualizaTabela("FormaPagamento", "usuario", "I", "VARCHAR(20)", "Usuario", "usuario", "'" & strUsuarioAdm & "'")
   '4ª Atualização de tabelas - 18/12/08
   'Inclusão do campo usuario na tabela TipoReceita
   'Modificação do tamanho do campo descrição na tabela Lancamento
   Call atualizaTabela("TipoReceita", "usuario", "I", "VARCHAR(20)", "Usuario", "usuario", "'" & strUsuarioAdm & "'")
   Call atualizaTabela("Lancamento", "descricao", "M", "VARCHAR(30)")
   '5ª Atualização de tabelas - 17/01/09
   'Inclusão do campo grupoDespesa na tabela Despesa
   'Inclusão do campo grupoDespesa na tabela Receita
   Call atualizaTabela("Despesa", "grupoDespesa", "I", "INTEGER")
   Call atualizaTabela("Receita", "grupoReceita", "I", "INTEGER")
   '6ª Atualização de tabelas - 13/01/13
   'Inclusão do campo LOCAL DA FICHA na tabela FICHA DE VENDAS
   'Inclusão do campo NEGATIVADA na tabela FICHA DE VENDAS
   'Inclusão do campo TIPO DE VENDA na tabela FICHA DE VENDAS
   'Inclusão do campo CEP na tabela FICHA DE VENDAS
   'Inclusão do campo CELULAR na tabela FICHA DE VENDAS
   'Inclusão do campo Código na tabela FICHA DE VENDAS
   'Inclusão do campo Código na tabela VALOR COBRADO
   'Call atualizaTabela("FICHA DE VENDAS", "LOCAL DA FICHA", "I", "VARCHAR (50)")
   'Call atualizaTabela("FICHA DE VENDAS", "NEGATIVADA", "I", "VARCHAR (50)")
   'Call atualizaTabela("FICHA DE VENDAS", "TIPO DE VENDA", "I", "VARCHAR (50)")
   'Call atualizaTabela("FICHA DE VENDAS", "CEP", "I", "VARCHAR (50)")
   'Call atualizaTabela("FICHA DE VENDAS", "CELULAR", "I", "VARCHAR (50)")
   'Call atualizaTabela("FICHA DE VENDAS", "Código", "I", "VARCHAR (50)")
   'Call atualizaTabela("VALOR COBRADO", "Código", "I", "VARCHAR (50)")
   
'========================================================================================
   
   'Inclui as formas de pagamento para os outros usuários e atualiza as referências.
   strSql = "Select Despesa.usuario as nomeUsuario, Despesa.formaPagamento as codigoForma, FormaPagamento.nomeForma as nomeForma " & _
               "From Despesa Left Join FormaPagamento On Despesa.formaPagamento = FormaPagamento.codForma " & _
               "Group By Despesa.usuario, Despesa.formaPagamento, FormaPagamento.nomeForma, FormaPagamento.usuario " & _
               "Having Despesa.usuario <> '" & strUsuarioAdm & "' And FormaPagamento.usuario='" & strUsuarioAdm & "' " & _
               "Order By Despesa.usuario, Despesa.formaPagamento"
   
   Set rstCon = objCon.consultaBanco(strSql)
   
   If rstCon.RecordCount > 0 Then
   
       Do Until rstCon.EOF
           proximoCodigo = codigoLivre("FormaPagamento", "codForma")
           strSql = "Insert Into FormaPagamento Values(" & _
                   proximoCodigo & ",'" & rstCon("nomeForma") & "',Null,'" & rstCon("nomeUsuario") & "')"
           Call objAtlz.atualizaBanco(strSql)
           strSql = "Update Despesa Set formaPagamento=" & proximoCodigo & _
                       " Where usuario='" & rstCon("nomeUsuario") & "' And " & _
                       "formaPagamento=" & rstCon("codigoForma")
           Call objAtlz.atualizaBanco(strSql)
           rstCon.MoveNext
       Loop
       
   End If
   
   rstCon.Close

'========================================================================================
   
   'Inclui os tipos de receita para os outros usuários e atualiza as referências.
   strSql = "Select Receita.usuario as nomeUsuario, Receita.tipoReceita as codigoReceita, " & _
                   "TipoReceita.descricao as nomeReceita, TipoReceita.classe as nomeClasse " & _
               "From Receita Left Join TipoReceita On Receita.tipoReceita = TipoReceita.codTipoReceita " & _
               "Group By Receita.usuario, Receita.tipoReceita, TipoReceita.descricao, TipoReceita.classe, TipoReceita.usuario " & _
               "Having Receita.usuario <> '" & strUsuarioAdm & _
                   "' And TipoReceita.usuario='" & strUsuarioAdm & "' " & _
               "Order By Receita.usuario, Receita.tipoReceita"
   
   Set rstCon = objCon.consultaBanco(strSql)
   
   If rstCon.RecordCount > 0 Then
   
       Do Until rstCon.EOF
           proximoCodigo = codigoLivre("TipoReceita", "codTipoReceita")
           strSql = "Insert Into TipoReceita Values(" & _
                   proximoCodigo & ",'" & rstCon("nomeReceita") & "','" & _
                   rstCon("nomeClasse") & "',Null,'" & rstCon("nomeUsuario") & "')"
           Call objAtlz.atualizaBanco(strSql)
           
           strSql = "Update Receita Set tipoReceita=" & proximoCodigo & _
                       " Where usuario='" & rstCon("nomeUsuario") & "' And " & _
                       "tipoReceita=" & rstCon("codigoReceita")
           
           Call objAtlz.atualizaBanco(strSql)
           rstCon.MoveNext
       Loop
       
   End If
   
   rstCon.Close

'========================================================================================
   
End Function

Function atualizaTabela(argTabela As String, argCampo As String, argAcao As String, Optional argTipo As String, Optional argTabelaEstrangeira As String, Optional argCampoEstrangeiro As String, Optional argValor As String) As Boolean
On Error GoTo Erro_Corrigir
   
   Dim dbs As Database
   Dim objCon As New classeConexao
   Dim rstCon As ADODB.Recordset
   Dim strSql As String
   
   strSql = "SELECT " & argCampo & " From " & argTabela
   Set rstCon = objCon.consultaBanco(strSql)
   
   rstCon.Close
   
   'Busca o banco de dados para atuallização
   Set dbs = OpenDatabase(BackEndAtual)
   
   If argAcao = "M" Then

       'Modifica o campo na tabela.
       strSql = "ALTER TABLE " & argTabela & " ALTER COLUMN " & argCampo & " " & argTipo & ";"
       dbs.Execute strSql
       dbs.Close
       atualizaTabela = True
   
   End If
   
   If argAcao = "E" Then
       'Exclui o campo na tabela.
       strSql = "ALTER TABLE " & argTabela & " DROP COLUMN " & argCampo & ";"
       dbs.Execute strSql
       dbs.Close
       atualizaTabela = True
   End If
   
   Exit Function

Campo_nao_existe:
   
   'Busca o banco de dados para atuallização
   Set dbs = OpenDatabase(BackEndAtual)
   
   If argAcao = "I" Then
       
       'Mensagem informando a atualização
       MsgBox "O módulo de << " & UCase(argTabela) & " >> está desatualizado.  " & vbCrLf & vbCrLf & _
               "O Sistema irá atualizá-lo para prosseguir.", vbExclamation, "Info.ID - Atualização de Módulos"
       
       ' Inclui o campo na tabela.
       strSql = "ALTER TABLE " & argTabela & " ADD COLUMN " & argCampo & " " & argTipo & ";"
       dbs.Execute strSql
       If argTabelaEstrangeira <> "" And argCampoEstrangeiro <> "" Then
           strSql = "ALTER TABLE " & argTabela & " ADD FOREIGN KEY (" & argCampo & ") References " & argTabelaEstrangeira & "(" & argCampoEstrangeiro & ")"
           dbs.Execute strSql
       End If
       
       'Inclui o valor do novo campo para todos os registros, caso informado
       If argValor <> "" Then
           strSql = "UPDATE " & argTabela & " SET " & argCampo & "=" & argValor
           dbs.Execute strSql
       End If
       
       dbs.Close
       atualizaTabela = True
   End If

Erro_Saida:
   Exit Function

Erro_Corrigir:
   If err.Number = 91 Then
       Resume Campo_nao_existe
   Else
       MsgBox err.Description & vbCrLf & "O sistema não foi atualizado. Por favor contate o desenvolvedor."
       atualizaTabela = False
       Resume Erro_Saida
   End If
End Function