[Resolvido]Localizador de Back end - criar um seletor

Boa tarde Amigos

Após um bom tempo sem pertuba-los, apareço com uma nova solicitação de ajuda.

Tenho um BD com este localizador de BE rodando: http://maximoaccess.forumeiros.com/t4315-resolvidolocalizador-de-arquivo-back_end. Muito bem por sinal, porém estou com este sistema para começar rodar em varias bases, onde cada uma terá seu banco de dados, assim nomei os BE com um nome especifico de cada base.

Exemplo:

Base Rio: sgsoirj_be
Base Curitiba: sgsoict_be

Porém necessito que o usuario tenha a opção de selecionar o arquivo BE toda vez que abrir o sistema, pois do modo em que está hoje, uma vez selecionado ele não pergunta mais.

Alguém pode me ajudar?

Grato

Kleyton

Deve ter uma chamada no evento "Ao carregar" do formulário, certo? Basta copiar essa chamada para um botão, fazendo os devidos ajustes, lógico, como, por exemplo, tirar a condição que só abre o seletor caso o backend não seja encontrado.

Boa tarde Criquio

Desculpe a demora em dar retorno estava a viajar.

Neste sistema tenho o seguinte modulo:

Option Compare Database
Option Explicit
Public CaminhoAtual As String
Public booNovaChecagem As Boolean
Public booOk As Boolean
Public booSair As Boolean


Public Function fncChecaVinculo() As Boolean
Dim PathBe As String
Dim NomeBE As String
Dim Contador As Byte
Dim box As String

On Error GoTo TrataErro

'------------------------------------------------------
'Passa o caminho e o nome do back-end para as variáveis
'------------------------------------------------------
PathBe = Nz(DLookup("path_0", "tblCaminhoBe"), "vazio")
NomeBE = Nz(DLookup("NomeBe", "tblCaminhoBe"), "vazio")

'-----------------------------------------------------------------
'Verifica se o nome do back-end se encontra na tabela tblcaminhoBe
'-----------------------------------------------------------------
If NomeBE = "vazio" Then
MsgBox "Entre com o nome do back-end no campo NomeBE da tabela tblCaminhoBe...", vbCritical, "Aviso"
fncChecaVinculo = True
Exit Function
End If

'---------------------------------------------------------------------------
'Verifica se o caminho atual do back-end esta gravado na tabela tblCaminhoBe
'---------------------------------------------------------------------------
If PathBe = "vazio" Then
CurrentDb.Execute "UPDATE tblCaminhoBe SET path_0 ='" & CurrentProject.Path & "\" & NomeBE & "'"
PathBe = CurrentProject.Path & "\" & NomeBE
End If

'-------------------------------------------------------------------------------------
'Passa o caminho do back-end, que está gravado no vínculo das tabelas, para a variável
'-------------------------------------------------------------------------------------
CaminhoAtual = fncBackEndAtual

'-----------------------------------------------
'Verifica se o back-end existe no local indicado
'-----------------------------------------------
If Len(Dir(PathBe) & "") > 0 Then
'----------------------------------------------------
'Verifica se o local atual do back-end corresponde
'ao local gravado no vínculo. caso não corresponda,
'abre a barra de progresso para refazer os vinculos
'----------------------------------------------------
If CaminhoAtual <> PathBe Then
CaminhoAtual = PathBe
DoCmd.OpenForm "frmBarraProgresso", OpenArgs:=1
Else
If Len(Trim(DLookup("formPrincipal", "tblCaminhoBe")) & "") > 0 Then
DoCmd.OpenForm DLookup("formPrincipal", "tblCaminhoBe")
End If
End If
Else
'----------------------------------------------------------------
'Abre o formulário para indicar a nova localização do back-end
'----------------------------------------------------------------
DoCmd.OpenForm "frmCaminhoBe", , , , , acDialog, 1
If booSair = True Then
fncChecaVinculo = True
Exit Function
End If
If booNovaChecagem Then fncChecaVinculo
End If

Sair:
Exit Function
TrataErro:
Select Case Err.Number
Case 76, 52
DoCmd.OpenForm "frmCaminhoBe", , , , , acDialog, 1
Case 2102
MsgBox "O formulário principal '" & DLookup("formPrincipal", "tblCaminhoBe") & "' não existe...", vbInformation, "Aviso"
fncChecaVinculo = True
Case Else
MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", Err.HelpFile, Err.HelpContext
fncChecaVinculo = True
End Select
End Function

Private Function fncBackEndAtual() As String
Dim strCon As String
Dim strTabelaLink As String
Dim tbl As DAO.TableDef

On Error GoTo TrataErro

'-----------------------------------------------
'capturando o nome da última tabela vinculada
'-----------------------------------------------
For Each tbl In CurrentDb.TableDefs
If Len(tbl.Connect & "") > 0 Then strTabelaLink = tbl.Name
Next
'-----------------------------------------------------
'Passando o caminho do vínculo para a variável
'-----------------------------------------------------
strCon = CurrentDb.TableDefs(strTabelaLink).Connect
'-----------------------------------------------------
'Agora vou retirar apenas o caminho do accdb,
'sem o ";DATABASE=" que o precede na string Connect.
'-----------------------------------------------------

fncBackEndAtual = Right$(strCon, (Len(strCon) - (InStr(1, strCon, ";DATABASE=", 2) + 9)))

Sair:
Exit Function
TrataErro:
MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", Err.HelpFile, Err.HelpContext
Resume Sair:
End Function


E na form de busca do vinculo o seguinte code:

Option Compare Database
Private Declare Function GetComputerName Lib "Kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Sub btProcurar_Click()
Dim Titulo As String, filtro As String, NovoCaminho As String
On Error Resume Next
filtro = "Banco de Dados Access (*.accdb)" & Chr(0) & "*.accdb"
Titulo = "Selecione o banco de dados..."
NovoCaminho = LocalizarArquivo(CurrentProject.Path, Titulo, filtro)
If NovoCaminho = CaminhoAtual Or NovoCaminho = "" Then
Me!Path_0 = CaminhoAtual
Else
Me!Path_0 = NovoCaminho
End If
Me!btSalvar.SetFocus
End Sub

Private Sub btSair_Click()
On Error Resume Next
Me!Path_0 = CaminhoAtual
booSair = True
DoCmd.Close acForm, "frmCaminhoBe"
End Sub

Private Sub btSalvar_Click()
On Error Resume Next
If Len(Dir(Me!Path_0) & "") = 0 Then
MsgBox "Arquivo inexistente no caminho indicado. Use o botão procurar...", vbInformation, "Aviso"
Me!btProcurar.SetFocus
Exit Sub
End If
If InStr(Me!Path_0, DLookup("NomeBe", "tblCaminhoBe")) = 0 Then
MsgBox "O back-end selecionado não faz parte do projeto..." & vbCrLf & vbCrLf & "Selecione o back-end " & DLookup("NomeBe", "tblCaminhoBe") _
, vbInformation, "Aviso"
Me!btProcurar.SetFocus
Exit Sub
End If
If Not Me!Path_0 = CaminhoAtual Then
'MsgBox "O programa será fechado" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & _
'"Reabra o programa e aguarde pela conclusão da nova configuração.", vbInformation, "Aviso"
booNovaChecagem = True
DoCmd.Close acForm, "frmCaminhoBe"
Else
MsgBox "É necessário modificar o caminho atual...", vbInformation, "Aviso"
End If
End Sub

Function fncNomeComputador() As String
Dim lngVal As Long, strCompName As String
On Error Resume Next
strCompName = Space(255)
lngVal = GetComputerName(strCompName, 255)
If lngVal Then
Me.Caption = "Nome deste computador: " & Left$(strCompName, InStr(strCompName, vbNullChar) - 1)
Else
Me.Caption = "Configurar em rede"
End If
End Function

Private Sub Form_Load()
On Error Resume Next
Call fncNomeComputador
End Sub

Private Sub Form_Open(Cancel As Integer)
Dim box
If Nz(Me.OpenArgs, 0) = 0 Then
Cancel = True
Exit Sub
End If
box = "

Falha de comunicação com a base de dados " & DLookup("Nomebe", "tblcaminhobe") & "

"
box = box & "

1 - Verifique se o computador que possui a base de dados está ligado.

"
box = box & "

2 - Verifique se o seu computador está em comunicação com a rede.

"
box = box & "

3 - Clique no botão procurar ou digite o novo caminho da rede, aonde se encontra o banco de dados.

"
box = box & "

4 - Entre em contato com o administrador da rede, caso não tenha resolvido o problema."
Me!txQuadro = box
Me!Rótulo21.Caption = "Exemplo: \\nome do computador na rede\pasta\" & DLookup("Nomebe", "tblcaminhobe")
End Sub

Private Sub Path_0_GotFocus()
Me!Path_0.SelStart = Len(Me!Path_0 & "")
End Sub

Desculpe meu amadorismo mas tentei algumas alteraçãoes no code e não consegui esse efeito que queria.

Grato

Kleyton

Creio que a solução seria fazer um code para que ao fechar ele limpe o campo da tabela que grava o caminho BE, assim sempre ao abrir ele perguntará.

Alguem pode me ajudar nisso?

Grato

Kleyton

Bom dia Amigos

Alterei a linha em vermelho, na verificação de > para <, e ele passou a solicitar para a pessoa localizar o BE sempre. Que era o que eu estava a principio precisando, porém me criou outro problema.

O modulo também checa se o caminho Be já esta vinculado com as variaveis, e apesar de ele me pedir para localizar o caminho do Be de novo, após localizar ele não aceita pq o caminho que localizo é igual ao caminho do BE que esta vinculado com as tabelas. Ou seja penso que a solução seria aliar essa alteração feita na linha em vermelho mais um code para ao fechar ele limpar o caminho salvo no vinculo das tabelas.

Alguém pode por favor me ajudar?

Grato

Kleyton

Option Compare Database
Option Explicit
Public CaminhoAtual As String
Public booNovaChecagem As Boolean
Public booOk As Boolean
Public booSair As Boolean


Public Function fncChecaVinculo() As Boolean
Dim PathBe As String
Dim NomeBE As String
Dim Contador As Byte
Dim box As String

On Error GoTo TrataErro

'------------------------------------------------------
'Passa o caminho e o nome do back-end para as variáveis
'------------------------------------------------------
PathBe = Nz(DLookup("path_0", "tblCaminhoBe"), "vazio")
NomeBE = Nz(DLookup("NomeBe", "tblCaminhoBe"), "vazio")

'-----------------------------------------------------------------
'Verifica se o nome do back-end se encontra na tabela tblcaminhoBe
'-----------------------------------------------------------------
If NomeBE = "vazio" Then
MsgBox "Entre com o nome do back-end no campo NomeBE da tabela tblCaminhoBe...", vbCritical, "Aviso"
fncChecaVinculo = True
Exit Function
End If

'---------------------------------------------------------------------------
'Verifica se o caminho atual do back-end esta gravado na tabela tblCaminhoBe
'---------------------------------------------------------------------------
If PathBe = "vazio" Then
CurrentDb.Execute "UPDATE tblCaminhoBe SET path_0 ='" & CurrentProject.Path & "\" & NomeBE & "'"
PathBe = CurrentProject.Path & "\" & NomeBE
End If

'-------------------------------------------------------------------------------------
'Passa o caminho do back-end, que está gravado no vínculo das tabelas, para a variável
'-------------------------------------------------------------------------------------
CaminhoAtual = fncBackEndAtual

'-----------------------------------------------
'Verifica se o back-end existe no local indicado
'-----------------------------------------------
If Len(Dir(PathBe) & "") < 0 Then
'----------------------------------------------------
'Verifica se o local atual do back-end corresponde
'ao local gravado no vínculo. caso não corresponda,
'abre a barra de progresso para refazer os vinculos
'----------------------------------------------------
If CaminhoAtual <> PathBe Then
CaminhoAtual = PathBe
DoCmd.OpenForm "frmBarraProgresso", OpenArgs:=1
Else
If Len(Trim(DLookup("formPrincipal", "tblCaminhoBe")) & "") > 0 Then
DoCmd.OpenForm DLookup("formPrincipal", "tblCaminhoBe")
End If
End If
Else
'----------------------------------------------------------------
'Abre o formulário para indicar a nova localização do back-end
'----------------------------------------------------------------
DoCmd.OpenForm "frmCaminhoBe", , , , , acDialog, 1
If booSair = True Then
fncChecaVinculo = True
Exit Function
End If
If booNovaChecagem Then fncChecaVinculo
End If

Sair:
Exit Function
TrataErro:
Select Case Err.Number
Case 76, 52
DoCmd.OpenForm "frmCaminhoBe", , , , , acDialog, 1
Case 2102
MsgBox "O formulário principal '" & DLookup("formPrincipal", "tblCaminhoBe") & "' não existe...", vbInformation, "Aviso"
fncChecaVinculo = True
Case Else
MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", Err.HelpFile, Err.HelpContext
fncChecaVinculo = True
End Select
End Function

Private Function fncBackEndAtual() As String
Dim strCon As String
Dim strTabelaLink As String
Dim tbl As DAO.TableDef

On Error GoTo TrataErro

'-----------------------------------------------
'capturando o nome da última tabela vinculada
'-----------------------------------------------
For Each tbl In CurrentDb.TableDefs
If Len(tbl.Connect & "") > 0 Then strTabelaLink = tbl.Name
Next
'-----------------------------------------------------
'Passando o caminho do vínculo para a variável
'-----------------------------------------------------
strCon = CurrentDb.TableDefs(strTabelaLink).Connect
'-----------------------------------------------------
'Agora vou retirar apenas o caminho do accdb,
'sem o ";DATABASE=" que o precede na string Connect.
'-----------------------------------------------------

fncBackEndAtual = Right$(strCon, (Len(strCon) - (InStr(1, strCon, ";DATABASE=", 2) + 9)))

Sair:
Exit Function
TrataErro:
MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", Err.HelpFile, Err.HelpContext
Resume Sair:
End Function

Por favor... Alguem?