[Resolvido]Fazer função verificar 04 Backs

Como mudar esta função para o meu front-end verificar em 04 back-end  separados  ? --- meu front usa 4 backs ...
{ Observe no código abaixo, que primeiro se percorre as tabelas do front-end para verificar se estão com os vínculos quebrados.  Os vínculos quebrados são deletados.  }

Código:

Public Sub fncVincular()
Dim be As DAO.Database
Dim tbl As DAO.TableDef
Dim LocalBe$

LocalBe = CurrentProject.Path & "\vincular_be.mdb"

'Percorre as tabelas no front-end e verifica se tem tabelas com vínculos quebrados
For Each tbl In CurrentDb.TableDefs
    If Left(tbl.Name, 4) <> "MSys" And Left(tbl.Name, 4) <> "Usys" Then
        If Not fncTabelaExiste(tbl.Name) Then
            'Excluir vínculo da tabela não existente no back-end
            DoCmd.DeleteObject acTable, tbl.Name
        End If
    End If
Next

Set be = DBEngine.OpenDatabase(LocalBe, False, False, ";PWD=a1234")
'Percorre as tabelas do back-end e verifica uma a uma,se está ou não,vinculada no front-end
For Each tbl In be.TableDefs
    If Left(tbl.Name, 4) <> "MSys" And Left(tbl.Name, 4) <> "Usys" Then
        If Not fncTabelaExiste(tbl.Name) Then
  'Realiza a vinculação da tabela não existente no front-end
  DoCmd.TransferDatabase acLink, "Microsoft Access", LocalBe, acTable, tbl.Name, tbl.Name
        End If
    End If
Next
be.Close

MsgBox "Tabelas Vinculadas..", vbInformation, "Aviso"
Set be = Nothing
Set tbl = Nothing
End Sub

{ A função que verifica se a tabela existe no front-end é esta: }

Código:

Public Function fncTabelaExiste(strNomeTabela As String) As Boolean
Dim rs As DAO.Recordset
'---------------------------------------------------------------
'Solicita ao VBA que prossiga com a execução do código,
'mesmo havendo erro e sem mostrar nenhuma mensagem.
'---------------------------------------------------------------
On Error Resume Next
'-----------------------------------
'Abre a tabela pesquisada
'-----------------------------------
Set rs = CurrentDb.OpenRecordset(strNomeTabela)
'---------------------------------------------------------------
'Se a tabela não existir, haverá erro e o valor(3078/3024) será
'armazenado no objeto Err.  Este valor poderá ser investigado
'através do comando Err.number
'---------------------------------------------------------------
Select Case Err.Number
    Case 3078, 3024
        fncTabelaExiste = False
    Case 0
        fncTabelaExiste = True
End Select

Set rs = Nothing
End Function

Font - By Avelino Sampaio - UsandoAccess usandoaccess.com.br/blog/vincular-tabelas-pelo-vba.asp#inicio

Olá Paulo Maia,

Estou no celular, mas se compredi bem a sua questão, o problema pode associado à variavel LocalBE, pois só esta associado a uma MDB.

Como tem 4 tabelas, creio que o melhor é extrair o nome do ficheiro MDB e atribuir à variável antes de ir verificar (fncTabelaExiste...)

Abraço

Sim,  mas...

Tenho um Font-End e 04 Back-End  ,  mas na função só é considerado um nome de back  ,  preciso verificar e vincular as tabelas que tem em cada um destes 04 arquivos back's

-------

Suposição minha  pela atual necessidade ...

LocalBe = CurrentProject.Path & "\Arquivo01_be.mdb"

LocalBe = CurrentProject.Path & "\Arquivo02_be.mdb"

LocalBe = CurrentProject.Path & "\Arquivo03_be.mdb"

LocalBe = CurrentProject.Path & "\Arquivo04_be.mdb"

-------


Não sei como mudar o código que postei no meu 1º Post aqui deste Tópico ,  para atender a esta minha necessidade.

Altere a função para receber o nome do back-end como parâmetro.

Public Sub fncVincular(LocalBe As String)

Retire a linha abaixo da função:

LocalBe = CurrentProject.Path & "\vincular_be.mdb"

Depois chame a função 4 vezes:

Call fncVincular(CurrentProject.Path & "\Arquivo01_be.mdb")
Call fncVincular(CurrentProject.Path & "\Arquivo02_be.mdb")
Call fncVincular(CurrentProject.Path & "\Arquivo03_be.mdb")
Call fncVincular(CurrentProject.Path & "\Arquivo04_be.mdb")

MUITO OBRIGADO === Cláudio Más

Funcionou...


OK  [ RESOLVIDO ]  

Percebi que não funciona se eu por o projeto FE com os BE em outro computador. Ele não recalcula os vínculos para o outro caminho novo do outro computador.

Tem uma forma de corrigir isso ?

Olá a todos,

Paulo renomear a pasta de raiz do seu projecto no seu pc está a revincular direito?
Teste e retorne.
Verifique também em ambos os pcs como tem o tratamento de erros.
Abraço

Olá Paulo,
Relativamente à mensagem 6, terá que ajustar o código para acionar a localização como confiável.
Veja tópicos abaixo se ajuda:
https://www.maximoaccess.com/t27967-resolvidoerro-de-fonte-confiavel
https://www.maximoaccess.com/t22545-resolvidoaccess-runtime-2010

Abraço a todos

OK, ahteixeira , mas ...


Este código foi projetado para atender as versões do Access 2007, 2010 e 2013.

usandoaccess.com.br/tutoriais/macro-de-seguranca-e-currentproject-istrusted.asp?id=1
Copiar link e colar no navegador

O meu é 2016.

ahteixeira

Mesmo assim, usei a função do Avelino com a macro AutoExec e continua parando nesse erro...  


&

Olá Paulo,

Antes de tudo não são permitidos links externos, ajustei a sua última mensagem.
Esse artigo do Mestre Avelino é muito bom, no entanto veja abaixo do download de exemplo tem um tópico relacionado "Macros e Segurança"

Poderá adicionar a unidade D:\ e C:\ manualmente e testar, mas a técnica demonstrada é o ideal.
Veja o tópico que referi.

Outra coisa, quando disse para ver o modo de tratamento desertos, se estiver na primeira opção o código do Avelino não funda corretamente nas partes que tem "On error resume next" eu próprio já confirmei, deve estar no modo classe (a opção do meio)

Estou no tablet, é o melhor que posso ajudar.

Abraço

OK, ahteixeira

Perdão pelo link , Eu deveria por o caminho sem hiperlink , da forma que vc editou.

o BO deve estar na função de vinculo, pois se eu ir clicando em Abrir ele vai tabela por tabela dos BE mostrando essa mensagem...


Eu não sei se há algum modo de tratar esta mensagem pelo vba na função de vinculo quando ela vai vincular.

OK, ahteixeira

Mas esta permissão todos que forem usar o sistema em suas respectivas maquinas precisam dar. "Nem todos terão essa facilidade de compreensão"


Se houvesse uma forma de contornar esta mensagem na função de vinculo, era o ideal.


Tendo em vista que esta mensagem tem dois botões,  podia setar o Abrir via vba,  não sei,  só ideia.

.
ou setar CurrentProject.IsTrusted como True

Paulo,
O artigo abaixo explica muito bem:
usandoaccess.com.br/tutoriais/macro-de-seguranca-e-currentproject-istrusted.asp?id=1
Se bem que tem a indicação que funciona na versão 2007,2020 e 2013.
Mas creio que também funcione na versão 2016, amanha vou tentar testar.

O que acontece é o seguinte, no PC onde está a tentar executar o seu código pode estar com as definições por defeito de quando se instala o Office (Access). Em que tem várias definições de Segurança que não permite executar Macros e Codigo (VBA).
Da primeira vez que executamos um projeto numa máquina, devemos alterar essas definições.
No artigo tem imagens a exemplificar onde se deve alterar (manualmente) e um código alternativo para a primeira execução.

Acontece que o código está apenas adicionar "o caminho" onde está a rodar o aplicativo como confiável.
Deve ajustar o código para também colocar "o caminho" dos BE como confiável ou fazer manualmente.
Como tenho visto nos seus "PrintScreens" tem o FE em C:\users\... e o BE em D:\...

Abraço

Não ,  estão todos em uma mesma pasta ( o FE  e os 04 BE )  em uma pasta na unidade D:


Porem falou uma coisa que faz sentido e pode funcionar ,  alterar o código para dar permissão também para os BE

tendo em vista que a mensagem só aparece na hora dos vínculos === BE


Mas não tenho ideia de como fazer esta alteração para permitir os BE junto com o FE  ,  ou para permitir a pasta enfim ....


----
Aqui é considerado só arquivos .accdb / mão não .mdb

Código:

'-------------------------------------------------------
'Captura o nome do seu aplicativo para cria o nome da
'pasta no trusted locations
'-------------------------------------------------------
nomeBd = CurrentProject.Name
nomeBd = Mid(nomeBd, 1, InStr(nomeBd, ".accd") - 1)

e aqui captura a pasta ...

Código:

Public Function fncLocalBd() As String
On Error Resume Next
'-----------------------------------------------
'Localiza a pasta do Banco de Dados em execução
'-----------------------------------------------
fncLocalBd = Application.CurrentProject.Path
End Function

era pra funcionar com todos os arquivos que estão na pasta. ( são todos BE e FE ) .mdb

Olá, adicione esta função e teste:

Código:

Public Function fncConfigMacroBE()
Dim reg As Object
On Error Resume Next

Set reg = CreateObject("wscript.shell")
'------------------------------------------------------------
'Configurando como confiável a pasta BE
'------------------------------------------------------------
reg.RegWrite CaminhoLoc & "AllowSubfolders", 1, "REG_DWORD"
reg.RegWrite CaminhoLoc & "Date", Date, "REG_SZ"
reg.RegWrite CaminhoLoc & "Description", "Projeto exemplo", "REG_SZ"
reg.RegWrite CaminhoLoc & "Path", "D:\S I S T E M A S", "REG_SZ"

Set reg = Nothing
End Function

Abraço

só mudei o nome da pasta para D:\TESTE   na sua função e chamei ela depois da chamada da função fncConfigMacro

Código:

Public Function fncConfigMacroBE()
Dim reg As Object
On Error Resume Next

Set reg = CreateObject("wscript.shell")
'------------------------------------------------------------
'Configurando como confiável a pasta BE
'------------------------------------------------------------
reg.RegWrite CaminhoLoc & "AllowSubfolders", 1, "REG_DWORD"
reg.RegWrite CaminhoLoc & "Date", Date, "REG_SZ"
reg.RegWrite CaminhoLoc & "Description", "Projeto exemplo", "REG_SZ"
reg.RegWrite CaminhoLoc & "Path", "D:\TESTE", "REG_SZ"

Set reg = Nothing
End Function

E não adicionou o D:\TESTE   ,  veja ...




esse caminho novo ai do dia 21  é o propio arquivo do Avelino ,  perceba que esta na minha pasta downloads.

E quando coloquei meu projeto FE e os BE nesta pasta isT5rusted não deu erro nenhum

Nada aqui ainda...

Depurei o código e percebi algo errado no carregamento das variáveis... então,

OK ,  Troquei esta linha ...

Código:

nomeBd = Mid(nomeBd, 1, InStr(nomeBd, ".accd") - 1)

Por esta aqui

Código:

nomeBd = Mid(nomeBd, 1, InStr(nomeBd, ".mdb") - 1)

E até que enfim a pasta foi criada como confiável. E não deu mais Erro.




** No meu caso resolveu assim, porem ...
Não tive oportunidade de testar ainda , mas Acho que para projetos  .accdb precisa por o "b" nessa linha ai tbm , assim ...

Código:

nomeBd = Mid(nomeBd, 1, InStr(nomeBd, ".accdb") - 1)

Olá Paulo Maia,

Obrigado pelo retorno.
O fórum agradece.

Abraço