ABRIR E FECHAR CONEXÃO NO FORMULÁRIO

 Tópico anterior Próximo tópico Novo tópico

ABRIR E FECHAR CONEXÃO NO FORMULÁRIO

VB / VBA

 Compartilhe  Compartilhe  Compartilhe
#472765 - 25/03/2017 21:22:37

MILTONSILVA94
CANOAS / RIO GRANDE DO SUL
Cadast. em:Janeiro/2015


Última edição em 27/03/2017 22:33:24 por MILTONSILVA94

Saudações colegas!

Gostaria de saber como encaixo nas minhas rotinas para sempre que 'abrir conexão' possa 'fechar conexão' nos formulários. Por exemplo tenho abaixo a rotina ao abrir formulário, como posso fazer:

Option Explicit

Dim lsql As String
Dim lTBPerfis As Recordset
Dim lItem As ListItem

Dim db As Database  'Início das variáveis (3 linhas) referente a 'Exclusao' pois tem vinculação entre duas tabelas
Dim rs As Recordset
Dim dbname As String  'Fim das variáveis

Private Sub Form_Load()
    Caption = "Perfis - Leader ERP Versão: " & App.Major & "." & App.Minor & "." & App.Revision
    lblDataFormulario = "  " & Format(Date, "dd/mm/yyyy") & "  "  'Exibe a data atual ao abrir formulário

    RotinaRefresh  'Chama rotina para vir com o listview preenchido

    'RotinaBloqueioBotaoDireitoMouse  'Rotina desabilitada

    If retorno = False Then
        'MensagemErro "Ao abrir formulário pesquisa cai aqui dentro!"
    Else
        'MensagemErro "Caso contrário cai aqui!"
    End If
End Sub

Private Sub RotinaExclusao()
    dbname = App.Path & "\BDSistemaIntegrado.mdb"
    Set db = DBEngine.Workspaces(0).OpenDatabase(dbname)
    Dim perfil As Long

    If lvwLista.ListItems.Count > 0 Then
        perfil = lvwLista.SelectedItem

        Set rs = db.OpenRecordset("SELECT id_Usuario FROM USUARIOS WHERE id_Perfil = " & perfil)

        If rs.RecordCount > 0 Then
            MensagemErro "Perfil já possui vínculo com usuários, não é possível excluir!"
                txtPerfil.Text = ""
                txtPerfil.SetFocus
        Else
            MensagemInformativo "O registro será excluído permanentemente e não poderá ser recuperado."
            
            If MsgBox("Confirma a exclusão do registro Nº '" & lvwLista.SelectedItem & "'?", vbQuestion + vbYesNo) = vbNo Then
                Exit Sub
            End If
            
            lsql = "DELETE FROM PERFIS WHERE id_perfil = " & lvwLista.SelectedItem
                gBDSistemaIntegrado.Execute lsql
                    lvwLista.ListItems.Remove (lvwLista.SelectedItem.Index)

            txtPerfil.Text = ""
            lblContador.Caption = ""
            txtPerfil.SetFocus
    
            RotinaRefresh
        End If
    End If
End Sub

Private Sub lvwLista_KeyUp(KeyCode As Integer, Shift As Integer)  'Rotina para botão delete fazer exclusão de registros
    If KeyCode = vbKeyDelete Then
        RotinaExclusao  'Chama rotina
    End If
End Sub  'Fim da rotina

Private Sub RotinaNovo()
    gsNA = "N"

    txtPerfil.Text = ""
        frmPerfisNovoAltera.Show , Me
End Sub

Private Sub RotinaAlterar()
    dbname = App.Path & "\BDSistemaIntegrado.mdb"
    Set db = DBEngine.Workspaces(0).OpenDatabase(dbname)
    Dim IdPerfil As Long
    
    If lvwLista.ListItems.Count = 0 Then
        MensagemErro "Selecione um registro para fazer a alteração!"
            txtPerfil.Text = ""
            txtPerfil.SetFocus
        Exit Sub
    End If
    If lvwLista.ListItems.Count > 0 Then
        IdPerfil = lvwLista.SelectedItem

        Set rs = db.OpenRecordset("SELECT id_Usuario FROM USUARIOS WHERE id_Perfil = " & IdPerfil)

        If rs.RecordCount > 0 Then
            MensagemErro "Perfil já possui vínculo com usuários, não é possível alterar!"
                txtPerfil.Text = ""
                txtPerfil.SetFocus
            Exit Sub
        End If
    End If

    txtPerfil.Text = ""  'Rotina para campo ficar em branco

    gsNA = "A"
    frmPerfisNovoAltera.Show , Me
End Sub

Private Sub RotinaExcluir()
    If lvwLista.ListItems.Count = 0 Then
        MensagemErro "Selecione um registro para fazer a exclusão!"
            txtPerfil.Text = ""
            txtPerfil.SetFocus
        Exit Sub
    End If
        RotinaExclusao  'Chama rotina
End Sub

Private Sub RotinaLimpar()
    txtPerfil.Text = ""
    txtPerfil.SetFocus
End Sub

Private Sub RotinaSalvar()
        MensagemErro "Opção indisponível!"
End Sub

Private Sub RotinaPesquisar()
    If (txtPerfil.Text) <> "" Then  'Monta pesquisa pelos dados informados
        lsql = "SELECT * FROM PERFIS WHERE perfil LIKE '*" & ComApostrofo(txtPerfil.Text) & "*'"
    Else
        lsql = "SELECT * FROM PERFIS ORDER BY id_perfil ASC"  'Se não for digitado nada retorna todos registros
    End If  'Fim da rotina

        txtPerfil.SetFocus  'Foco vai para este campo

    Set lTBPerfis = gBDSistemaIntegrado.OpenRecordset(lsql, dbOpenSnapshot)

    If lTBPerfis.EOF Then
        MensagemErro "Erro! Nenhum registro foi localizado!"
            lvwLista.ListItems.Clear
            txtPerfil.Text = ""
            lblContador.Caption = ""
            txtPerfil.SetFocus
        Exit Sub
    End If

    lvwLista.ListItems.Clear  'Rotina deve ficar aqui, caso contrário duplica os registros da RotinaPesquisar

    Do While lTBPerfis.EOF = False

    Set lItem = lvwLista.ListItems.Add

    lItem.Text = lTBPerfis.Fields("id_perfil").Value
    lItem.SubItems(1) = Format(lTBPerfis.Fields("data_hora").Value, "dd/mm/yyyy hh:mm:ss")
    lItem.SubItems(2) = lTBPerfis.Fields("perfil").Value
    lItem.SubItems(3) = lTBPerfis.Fields("atualizado_por").Value
    lItem.SubItems(4) = Format(lTBPerfis.Fields("ultima_atualizacao").Value, "dd/mm/yyyy hh:mm:ss")

    If lvwLista.ListItems.Count = 1 Then  'Caso a pesquisa filtrada retorne apenas 1 registro o botão ficará invisível
        cmdOrdenarPorPerfil.Enabled = False
    End If

        txtPerfil.Text = ""  'Rotina para campo ficar em branco se o resultado for positivo

        lblContador.Caption = lTBPerfis.RecordCount & " registro(s)"  'Rotina para mostrar total de registros da pesquisa
    
        lTBPerfis.MoveNext
    Loop
        
    If lvwLista.ListItems.Count > 1 Then  'Se pesquisa retornar mais de 1 registro, os botões ficarão visíveis
        cmdOrdenarPorPerfil.Enabled = True
    End If
End Sub

Private Sub cmdOrdenarPorPerfil_Click()
    lsql = "SELECT * FROM PERFIS ORDER BY perfil ASC"  'Rotina que monta pesquisa

        txtPerfil.SetFocus  'Foco vai para este campo

    Set lTBPerfis = gBDSistemaIntegrado.OpenRecordset(lsql, dbOpenSnapshot)

    lvwLista.ListItems.Clear
    
    Do While lTBPerfis.EOF = False
    
    Set lItem = lvwLista.ListItems.Add

    lItem.Text = lTBPerfis.Fields("id_perfil").Value
    lItem.SubItems(1) = Format(lTBPerfis.Fields("data_hora").Value, "dd/mm/yyyy hh:mm:ss")
    lItem.SubItems(2) = lTBPerfis.Fields("perfil").Value
    lItem.SubItems(3) = lTBPerfis.Fields("atualizado_por").Value
    lItem.SubItems(4) = Format(lTBPerfis.Fields("ultima_atualizacao").Value, "dd/mm/yyyy hh:mm:ss")

    If lvwLista.ListItems.Count = 1 Then  'Caso a pesquisa filtrada retorne apenas 1 registro o botão abaixo ficará invisível
        cmdOrdenarPorPerfil.Enabled = False
    End If

        txtPerfil.Text = ""  'Rotina para campo ficar em branco se o resultado for positivo

        lblContador.Caption = lTBPerfis.RecordCount & " registro(s)"  'Rotina para mostrar total de registros da pesquisa

        lTBPerfis.MoveNext
    Loop

    If lvwLista.ListItems.Count > 1 Then  'Se pesquisa retornar mais de 1 registro, os botões ficarão visíveis
        cmdOrdenarPorPerfil.Enabled = True
    End If
End Sub

Private Sub RotinaSair()
    Unload Me
        frmMDISistema.Show
End Sub


Obrigado...



#472771 - 26/03/2017 08:06:25

OMAR2011
MONTES CLAROS
Cadast. em:Setembro/2011


Última edição em 26/03/2017 08:48:07 por OMAR2011

Abre apenas uma única vez no Load do Form.
E fecha no Unload.
Apenas as tabelas Abre e Fecha.
Quanto ao Vba nada a comentar.




#472790 - 26/03/2017 21:51:37

ADILSOO
PRATANIA
Cadast. em:Março/2012


Tome cuidado ao abrir a conexão e deixar aberta, o usuário pode deixar a tela aberta por muito tempo sem usar, o que pode causar problemas em uma conexão com algum servidor online por exemplo.

O ideal é sempre que precisar pegar alguma informação, abre e já fecha em seguida.

O importante não é oque você sabe hoje, e sim o quanto você pode evoluir amanhã!
Meu Skype: adilson.skype1


#472798 - 27/03/2017 08:10:34

OMAR2011
MONTES CLAROS
Cadast. em:Setembro/2011


Veja.
http://www.vbmania.com.br/index.php?modulo=forum&metodo=abrir&id=353701



#472824 - 27/03/2017 22:31:47

MILTONSILVA94
CANOAS / RIO GRANDE DO SUL
Cadast. em:Janeiro/2015


Citação:
:
Abre apenas uma única vez no Load do Form.
E fecha no Unload.
Apenas as tabelas Abre e Fecha.
Quanto ao Vba nada a comentar.


Obrigado pela ajuda.

Citação:
:
Tome cuidado ao abrir a conexão e deixar aberta, o usuário pode deixar a tela aberta por muito tempo sem usar, o que pode causar problemas em uma conexão com algum servidor online por exemplo.

O ideal é sempre que precisar pegar alguma informação, abre e já fecha em seguida.


Na minha empresa passo por isso, o software vive trancando nos formulários por causa das conexões simultâneas.

Citação:
:
Veja.
http://www.vbmania.com.br/index.php?modulo=forum&metodo=abrir&id=353701


Irei analisar e estudar nos próximos dias este assunto.

Obrigado colegas!



#477690 - 07/11/2017 19:50:55

PETERSONTDS
NOVA SERRANA
Cadast. em:Setembro/2017


Irei te ajudar de forma bem simples, e a forma que eu gosto de programar menor quantidade de linhas possível
Você abriu um tópico sobre navegação de registros e acabou não conseguindo o que queria e fez uma adapitação
Neste que uma conexão com banco de dados, com o mesmo exemplo irei te mostrar um solução de forma simples pro seu 2 problemas

Primeiro em um Módulo Copie e Cole, se der erro e só procurar a referencia da conexão no Google, eu não me lembro dela no momento

Public db As New ADODB.Connection
Public rs As New ADODB.Recordset
Public Path As String

Public Sub ConnectBD()

    Path = App.Path & "\Banco.mdb"
    db.Open "Provider=microsoft.jet.oledb.4.0;data source=" & Path

End Sub

Public Sub DesconnectBD()
    
    If rs.State = 1 Then rs.Close: Set rs = Nothing
    If db.State = 1 Then db.Close: Set db = Nothing
      
End Sub

No Evento Change da textbox txtCodigoPerfil, copie e cole

Private Sub txtCodigoPerfil_Change()
    
    ConnectBD
    rs.Open "SELECT codigo_perfil FROM lTBPerfis WHERE codigo_perfil = " & txtCodigoPerfil.Text, db, 3, 3
    
    With rs

        txtCodigoPerfil.Text = .Fields(1)
        txtDataHora.Text = .Fields(2)
        txtPerfil.Text = .Fields(3)
        lblAtualizadoPor = .Fields(4)
        lblUltimaAtualizacao = .Fields(5)
  
        .Update

    End With

    DesconnectBD

End Sub

No Evento Click do Botão cmdProximo, copie e cole

Private Sub cmdProximo_Click()
    
    Dim PROXIMO_REGISTRO As Integer
    
    ConnectBD
    rs.Open "SELECT codigo_perfil FROM lTBPerfis", db, 3, 3

    While Not rs.EOF

        If rs(0) = txtCodigoPerfil.Text Then

            rs.MoveNext
            PROXIMO_REGISTRO = rs(0)
            rs.MoveLast 'INTERROPENDO O CÓDIGO POIS JÁ ENCONTROU O REGISTRO
            
        End If

        rs.MoveNext

    Wend

    DesconnectBD
    
    txtCodigoPerfil.Text = PROXIMO_REGISTRO
    
End Sub

No Evento Click do Botão cmdAnterior, copie e cole

Private Sub cmdAnterior_Click()
    
    Dim PROXIMO_ANTERIOR As Integer
    
    ConnectBD
    rs.Open "SELECT codigo_perfil FROM lTBPerfis", db, 3, 3

    While Not rs.EOF

        If rs(0) = txtCodigoPerfil.Text Then

            rs.MovePrevious
            PROXIMO_ANTERIOR = rs(0)
            rs.MoveLast
            
        End If

        rs.MoveNext

    Wend

    DesconnectBD
    
    txtCodigoPerfil.Text = PROXIMO_ANTERIOR
    
End Sub



#477726 - 08/11/2017 19:53:16

MILTONSILVA94
CANOAS / RIO GRANDE DO SUL
Cadast. em:Janeiro/2015


Citação:
:
Irei te ajudar de forma bem simples, e a forma que eu gosto de programar menor quantidade de linhas possível
Você abriu um tópico sobre navegação de registros e acabou não conseguindo o que queria e fez uma adapitação
Neste que uma conexão com banco de dados, com o mesmo exemplo irei te mostrar um solução de forma simples pro seu 2 problemas

Primeiro em um Módulo Copie e Cole, se der erro e só procurar a referencia da conexão no Google, eu não me lembro dela no momento

Public db As New ADODB.Connection
Public rs As New ADODB.Recordset
Public Path As String

Public Sub ConnectBD()

    Path = App.Path & "Banco.mdb"
    db.Open "Provider=microsoft.jet.oledb.4.0;data source=" & Path

End Sub

Public Sub DesconnectBD()
    
    If rs.State = 1 Then rs.Close: Set rs = Nothing
    If db.State = 1 Then db.Close: Set db = Nothing
      
End Sub

No Evento Change da textbox txtCodigoPerfil, copie e cole

Private Sub txtCodigoPerfil_Change()
    
    ConnectBD
    rs.Open "SELECT codigo_perfil FROM lTBPerfis WHERE codigo_perfil = " & txtCodigoPerfil.Text, db, 3, 3
    
    With rs

        txtCodigoPerfil.Text = .Fields(1)
        txtDataHora.Text = .Fields(2)
        txtPerfil.Text = .Fields(3)
        lblAtualizadoPor = .Fields(4)
        lblUltimaAtualizacao = .Fields(5)
  
        .Update

    End With

    DesconnectBD

End Sub

No Evento Click do Botão cmdProximo, copie e cole

Private Sub cmdProximo_Click()
    
    Dim PROXIMO_REGISTRO As Integer
    
    ConnectBD
    rs.Open "SELECT codigo_perfil FROM lTBPerfis", db, 3, 3

    While Not rs.EOF

        If rs(0) = txtCodigoPerfil.Text Then

            rs.MoveNext
            PROXIMO_REGISTRO = rs(0)
            rs.MoveLast 'INTERROPENDO O CÓDIGO POIS JÁ ENCONTROU O REGISTRO
            
        End If

        rs.MoveNext

    Wend

    DesconnectBD
    
    txtCodigoPerfil.Text = PROXIMO_REGISTRO
    
End Sub

No Evento Click do Botão cmdAnterior, copie e cole

Private Sub cmdAnterior_Click()
    
    Dim PROXIMO_ANTERIOR As Integer
    
    ConnectBD
    rs.Open "SELECT codigo_perfil FROM lTBPerfis", db, 3, 3

    While Not rs.EOF

        If rs(0) = txtCodigoPerfil.Text Then

            rs.MovePrevious
            PROXIMO_ANTERIOR = rs(0)
            rs.MoveLast
            
        End If

        rs.MoveNext

    Wend

    DesconnectBD
    
    txtCodigoPerfil.Text = PROXIMO_ANTERIOR
    
End Sub


Hummm... Obrigado PETERSONTDS
Este assunto vou comentando ao longo dos próximos dias aqui no fórum. Preciso concluir algumas outras prioridades.



 Tópico anterior Próximo tópico Novo tópico


Para responder este tópico o login é requerido
Se você já possui uma conta de usuário por favor faça seu login
Se você não possui uma conta de usuário use a opção Criar usuário