Exemplo de Sistema Multi Empresa

Olá,
A proposito de tópico e conforme prometido, segue abaixo exemplo de sistema multi empresa.

Aproveito para postar algum código utilizado nas operações mais importantes:
Verifica caminhos e liga à tabela de Utilizadores

Código:

Private Sub Form_Load()
' Autor ..: Alvaro Teixeira (ahteixeira)
' Data ...: 07-07-2016
On Error GoTo Err_Form_Load
    
    Dim pathComuns, strTabela As String
    Dim x
    pathComuns = Application.CurrentProject.Path & "\AppDados\AppComuns.mdb"
    strTabela = "tblUtilizadores"
    
        If Not Dir(pathComuns) <> "" Then
            MsgBox "Verifique se existe o caminho e ficheiro:" & pathComuns, vbCritical, "Erro no acesso ao ficheiro"
            DoCmd.Close acForm, "frmLogin"
            DoCmd.Quit
        Else
            If fncTabelaEstaLigada(strTabela) Then
                DoCmd.DeleteObject acTable, strTabela
            End If
            DoCmd.TransferDatabase acLink, "Microsoft Access", _
            pathComuns, acTable, strTabela, strTabela
        End If
        If fncTabelaEstaLigada(strTabela) Then
            x = Nz(DCount("NomeUtilizador", "tblUtilizadores"), 0) > 0
        End If


Exit_Form_Load:
    Exit Sub

Err_Form_Load:
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "Erro"
    Resume Exit_Form_Load

End Sub

Função abrir ficheiro e ligar

Código:

Function fncAbrirFicheiroLigar() As String
' Autor ..: Alvaro Teixeira (ahteixeira)
' Código .: fncAbrirFicheiro
' Data ...: 11-08-2016
' Para ...: MaximoAccess.com
' Obs ....: Requer referencia a Microsoft Office XX Object Library
' Abrir, escolher ficheiro (tipo Abrir do Word),
' verifica tabelas da base de dados escolhida se existe ligação
' com mesmo nome apaga tabela(s) ligada(s)
' por fim liga tabelas da base de dados escolhida.
    
    On Error GoTo PROC_ERR
    
    Dim db As DAO.Database
    Dim tbl As TableDef
    Set db = CurrentDb()
    
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    fd.Title = "Selecione o ficheiro da empresa"
    fd.InitialFileName = Application.CurrentProject.Path & "\AppDados\Empresas\"
    fd.Filters.Add "Ficheiro MDB", "*.mdb", 1

    fd.Show
    
    If (fd.SelectedItems.Count > 0) Then
        Dim dbe As DAO.Database
        Dim tdefs As TableDefs, tdef As TableDef
        Set dbe = DBEngine.OpenDatabase(fd.SelectedItems(1))
            For Each tdef In dbe.TableDefs
                If Left(tdef.Name, 4) <> "MSys" Then
                    If fncTabelaEstaLigada(tdef.Name) Then DoCmd.DeleteObject acTable, tdef.Name
                    DoCmd.TransferDatabase acLink, "Microsoft Access", _
                    fd.SelectedItems(1), acTable, tdef.Name, tdef.Name
                End If
            Next tdef
        dbe.Close
        Set dbe = Nothing

        DoCmd.Close acForm, "frmEscolheEmpresa"
        DoCmd.OpenForm "frmMenu"
    Else
        MsgBox "Operação cancelada pelo utilizador.", vbInformation, ""
    End If
    
    
PROC_EXIT:
    db.Close
    Set db = Nothing
    Exit Function
    
    
PROC_ERR:
    DoCmd.Hourglass False
        If Err.Number = 3011 Then
           MsgBox "Ficheiro MDB inválido.", vbCritical, ""
        Else
           MsgBox Err.Number & " - " & Err.Description, vbCritical, ""
        End If
    Resume PROC_EXIT
    
End Function


Função verifica se existe tabela ligada

Código:

Function fncTabelaEstaLigada(sNomeTabela As String) As Boolean
' Autor ..: Alvaro Teixeira (ahteixeira)
' Código .: fncTabelaEstaLigada
' Data ...: 07-07-2016
' Para ...: MaximoAccess.com
' Verifica apenas se existe a ligação/vinculo, não verifica se existe o ficheiro ou tabela da ligação
    
    fncTabelaEstaLigada = DCount("*", "MSysObjects", "MSysObjects.Name = '" & sNomeTabela & "' AND MSysObjects.Type = 6")

End Function

Abraço

ahteixeira,

vc solucionou um problema que tenho há alguns anos, tenho um programa de controle da execução crédito orçamentário, SIAFI, para cada ano crio um arquivo.

Porém, para fazer consultas de anos anteriores tinha que sair do atual e abrir o referido arquivo do ano em questão.

Minhas possibilidades agora são enormes.


Valeu, muito obrigado.


Cleverson

Muito bom, é mais uma pérola para a coleção máximo Access


Obrigado ahteixeira, muito obrigado mesmo.

Obrigado, ahteixeira!

muito obrigado.

Olha que maravilha mestre ahteixeira, ficou muito bom mesmo o exemplo... Irei esmiuçar esses codigos assim que possivel... Novos conhecimentos e sempre bem vindo!

Obrigado por compartilhar!

Olá a todos,

Um colega colocou a questão se seria possível mostar a base de dados "ligada", para isso deve-se colar o seguinte código num Módulo:

Código:

Public Function fncCaminhoTabelaLigada(NomeTabela As String) As String
' Autor ..: Alvaro Teixeira (ahteixeira)
' Código .: fncCaminhoTabelaLigada
' Data ...: 05-04-2022
' Para ...: MaximoAccess.com
' Obs ....: Obter o caminho completo e base de dados de tabela ligada

    On Error Resume Next
    fncCaminhoTabelaLigada = Replace(CurrentDb.TableDefs(NomeTabela).Connect, ";DATABASE=", "")
    
End Function

No formulário alterar a "origem" do campo de texto com a chamada da função indicando o nome da tabela, por exemplo:

Código:

=fncCaminhoTabelaLigada("tblClientes")

Obtemos o pretendido:


Abraço e bons estudos

Ótimo exemplo parabéns!

Ideal para acessar bancos de fechamentos mensais e/ou anuais.

Olá, é gratificante saber que é útil o exemplo postado.
Obrigado pelo retorno.
Isto é que é ser MaximoAccess
Abraço e bons estudos