há um tempo atras achei um codigo na internet pra criar um formulario de pesquisa de dados.
naquela epoca funcionou direitinho, e ainda funciona no projeto da epoca.
acontece que agora to tentando usar o mesmo codigo num outro projeto e to tendo um erro esquisito.
o codigo é:
Option Compare Database
Option Explicit
' Desenvolvido por JR - <accessjr@bol.com.br>
' Brasília - DF, em Jan/1999.
' http://www.accessjr.cjb.net
' Estas variáveis permanecerão abertas enquanto
' o formulário estiver aberto para agilizar
' as buscas subseqüentes.
Dim Rs As DAO.Recordset, Rs1 As DAO.Recordset
Dim mValor As Variant
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Set Rs = Nothing 'Libera memória
Set Rs1 = Nothing
End Sub
Private Sub cmdCancelar_Click()
On Error Resume Next
DoCmd.Close
End Sub
Private Sub cmdExibir_Click()
On Error GoTo Err_cmdExibir
With lstRetorno
If .ListCount = 0 Then GoTo Termina
End With
Forms!Alunos!Nome = Me.lstRetorno
DoCmd.Close acForm, "LOCALIZAR_CLIENTE"
Termina:
Exit Sub
Err_cmdExibir:
Select Case Err
Case 94
MsgBox "Selecione um Aluno na Caixa de Listagem.", vbInformation, "Informação"
Case Else
MsgBox Err.Description, vbCritical, "Erro"
End Select
Resume Termina
End Sub
Private Sub cmdLimpar_Click()
On Error Resume Next
txtPesquisa = ""
txtPesquisa.SetFocus
Rs1.Close
lstRetorno.Requery
lblSelecionadas.Caption = "Nenhum Aluno Filtrado"
End Sub
Private Sub lstRetorno_DblClick(Cancel As Integer)
On Error Resume Next
Call cmdExibir_Click
End Sub
Private Sub txtPesquisa_Change()
Dim strSQL As String
On Error GoTo Rs_Fechado
Pesquisa:
mValor = txtPesquisa.text
If Len(mValor & "") = 0 _
Or Asc(mValor) = 32 Then 'Limpa espaços também.
Call cmdLimpar_Click
Exit Sub
End If
'Na primeira vez, a rotina desviará para o rótulo
'Rs_Fechado, pois o Recordset ainda não foi aberto.
'Na 2ª vez em diante, a rotina prossegue normalmente.
With Rs
.Filter = Me.FindBy & " Like '*" & adhHandleQuotes(mValor, "'") & "*'"
Set Rs1 = .OpenRecordset
'Move para último p/ fazer contagem na função PreencheLista
If Rs1.RecordCount <> 0 Then Rs1.MoveLast
lstRetorno.Requery
End With
Fim:
Exit Sub
Rs_Fechado:
Select Case Err
Case 91, 3420 'Ocorre só na primeira vez em que é pesquisado um item.
strSQL = "SELECT COD, Matr, Nome, Telefone, Celular, Bairro " _
& "FROM CLIENTES ORDER BY Nome"
'Cria um recordset bem rápido, pois é SnapShot.
Set Rs = DBEngine(0)(0).OpenRecordset(strSQL, dbOpenSnapshot)
GoTo Pesquisa
Case 5 'ocorre ao voltar com BackSpace, apagando o texto.
Resume Next
Case Else
MsgBox "Erro nº " & Err & vbCrLf _
& Err.Description, vbCritical, "Erro"
End Select
Resume Fim
End Sub
Function PreencheLista(ctl As Control, varID As Variant, lngRow As Long, _
lngCol As Long, intCode As Integer) As Variant
'Função CallBack padrão para preencher Combo/List box.
On Error GoTo Err_Preenche
Dim valret As Variant 'Retorno p/ cada um dos intCode indicados em Select Case.
Dim I As Integer
Static strNome() As Variant 'cria matriz dinâmica
Static sContaReg As Integer
sContaReg = Rs1.RecordCount
I = 0
valret = Null
Select Case intCode
Case acLBInitialize ' Inicializa.
With Rs1
ReDim strNome(sContaReg, 5) 'redimensiona conforme nº linhas do recordset
.MoveFirst
For I = 0 To sContaReg - 1
strNome(I, 0) = !COD
strNome(I, 1) = !Matr
strNome(I, 2) = !Nome
strNome(I, 3) = !Telefone
strNome(I, 4) = !Celular
strNome(I, 5) = !Bairro
.MoveNext
Next I
End With
valret = True 'deve ser diferente de zero ou Null para prosseguir.
Case acLBOpen ' Abre.
valret = Timer ' Gera Código exclusivo.
Case acLBGetRowCount ' Obtém linhas.
valret = -1 ' significa desconhecido
'Case acLBGetColumnCount ' Obtém colunas.
'valret = 2
'Case acLBGetColumnWidth ' Obtém a largura da coluna.
'valret = -1 ' Utiliza a largura padrão.
Case acLBGetValue ' Obtém os dados.
valret = strNome(lngRow, lngCol)
Case acLBEnd 'Fim
Erase strNome 'limpa a matriz.
End Select
PreencheLista = valret 'preenche a Listbox
lblSelecionadas.Caption = sContaReg & " Aluno(s) Filtrado(s)"
Exit Function
Err_Preenche:
Select Case Err
Case 9, 91 ' Erro gerado na 1ª vez que abrir
Resume Next
Case 3420, 3021 ' Causado pelo botão Limpar (Rs1.Close)
PreencheLista = Null
Case Else
MsgBox "Erro nº " & Err & vbCrLf _
& Err.Description, vbCritical, "Erro"
End Select
End Function
o erro acontece quando vou usar o form de pesquisa e digito algo. ai da erro:
Erro de compilação:
Sub ou Fuction não definida.
e ele marca o .FindBy abaixo:
Private Sub txtPesquisa_Change()
Dim strSQL As String
On Error GoTo Rs_Fechado
Pesquisa:
mValor = txtPesquisa.text
If Len(mValor & "") = 0 _
Or Asc(mValor) = 32 Then 'Limpa espaços também.
Call cmdLimpar_Click
Exit Sub
End If
'Na primeira vez, a rotina desviará para o rótulo
'Rs_Fechado, pois o Recordset ainda não foi aberto.
'Na 2ª vez em diante, a rotina prossegue normalmente.
Pergunta
Humm
há um tempo atras achei um codigo na internet pra criar um formulario de pesquisa de dados.
naquela epoca funcionou direitinho, e ainda funciona no projeto da epoca.
acontece que agora to tentando usar o mesmo codigo num outro projeto e to tendo um erro esquisito.
o codigo é:
o erro acontece quando vou usar o form de pesquisa e digito algo. ai da erro:
Erro de compilação:
Sub ou Fuction não definida.
e ele marca o .FindBy abaixo:
alguém tem ideia do que possa ser?
já verifiquei se era falta da referencia Microsoft DAO 3.6 mas no access 2007 ela já vem como padrão.
Editado por HummLink para o comentário
Compartilhar em outros sites
1 resposta a esta questão
Posts Recomendados
Participe da discussão
Você pode postar agora e se registrar depois. Se você já tem uma conta, acesse agora para postar com sua conta.