Usar a mesma conexao

[alissong 1]

Pessoal, criei esses comandos para conectar com o mysql com o visual basic 06. Nesse sistema existem muitos formulários, mas vou disponibilizar somente código completo para cadastrar usuário no sistema:1° Construir um módulo chamado conexão: Veja o código:'''''''''''''''''''''''''''Public mycon As New ADODB.ConnectionPublic myrs As New ADODB.RecordsetPublic calther As StringPublic sql As String''''''''''''''''''''''''''''2º Construir o código do formulário usuário: Veja o código:'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Dim AdoUsuario As New ADODB.RecordsetPrivate Sub cpf_GotFocus()cpf.Mask = "##############"End SubPrivate Sub cpf_LostFocus()If Len(cpf.Text) > 0 ThenSelect Case Len(cpf.Text) Case Is = 11 cpf.Mask = "###.###.###-##" If Not calculacpf(cpf.Text) Then MsgBox "CPF com DV incorreto !!" cpf.Mask = "##############" cpf.SetFocus End IfEnd SelectEnd IfEnd SubPrivate Sub Form_Load()On Error GoTo Form_Load ' Erro ao carregar formulário'Centraliza o formulário na área de trabalho do MDI:Me.Left = (MDIFormDespesa.ScaleWidth - Me.Width) / 2Me.Top = (MDIFormDespesa.ScaleHeight - Me.Height) / 2Screen.MousePointer = vbHourglassIf AdoUsuario.State = 1 Then Set AdoUsuario = Nothingsql = "select * from usuario order by nome_usuario"AdoUsuario.Open sql, mycon, adOpenDynamic, adLockPessimisticmycon.Execute sqlAdoUsuario.MoveFirstAdoUsuario.CacheSize = 30mostradadosregistro_usuariotipo_usuario.AddItem "Administrador"tipo_usuario.AddItem "Usuario"Form_Load_exit:Screen.MousePointer = vbDefaultExit SubForm_Load:MsgBox Err.Description, vbInformation, "Erro ao [Form_Load]"End SubPrivate Sub cmdAlterar_Click()On Error GoTo cmdEditar ' Erro ao alterar registro'Habilita todos os camposnome_usuario.Locked = Falsecpf.Enabled = Truesenha.Locked = Falsetipo_usuario.Locked = False'Habilita os botões comandoscmdexcluir.Enabled = Truecmdgravar.Enabled = True'Desabilita os botões comandoscmdincluir.Enabled = Falsenome_usuario.SetFocuscmdEditar_exit:Exit SubcmdEditar:MsgBox Err.Description, vbInformation, "Erro ao [cmdalterar]"End SubPrivate Sub cmdCancelar_Click()On Error GoTo cmdcancelar ' Erro ao cancelarScreen.MousePointer = vbHourglassAdoUsuario.CancelUpdatemostradadosregistro_usuario'Habilita o botão incluircmdincluir.Enabled = Truecmdgravar.Enabled = Falsecmdcancelar.Enabled = False'Desabilita os campos do formulárionome_usuario.Locked = Truecpf.Enabled = Falsesenha.Locked = Truetipo_usuario.Locked = TrueScreen.MousePointer = vbDefaultcmdcancelar_exit:Exit Subcmdcancelar:MsgBox Err.Description, vbInformation, "Erro ao [cmdcancelar]"End SubPrivate Sub cmdexcluir_Click()On Error GoTo cmdexcluirIf MsgBox("Deseja excluir o cliente ?", vbYesNo + vbCritical + vbDefaultButton1, "Excluir") = vbYes Then'Desabilita o botão gravarcmdgravar.Enabled = False'Desabilita o botão excluircmdexcluir.Enabled = FalseWith AdoUsuario.Delete.MoveNextIf .EOF Then .MovePreviousIf .BOF Then'Desabilita os camposnome_usuario.Locked = Truecpf.Enabled = Falsesenha.Locked = Truetipo_usuario.Locked = TrueMsgBox "Não há dados no arquivo !", vbInformation, "Excluir"End IfEnd IfEnd WithEnd Ifmostradadosregistro_usuariocmdexcluir_exit:Exit Subcmdexcluir:MsgBox " Usuário não permissão !", vbInformation, "Excluir"End SubPrivate Sub cmdIncluir_Click()On Error GoTo cmdincluir ' Erro ao incluir registrolimpa_dadosAdoUsuario.AddNewnome_usuario.Locked = Falsecpf.Enabled = Truesenha.Locked = Falsetipo_usuario.Locked = False'Desabilita o botão incluircmdincluir.Enabled = False'Habilita o botao cancelarcmdcancelar.Enabled = True'Habilita o botao gravarcmdgravar.Enabled = Truenome_usuario.SetFocuscmdincluir_exit:Exit Subcmdincluir:MsgBox Err.Description, vbInformation, "Erro ao [cmdincluir]"End SubPrivate Sub cmdanterior_Click()On Error GoTo cmdanterior 'Erro ao mover registroIf Not AdoUsuario.BOF Then AdoUsuario.MovePreviousIf AdoUsuario.BOF And AdoUsuario.RecordCount > 0 ThenBeepAdoUsuario.MoveFirstEnd Ifmostradadosregistro_usuariocmdanterior_exit:Exit Subcmdanterior:MsgBox Err.Description, vbInformation, "Erro ao [cmdanterior]"End SubPrivate Sub cmdFechar_Click()On Error GoTo cmdfecharIf MsgBox("Deseja fechar o formulário ?", vbYesNo + vbCritical + vbDefaultButton1, "Fechar") = vbYes ThenUnload MeEnd IfExit Subcmdfechar_exit:Set AdoUsuario = Nothingcmdfechar:MsgBox Err.Description, vbInformation, "Erro em [cmdfechar]"End SubPrivate Sub cmdGravar_Click()Dim controle As ControlFor Each controle In form_despesaIf TypeOf controle Is TextBox Thencontrole.Text = LimpaTexto(controle.Text)End IfNextOn Error GoTo cmdgravar ' Erro ao gravar registroIf nome_usuario.Text = Empty ThenMsgBox "Digite o login do usuario", vbExclamation, "Campo Obrigatório"nome_usuario.SetFocusExit SubEnd IfIf cpf.Text = Empty ThenMsgBox "Digite o nº do cpf", vbExclamation, "Campo Obrigatório"cpf.SetFocusExit SubEnd IfIf senha.Text = Empty ThenMsgBox "Digite a senha do usuário", vbExclamation, "Campo Obrigatório"senha.SetFocusExit SubEnd IfIf tipo_usuario.Text = Empty ThenMsgBox "Selecione a permissão do usuário ", vbExclamation, "Campo Obrigatório"tipo_usuario.SetFocusExit SubEnd IfScreen.MousePointer = vbHourglassmycon.BeginTrans AdoUsuario("nome_usuario") = "" & nome_usuario.Text AdoUsuario("cpf") = "" & cpf.Text AdoUsuario("senha") = "" & senha.Text AdoUsuario("tipo_usuario") = "" & tipo_usuario.Text AdoUsuario.Update AdoUsuario.Requerymycon.CommitTrans 'Desabilita o botão cancelarcmdcancelar.Enabled = False'Desabilita o botão gravarcmdgravar.Enabled = False'Desabilita o botão excluircmdexcluir.Enabled = False'Habilita o botão incluircmdincluir.Enabled = True'Bloqueia todos os camposnome_usuario.Locked = Truecpf.Enabled = Falsesenha.Locked = Truetipo_usuario.Locked = TrueMsgBox "Operação realizada com sucesso !", vbInformation, "Salvar Inclusão / Alteração"form_usuario.RefreshScreen.MousePointer = vbDefaultcmdgravar_exit:Exit SubIf cmdgravar Then mycon.RollbackTransExit Subcmdgravar:MsgBox Err.Description, vbInformation, "Erro em [cmdgravar]"cmdCancelar_ClickEnd SubPrivate Sub cmdprimeiro_Click()On Error GoTo cmdprimeiro 'Erro ao mover registroAdoUsuario.MoveFirstmostradadosregistro_usuarioBeepcmdprimeiro_exit:Exit Subcmdprimeiro:MsgBox Err.Description, vbInformation, "Erro ao [cmdprimeiro]"End SubPrivate Sub cmdproximo_Click()On Error GoTo cmdproximo ' Erro ao mover registroIf Not AdoUsuario.EOF Then AdoUsuario.MoveNextIf AdoUsuario.EOF And AdoUsuario.RecordCount > 0 ThenBeepAdoUsuario.MoveLastEnd Ifmostradadosregistro_usuariocmdproximo_exit:Exit Subcmdproximo:MsgBox Err.Description, vbInformation, "Erro ao [cmdproximo]"End SubPrivate Sub cmdultimo_Click()On Error GoTo cmdultimo ' Erro ao mover registroAdoUsuario.MoveLastmostradadosregistro_usuarioBeepcmdultimo_exit:Exit Subcmdultimo:MsgBox Err.Description, vbInformation, "Erro ao [cmdultimo]"End SubPrivate Sub Form_KeyPress(KeyAscii As Integer)'Movendo os campos com tecla enterIf KeyAscii = 13 Then SendKeys "{TAB}"End IfKeyAscii = Asc(UCase(Chr(KeyAscii)))End SubPrivate Sub mostradados()On Error GoTo mostradadosIf AdoUsuario.BOF = True Or AdoUsuario.EOF = True ThenExit Sub'se o ponteiro esta no fim do arquivo ou no comeco saiEnd IfIf IsNull(AdoUsuario("cod_usuario")) Thencod_usuario.Text = ""Elsecod_usuario.Text = AdoUsuario("cod_usuario")End IfIf IsNull(AdoUsuario("nome_usuario")) Thennome_usuario.Text = ""Elsenome_usuario.Text = AdoUsuario("nome_usuario")End IfIf IsNull(AdoUsuario("cpf")) Thencpf.Text = ""Elsecpf.Text = AdoUsuario("cpf")End IfIf IsNull(AdoUsuario("senha")) Thensenha.Text = ""Elsesenha.Text = AdoUsuario("senha")End IfIf IsNull(AdoUsuario("tipo_usuario")) Thentipo_usuario.Text = ""Elsetipo_usuario.Text = AdoUsuario("tipo_usuario")End IfIf IsNull(AdoUsuario("data_cadastro")) Thendata_cadastro.Text = ""Elsedata_cadastro.Text = AdoUsuario("data_cadastro")End Ifregistro_usuarioOn Error GoTo 0mostradados_exit:Exit Submostradados:MsgBox Err.Description, vbExclamation, "Erro em [mostradados]"End SubPrivate Sub registro_usuario()numeroregistros = AdoUsuario.RecordCountregistro.Caption = " Registro : " & (AdoUsuario.AbsolutePosition) & " / " & numeroregistrosEnd SubPrivate Sub limpa_dados()cod_usuario.Text = ""nome_usuario.Text = ""cpf.Text = ""senha.Text = ""tipo_usuario.Text = ""data_cadastro.Text = ""End SubPrivate Sub tipo_usuario_GotFocus()SendKeys "{F4}"End Sub'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''FIM3º Construir o código de conexão com banco mysql: No formulário chamado apresentação que após 5 segundo exibe o formulário de login para ter acesso ao formulário MDIFormDespesa: Veja o código.'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''InicioPrivate Sub Timer1_Timer()On Error GoTo ErrConexao ' Inicia o tratamento de erro na conexãoSet mycon = New ADODB.Connectionmycon.ConnectionTimeout = 60mycon.CommandTimeout = 400mycon.CursorLocation = adUseClientmycon.Open "driver={MySQL ODBC 3.51 Driver};DSN=orcamento;OPTION=3;server=localhost;uid=root;pwd=xxx;PORT=3306;database=orcamento"Unload Meform_login.ShowExit SubErrConexao:With ErrIf .Number <> 0 ThenMsgBox " Houve um erro na conexão com o banco de dados." & _vbCrLf & " O sistema será encerrado ?", _vbCritical + vbOKOnly + vbApplicationModal, _" Erro nao conexão".Number = 0Set mycon = NothingEndEnd IfEnd WithEnd SubDim ctr As IntegerDim xTextPrivate Sub cmdlocalizar_Click()On Error GoTo cmdLocalizar ' Erro ao localizar usuariosDim LoginOK As BooleanDim rsUsu As ADODB.RecordsetLoginOK = FalseIf txtusuario.Text = "" Then MsgBox "Digite o Nome do Usuário !", vbExclamation + vbCritical, " Campo Obrigatório" txtusuario.SetFocus Exit SubEnd IfIf txtsenha.Text = "" Then MsgBox "Digite a Senha do Usuário !", vbExclamation + vbCritical, " Campo Obrigatório" txtsenha.SetFocus Exit SubEnd If'abrir uma consulta com o usuário informadosql = "SELECT * FROM usuario WHERE nome_usuario ='" & txtusuario.Text & "'"Set rsUsu = mycon.Execute(sql)'verificar se encontrou o usuárioIf rsUsu.EOF = True Then MsgBox "Usuário não encontrado !", vbExclamation + vbCritical, "O Usuário não confere" txtusuario.SetFocusElse 'se encontrou, verificar a senhaIf rsUsu.Fields("senha") = txtsenha.Text Then LoginOK = True 'definir que o usuário foi encontrado e a senha está OKElsectr = ctr + 1If ctr = 4 ThenEndElsexText = "Você tem mais" + Str(4 - ctr) + " chances"If ctr = 3 ThenxText = "Esta é sua última chance !!"End If MsgBox "Senha incorreta !" & vbCrLf & _ xText, vbExclamation + vbCritical, "Senha não confere" txtsenha.Text = "" txtsenha.SetFocus SendKeys "{Home}+{End}"End IfEnd IfEnd IfrsUsu.CloseSet rsUsu = NothingIf LoginOK = True Then 'exibir a mensagem de OK 'VBCrlf = quebra de linha MsgBox "Usuário encontrado com sucesso!" & vbCrLf & "Clique em OK para continuar.", vbInformation, "Autenticação OK!" Unload form_login MDIFormDespesa.ShowEnd Ifcmdlocalizar_exit:Exit SubcmdLocalizar:MsgBox Err.Description, vbInformation, "Erro ao [cmdLocalizar]"End SubPrivate Sub Form_KeyPress(KeyAscii As Integer)'Movendo os campos com tecla enterIf KeyAscii = 13 Then SendKeys "{TAB}"End IfEnd SubPrivate Sub sair_sistema_Click()On Error GoTo sair_sistema 'Erro ao sair do sistemaScreen.MousePointer = vbHourglassIf MsgBox("Deseja sair do sistema ?", vbYesNo + vbQuestion + vbApplicationModal, "Sair") = vbYes ThenUnload MeSet mycon = NothingExit SubEnd Ifsair_sistema_exit:Screen.MousePointer = vbDefaultExit Subsair_sistema:MsgBox Err.Description, vbInformation, "Erro ao [sair_sistema]"End Sub''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Está quase perfeito, pois consigo ler os dados tabela usuario, incluir, alterar, excluir. Mas existe um campo chamado cpf que é unique nessa tabela. Agora aparece um erro obvio quando o usuário digita o mesmo cpf para inclusão. Exibe o erro Foreign Key unique no cpf. Portanto, a partir desse momento o usuário perde a conexão com o banco mysql, pois não permite incluir, alterar e excluir nesse formulário e nos outros.Porque isso?Alguem ver aonde estou erro.

[Luizgrs 0]

Para evitar esse erro você tem que fazer uma verificação.Antes de efetuar um novo cadastro ou uma alteração verifique se o novo CPF já está cadastrado.Lembrando que se você for fazer essa verificação na hora da alteração você deve descartar o registro que está sendo alterado.E o fato da conexão "parar de funcionar" é que por causa do erro ela é "desfeita'.

[alissong 1]

Luizgrs,Valeu pela dica e muito obrigado....Um abraço.