[Resolvido]Valor de Grupo Opções conforme o numero de linhas da numa listBox

Boa noite Amigos



Obrigado

Bom dia Assis,
Ao clicar faz um Dcount(...) dos registos que vai mostrar.
Assim já tem o numero de linhas e pode controlar (com IF ou Select Case) qual o grupo que pretende mostar.

Abraço

Bom dia Teixeira
Eu não queria clikar no Grupo Opções.
No Load.....
O número de linhas é que decidia o valor do Grupo Opções.

Veja o simples;

Código:

Private Sub Form_Load()
Dim ListControl As Control

 Set ListControl = Me.Lista
 
 With ListControl
 Select Case .ListCount
  Case Is <= 15
    Me.Quadro.Value = 4
  Case Is > 15
    Me.Quadro.Value = 3
 End Select
 End With
End Sub


Bom dia JPaulo

Mesmo tendo + que 15 ou - de 15 linhas na Lista o valor do Quadro mantem-se sempre 4.

Obrigado

Boa JPaulo.
Assis, talvez falte o Me.Lista.Requery.
Mostre como tem o codigo da Sub
Abraço a todos

Assis, todos os testes que fiz aqui funcionaram em pleno.

Por isso aí também tem de funcionar, é só ter olho vivo.

Veja se ajuda;

JPaulo

No seu exemplo sim funciona, mas no meu não...

Obrigado e bom fim de semana

Boa tarde Amigos

Assim consigo o objetivo no nº de linha a mostrar.
Mas o valor do Grupo Opção " Quadro " é sempre o mesmo ( 3 )

Criei um campo novo " txtc "

Me.txtc = Me.Lista.ListCount


If Me.txtc.Value < 15 Then
Me.Quadro.Value = 4
Else
Me.Quadro.Value = 3
End If

Alguma ideia para o valor do Quadro não alterar ?

PS - Tentei postar parte da BD, mas como é dividida e o formulário em causa tem dados de outros formulários é difícil.

Olá Assis,
Poste o código todo que tem nos eventos desse formulário, para ver se encontramos o que está acontecer.
Abraço a todos

Ai vai Teixeira,

Código:

Option Compare Database
Option Explicit
Dim filtro As String
Dim tblTemp As String

Private Sub bt_sair_Click()
On Error Resume Next
Me.txtData = "" 'Null
shell ("taskkill /F /IM Teclado.exe")
DoCmd.Close
End Sub

Private Sub Comando110_Click()
On Error Resume Next
DoCmd.OpenForm "Calculadora"
End Sub

Private Sub Comando65_Click()

If IsNull(Me.txtHistorico) Then
MsgBox "Falta Preencher o Movimento", vbInformation, "Campo Obrigatório"
Me.txtHistorico.SetFocus

Exit Sub
Else
 If IsNull(Me.Rubrica) Then
MsgBox "Falta Preencher a Rubrica", vbInformation, "Campo Obrigatório"
Me.Rubrica.SetFocus

 Exit Sub
 Else
   If IsNull(Me.Entidade) Then
MsgBox "Falta Preencher a Entidade", vbInformation, "Campo Obrigatório"
Me.Entidade.SetFocus

 Exit Sub
 Else
  If IsNull(Me.ValorMovimento) Or Me.ValorMovimento.Value = "0.00 €" Or Me.ValorMovimento.Value = "" Then
MsgBox "O Valor do Lançamento tem que ser maior que Zero !", vbInformation, "Campo Obrigatório"
Me.ValorMovimento.SetFocus

Exit Sub
End If

If Me.Contabilistico.Value < CDbl(Me.ValorMovimento) And Me.TipoMov = "C" Then
MsgBox "Não tem Saldo Disponivel para Efectuar este Lançamento  !", vbInformation, "Gestão Bancária"
Call Comando68_Click
Exit Sub
End If
 End If
 End If
 End If
 
 Dim Msg As String
On Error GoTo 1

Dim BCO As Database

Dim Lançamentos As Recordset
Dim LançamentosDatados As Recordset

If MsgBox("Confirma o Registo do Lançamento ?" & vbCrLf & txtData & vbCrLf & Me.txtHistorico & vbCrLf & Me.Rubrica & vbCrLf & Me.Entidade & vbCrLf & "Valor  " & Format(ValorMovimento, "#,##0.00 €") & " ?", vbYesNo, "Gestão Bancária") = vbNo Then
MsgBox "Registo do Lançamento Cancelado", vbInformation, "Gestão Bancária"
Call Comando68_Click
Exit Sub
End If

Set BCO = CurrentDb()

If Me.txtData <= Date Then
Set Lançamentos = BCO.OpenRecordset("tblmovimento")

Lançamentos.AddNew

Lançamentos![IdCaixa] = Me.IdCaixa
Lançamentos![DataMovimento] = Me.txtData
Lançamentos![Historico] = Me.txtHistorico
Lançamentos![Rubrica] = Me.Rubrica
Lançamentos![Entidade] = Me.Entidade
Lançamentos![Doc] = Me.TxtDoc
Lançamentos![ValorMovimento] = ValorMovimento
Lançamentos![Ordenar] = txtData + Time

If Me.TipoMov = "D" Then
Lançamentos![ValorDebito] = ValorMovimento
Lançamentos![ValorCredito] = 0
ElseIf Me.TipoMov = "C" Then
Lançamentos![ValorCredito] = ValorMovimento
Lançamentos![ValorDebito] = 0
End If
Lançamentos.Update
Lançamentos.Close
Else
MsgBox "Este Movimento Vai Ficar Pendente ! " & vbCrLf & "          Até Dia " & txtData & " ", vbInformation, "Aviso"
Set LançamentosDatados = BCO.OpenRecordset("tblmovimentoData")
LançamentosDatados.AddNew

LançamentosDatados![IdCaixa] = Me.IdCaixa
LançamentosDatados![DataMovimento] = Me.txtData
LançamentosDatados![Historico] = Me.txtHistorico
LançamentosDatados![Rubrica] = Me.Rubrica
LançamentosDatados![Entidade] = Me.Entidade
LançamentosDatados![Doc] = Me.TxtDoc
LançamentosDatados![ValorMovimento] = ValorMovimento
LançamentosDatados![Ordenar] = txtData + Time

If Me.TipoMov = "D" Then
LançamentosDatados![ValorDebito] = ValorMovimento
LançamentosDatados![ValorCredito] = 0
ElseIf Me.TipoMov = "C" Then
LançamentosDatados![ValorCredito] = ValorMovimento
LançamentosDatados![ValorDebito] = 0
End If
LançamentosDatados.Update
LançamentosDatados.Close
End If

Call fncAuditar(Me.Name, 0, Me.Texto94 & " Movimentação " & Me!txtHistorico & " - " & Me.Rubrica & " - " & Format(ValorMovimento, "#,##0.00 €"))

Call fncMontaSaldo
Call Form_Current

Me.Comando65.Visible = True
Me.Comando96.Visible = False
Me.Comando97.Visible = False
Call Comando68_Click
Me.txtData = Forms.menu.DataMenu
Me.txtData.SetFocus
Me.txtData.SelStart = 0
Me.Lista.Requery

Exit_1:
DoCmd.Hourglass False
DoCmd.Echo True
Exit Sub

1 A:
DoCmd.Hourglass False
DoCmd.Echo True
Msg = "Erro # " & Str(Err.Number) & " Gerado na " & Err.Source _
& vbNewLine & vbNewLine & "Descrição: " & Err.Description _
& vbNewLine & vbNewLine & "Por favor contate o Administrador de Sistema."
MsgBox Msg, vbMsgBoxHelpButton + vbCritical, "Erro", Err.Helpfile, Err.HelpContext
Resume Exit_1




End Sub

Private Sub Comando65_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Me.Comando65.ForeColor = 255
Me.Comando65.FontSize = 12
End Sub

Private Sub Comando68_Click()
On Error Resume Next
Call Form_Current
Me.IdCaixa = "" 'Null
Me.txIdMovimento = "" 'Null
Me.txtHistorico = "" 'Null
Me.Rubrica = "" 'Null
Me.Entidade = "" 'Null
Me.ValorMovimento = "0.00 €"
Me.TxtDoc = "" 'Null
Me.txVelho = "" 'Null
Me.txtTotalCarateres = "" 'Null
Me.txtData = Forms.menu.DataMenu
Me.Comando65.Enabled = False
Me.Comando96.Visible = False
Me.Comando97.Visible = False
Me.txtData.SetFocus
End Sub



Private Sub Comando68_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Comando68.ForeColor = 255
Me.Comando68.FontSize = 12
End Sub

Private Sub Comando96_Click()

Dim varItem As Variant

If Me.Lista.ItemsSelected.Count = 0 Then
   DoCmd.Beep
   MsgBox "Nenhum Movimento Selecionado! " & vbCrLf & "Selecione o Registo a Anular com um Click !", vbInformation, "ATENÇÃO"
Exit Sub
End If

If Lista.Column(3) = "Transferência" Then
MsgBox "As Transferências entre Contas Não São Eliminadas neste Painel " & vbCrLf & "Tem um Menu Próprio !", vbOKOnly + vbInformation, "Gestão Bancária"
Me.Foco.SetFocus
Exit Sub
End If



For Each varItem In Lista.ItemsSelected
If MsgBox("Confirma Eliminação do Registo ?" & vbCrLf & Lista.Column(1) & vbCrLf & Lista.Column(2) & vbCrLf & Lista.Column(3) & vbCrLf & Lista.Column(4) & " ?", vbYesNo, "Gestão Bancária") = vbYes Then

CurrentDb.Execute "DELETE * FROM tblmovimento WHERE idmovimento =" & CLng(Me.Lista.Column(0)) & ";"

Call fncAuditar(Me.Name, 1, Me.Texto94 & " Anular Movimento " & Me!txtHistorico & " - " & Me.Rubrica & " - " & Format(ValorMovimento, "#,##0.00 €"))


MsgBox "Movimento Anulado com Sucesso!", vbOKOnly + vbInformation, "Gestão Bancária"
Call fncMontaSaldo
Call Form_Current
Me.Lista.Requery
Me.Foco.SetFocus
Call Comando68_Click
Else
Me.Foco.SetFocus
Call Comando68_Click
Me.Lista.Selected(varItem) = False
Me.txtData.SetFocus
Exit Sub
End If

Next varItem

End Sub

Private Sub Comando96_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Me.Comando96.ForeColor = 255
Me.Comando96.FontSize = 12
End Sub

Private Sub Comando97_Click()
On Error Resume Next

If Lista.Column(3) = "Transferência" Then
MsgBox "As Transferências entre Contas não Podem ser Alteradas " & vbCrLf & "Tem de ser Eliminadas num Menu Próprio !", vbOKOnly + vbInformation, "Gestão Bancária"
Me.Foco.SetFocus
Exit Sub
End If


If (Me!txIdMovimento.ForeColor <> 255) Or (Len(Me!txIdMovimento & "") = 0) Then

MsgBox "Nenhum Campo Foi Alterado!", vbOKOnly + vbInformation, "Gestão Bancária"
Me.Foco.SetFocus
Exit Sub
Else

If MsgBox("Confirma a Alteração do Movimento ?" & vbCrLf & Lista.Column(1) & vbCrLf & Lista.Column(2) & vbCrLf & Lista.Column(3) & vbCrLf & Lista.Column(4) & " ?", vbYesNo, "Gestão Bancária") = vbYes Then
 
 
 If Me.Contabilistico < Me.ValorMovimento.Value And Me.TipoMov = "C" Then
MsgBox "Não tem Saldo Disponivel para Efectuar este Lançamento  !", vbInformation, "Gestão Bancária"
Call Comando68_Click
Exit Sub
End If

If IsNull(Me.txtHistorico) Then
MsgBox "Falta Preencher o Movimento", vbInformation, "Campo Obrigatório"
Me.txtHistorico.SetFocus
Exit Sub
Else
 If IsNull(Me.Rubrica) Then
MsgBox "Falta Preencher a Rubrica", vbInformation, "Campo Obrigatório"
Me.Rubrica.SetFocus
 Exit Sub
 Else
   If IsNull(Me.Entidade) Then
MsgBox "Falta Preencher a Entidade", vbInformation, "Campo Obrigatório"
Me.Entidade.SetFocus
 Exit Sub
 Else
  If IsNull(Me.ValorMovimento) Or Me.ValorMovimento.Value = "0.00 €" Or Me.ValorMovimento.Value = "" Then
MsgBox "O Valor do Lançamento tem que ser maior que Zero !", vbInformation, "Campo Obrigatório"
Me.ValorMovimento.SetFocus
Exit Sub
End If

 End If
 End If
 End If
 
Dim db1 As Database, rs As Recordset
   Set db1 = CurrentDb()
   Set rs = db1.OpenRecordset("tblmovimento", dbOpenDynaset)
   rs.FindFirst "idmovimento = " & Me.txIdMovimento
   rs.Edit
   
   rs("idmovimento") = Me.txIdMovimento
   rs("idcaixa") = Me.IdCaixa
   rs("datamovimento") = Me.txtData
   rs("Historico") = Me.txtHistorico
   rs("rubrica") = Me.Rubrica
   rs("entidade") = Me.Entidade
   rs("doc") = Me.TxtDoc
   rs("valormovimento") = Me.ValorMovimento
   rs("Ordenar") = txtData + Time()
   If Me.TipoMov = "D" Then
   rs("valordebito") = ValorMovimento
   rs("valorcredito") = 0
   ElseIf Me.TipoMov = "C" Then
   rs("valorcredito") = ValorMovimento
   rs("valordebito") = 0
   End If
   
   If Me.txtHistorico = "Saldo Inicial" Then
   CurrentDb.Execute "UPDATE Banco SET saldoinicial='" & Me.ValorMovimento.Value & "' WHERE nbanco = " & Me!IdCaixa & ";"
   Else
   End If
   
   rs.Update
   rs.Close
   Set rs = Nothing
   Set db1 = Nothing


Call fncMontaSaldo
Call Form_Current

MsgBox "Movimento Alterado com Sucesso!", vbOKOnly + vbInformation, "Gestão Bancária"

Call fncAuditar(Me.Name, 2, Me.Texto94 & " Alterar Movimento " & Me!txtHistorico & " - " & Me.Rubrica & " - " & Format(ValorMovimento, "#,##0.00 €"))


Me.txtHistorico = "" 'Null
Me.Rubrica = "" 'Null
Me.Entidade = "" 'Null
Me.ValorMovimento = "0.00 €"
Me.TxtDoc = "" 'Null
Me.Foco.SetFocus
Call Comando68_Click
Else

Me.txtHistorico = "" 'Null
Me.Rubrica = "" 'Null
Me.Entidade = "" 'Null
Me.ValorMovimento = "0.00 €"
Me.TxtDoc = "" 'Null
Me.Foco.SetFocus
Call Comando68_Click
End If
End If
End Sub

Private Sub Comando97_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Comando97.ForeColor = 255
Me.Comando97.FontSize = 12
End Sub

Private Sub Div_Click()
On Error Resume Next
DoCmd.OpenForm "Dividido"
End Sub

Private Sub Div_LostFocus()
Me.Div.ForeColor = vbYellow
Me.Div.FontSize = 10
End Sub

Private Sub Entidade_AfterUpdate()
Me.TxtDoc = Nz(DMax("Doc", "Lançamentos Consulta", "idcaixa = " & Me.IdCaixa & " and " & "Historico='" & Me.txtHistorico & "' AND " & "Rubrica ='" & Me.Rubrica & "'AND " & "Entidade ='" & Me.Entidade & "'")) + 1
If IsNull(Me.TxtDoc) Then
Me.TxtDoc = 1
End If

End Sub

Private Sub Entidade_Change()
If Nz(Me!txVelho) <> Nz(Me!Entidade.Text) Then fncPintaTexto (255)
Dim I As Integer, intSomaCarateres As Integer

'-----------------------------------------------------------------------
Dim strText, strFind, strFind2
      strText = Me.Entidade.Text
  If Len(Trim(strText)) > 0 Then
      strFind2 = "Entidade Like '*"
    For I = 1 To Len(Trim(strText))
  If (Right(strFind, 1) = "*") Then
      strFind = Left(strFind, Len(strFind) - 1)
  End If
      strFind = strFind & Mid(strText, I, 1) & "*"
    Next
      strFind2 = strFind2 & strFind & "'"
      strSQL = "SELECT Entidade FROM Entidade where " & strFind2 & " ORDER BY Entidade;"
      Me.Entidade.RowSource = strSQL
      Me.Entidade.Dropdown
  Else
      strSQL = "SELECT Entidade FROM Entidade ORDER BY Entidade; "
      Me.Entidade.RowSource = strSQL
  End If
'--------------------------------

'By JPaulo ® Maximo Access


'Limita o campo a 20 carateres
   If Len(Me.Entidade.Text) > 20 Then
'Se chegar aos 20 carateres, mantem apenas os 20 digitados à esquerda
       Me.Entidade.Text = Left(Me.Entidade.Text, 20)
   Me.Entidade.SelStart = 20
'Informa o usuário, através de mensagem
MsgBox "Tamanho máximo do campo, excedido...", vbCritical
'Me.Entidade = "" 'Null
End If
'Inicia o contador a zero
   intSomaCarateres = 0
For I = 1 To Me.Entidade.SelStart
       intSomaCarateres = I
   Next I
'Coloca no campo do total de carateres, um a um
Me.txtTotalCarateres.Value = intSomaCarateres
'Se o usuário apagar os carateres um a um e chegar a zero, limpa a caixa
   If Me.txtTotalCarateres.Value = 0 Then
       Me.txtTotalCarateres.Value = ""
End If
End Sub



Private Sub Entidade_GotFocus()

'Call fcor(Me!Entidade, "am")
'Me.txVelho = Me.Entidade.Value
' If IsNull(Me.txtHistorico) Then
' MsgBox "Falta Preencher o Movimento", vbInformation, "Campo Obrigatório"
' Me.txtHistorico.SetFocus
' Else
'  If IsNull(Me.Rubrica) Then
' MsgBox "Falta Preencher a Rubrica", vbInformation, "Campo Obrigatório"
' Me.Rubrica.SetFocus
'  End If
'  End If
Call fcor(Me!Entidade, "am")
Me.txVelho = Me.Entidade.Value
If IsNull(Me.txtHistorico) Then
MsgBox "Falta Preencher o Movimento", vbInformation, "Campo Obrigatório"
Me.txtHistorico.SetFocus
Else
 If IsNull(Me.Rubrica) Then
MsgBox "Falta Preencher a Rubrica", vbInformation, "Campo Obrigatório"
Me.Rubrica.SetFocus
 End If
 End If
With Me
   .ActiveControl.Requery
   .ActiveControl.Dropdown


End With

End Sub



Private Sub Entidade_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Me.Rubrica.SetFocus
End Sub

Private Sub Entidade_LostFocus()
Me.Entidade.BackColor = vbWhite
End Sub

Private Sub Entidade_NotInList(NewData As String, Response As Integer)

Dim SQL As String
Dim SQL33 As String
Dim Est1 As String
DoCmd.SetWarnings False


If NewData = "Abertura" Then
MsgBox "Entidade " & FirstCaps([NewData]) & "  Não Permitida....", vbCritical, "Gestão Bancária"
Response = acDataErrContinue
Entidade = "" 'Null
Exit Sub
Else

If MsgBox("Entidade Não Registada" & vbCrLf & "Deseja Registar a Entidade " & "Agora?", vbInformation + vbYesNo, "Nova Entidade") = vbYes Then
SQL = "INSERT INTO Entidade (Entidade) VALUES ('" & FirstCaps(NewData) & "')"
DoCmd.RunSQL SQL
Est1 = InputBox("Inserir o Nome Completo da Entidade ?", "Nome Completo")
CurrentDb.Execute "UPDATE Entidade SET nome = ('" & FirstCaps(Est1) & "') WHERE '" & NewData & "' = Entidade"
Response = acDataErrAdded
Else
Response = acDataErrDisplay
End If
DoCmd.SetWarnings True
End If
End Sub

Private Sub Foco_GotFocus()
Me.Comando65.Enabled = False 'True
Me.Comando68.Enabled = False

End Sub

Private Sub Form_Close()
On Error Resume Next
CurrentDb.Execute "Delete * From tmp_tblMovimento"
On Error Resume Next
Forms!menu.Form!Incorporado38.Requery
Forms!menu.Form.Requery
Forms![menu].Requery
Forms!menu.Form!Incorporado38.Comando7.SetFocus
End Sub



Private Sub Form_Current()
On Error Resume Next

Me.Pendente = DLookup("[SaldoPendente]", "Vpendentes")
Me.Contabilistico = Nz(Me!txSaldo, 0) + Nz(Me!Pendente, 0)
If IsNull(Me.Pendente) Then
Me.RPendente.Visible = False
Else
Me.RPendente.Visible = True
End If
'---------------
If IsNull(Me.txtHistorico) And IsNull(Me.Rubrica) And IsNull(Me.Entidade) And IsNull(Me.TxtDoc) And IsNull(Me.ValorMovimento) Then
Me.Comando65.Enabled = False
Else
Me.Comando65.Enabled = True
End If
'----------------


Me.txtc = "Total de Movimento no Periodo - " & Me.Lista.ListCount

Me.Texto117 = "Total de Movimento na Conta - " & Nz(DCount("Historico", "tblmovimento", "idcaixa = " & Me.IdCaixa & ""), 0)
Me.TxtCC = DCount("*", "Banco")


Me.DtInicio = DFirst("[datamovimento]", "tmp_tblMovimento")
Me.DtFim = DLast("[datamovimento]", "tmp_tblMovimento")


If Nz(DLast("Doc", "tblMovimento", "idcaixa = " & Me.IdCaixa & " and " & "Historico='Saldo Inicial'")) + 1 > 1 Then
Me!txtHistorico.RowSource = "SELECT Movimentos, [Tipo Mov] FROM Movimentos WHERE Movimentos<>'Saldo Inicial' ORDER BY Movimentos;"
Me.Rubrica.RowSource = "SELECT Referencia.Ref, Referencia.[Tipo Rub] FROM Referencia WHERE Referencia.Ref <> 'SLD' and Referencia.Ref <> 'Transferência' And Referencia.[Tipo Rub] = [Forms].[frmMovimentoCaixa].[TipoMov] ORDER BY Referencia.Ref;"
Me.Entidade.RowSource = "SELECT Entidade.Entidade FROM Entidade WHERE Entidade<>'Abertura' ORDER BY Entidade;"
Me.TipoMov = "D"

Else

Me.TipoMov = "D"
Me!txtHistorico.RowSource = "SELECT Movimentos, [Tipo Mov] FROM Movimentos ORDER BY Movimentos;"
Me.Rubrica.RowSource = "SELECT Referencia.Ref, Referencia.[Tipo Rub]FROM Referencia WHERE (((Referencia.[Tipo Rub]) = [Forms].[frmMovimentoCaixa].[TipoMov]))ORDER BY Referencia.Ref;"
Me.Entidade.RowSource = "SELECT Entidade.Entidade FROM Entidade ORDER BY Entidade.Entidade;"
End If
End Sub

Private Sub Form_Error(DataErr As Integer, Response As Integer)
Response = acDataErrContinue 'inibe msg padrão do access.
'MsgBox "Dados Inseridos Incorretos ! ", vbInformation, "Aviso"
ActiveControl.Undo
Exit Sub
Response = acDataErrDisplay
Response = acDataErrContinue
Exit Sub
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim intCtrlApertada As Integer
intCtrlApertada = (Shift And acCtrlMask) > 0
'Se a tecla Control estiver apertada
If intCtrlApertada Then
'Se apertar p
If (KeyCode = 80) Then
KeyCode = 0
Rem MsgBox "você pressionou control + p"
End If
End If

'Se apertar F4
If (KeyCode = 115) Then
KeyCode = 0
End If
End Sub

Private Sub Form_Load()

ReSizeForm Me
Call Center(Me)

'If Me!txtc.Value < 15 Then
'Me!Quadro.Value = 4
'Else
'Me!Quadro.Value = 3
'End If
Dim ListControl As Control

Set ListControl = Me.Lista

With ListControl
Select Case .ListCount
 Case Is <= 15
   Me.Quadro.Value = 4
 Case Is > 15
   Me.Quadro.Value = 3
End Select
End With
Me.Texto94 = Me.Conta
Me.Texto362 = Forms.menu.Ano
Call fncMontaSaldo
Call fncMontaEventos(Me)
Call Form_Current




Dim X As Long
Dim rst, rst1 As Recordset

Set rst = CurrentDb.OpenRecordset("select * from tblmovimentoData")
Set rst1 = CurrentDb.OpenRecordset("select * from tblmovimento")

X = 0

If rst.RecordCount = 0 Then Exit Sub

rst.MoveLast
rst.MoveFirst

Do While Not rst.EOF

If rst.Fields("datamovimento").Value <= Date Then
X = X + 1
rst1.AddNew
rst1.Fields("ordenar").Value = rst.Fields("ordenar").Value
rst1.Fields("DataMovimento").Value = rst.Fields("DataMovimento").Value
rst1.Fields("idcaixa").Value = rst.Fields("idcaixa").Value
rst1.Fields("Historico").Value = rst.Fields("Historico").Value
rst1.Fields("Rubrica").Value = rst.Fields("Rubrica").Value
rst1.Fields("entidade").Value = rst.Fields("entidade").Value
rst1.Fields("Doc").Value = rst.Fields("doc").Value
rst1.Fields("valordebito").Value = rst.Fields("valordebito").Value
rst1.Fields("valorcredito").Value = rst.Fields("valorcredito").Value
rst1.Fields("Reconciliado").Value = rst.Fields("Reconciliado").Value
rst1.Fields("Valormovimento").Value = rst.Fields("Valormovimento").Value
'adiciona na tabela tblmovimento
rst1.Update
'apaga na tabela tblmovimentoData
rst.Delete
Else
'se não encontra não faz nada
End If
rst.MoveNext
Loop
If X > 0 Then
MsgBox X & " Movimento(s) Pendente(s) Registado(s)", vbQuestion, "Gestão Bancária"
Else
End If

Set rst = Nothing


End Sub

Public Function fncMontaSaldo()
Dim rs As dao.Recordset
Dim Acumulado As Double
Dim strSQL As String
Dim D As Integer

Call fncLimpaCampos

Me!Lista.RowSource = ""
'--------------------------------------------------------------------------------------------------------------------
'Passa para a variavel "d" um dos valores (3,7,15,30,60,90) , dependendo da quantidade de dias escolhida no quadro
'--------------------------------------------------------------------------------------------------------------------
D = Switch(Me!Quadro = 1, 3, Me!Quadro = 2, 7, Me!Quadro = 3, 15, Me!Quadro = 4, 30, Me!Quadro = 5, 60, Me!Quadro = 6, 90, Me!Quadro = 7, 9000)
'--------------------------------------------------
'Passa para a variavel o nome da tabela temporaria
'--------------------------------------------------
tblTemp = "tmp_tblMovimento"
'------------------------------------------------------
'Monta a SQL que irá criar a tabela temporaria local
'-----------------------------------------------------
On Error GoTo 1
strSQL = "SELECT tblMovimento.*, Cdbl(0) as SaldoLinha "
strSQL = strSQL & "INTO " & tblTemp & " FROM tblMovimento "
strSQL = strSQL & "WHERE idCaixa = " & Me.IdCaixa & " And cdbl(dataMovimento) > " & CDbl(DMax("datamovimento", "tblMovimento") - D) & " ORDER BY dataMovimento;"

'---------------------------------------------------
'Executa a função que irá crar a tabela temporaria
'---------------------------------------------------
If fncCriarTabela(strSQL, tblTemp, 102030) Then
   '---------------------------------------------------------------------------------------------------------------------------------
   'Passa o Saldo do Caixa para o campo txSaldo
   'O Saldo final é composto do saldo acumulado, que fica armazenado na tabela tblConfig, mais o saldo residual da tabela tblMovimento
   'Este procedimento evita ter que somar os valores desde o primeiro registro lançado
   '---------------------------------------------------------------------------------------------------------------------------------
     
   Me!txSaldo = Nz(DLookup("SaldoCaixa", "tblConfig", "idcaixa = " & Me.IdCaixa & ""), 0) + DSum("[valordebito] - [valorcredito]", "tblMovimento", "idCaixa = " & Me.IdCaixa)
   Me!SaldoAnterior = Nz(Me!txSaldo, 0) - DSum("[valordebito] - [valorcredito]", tblTemp)
   Acumulado = Nz(Me!SaldoAnterior, 0)
 

   '--------------------------------------------------------------------------------------------------
   'Abre o recordset da tabela temporaria para calcular e salvar o saldo acumulado por linha(registro)
   'Gravar o Saldo por linha facilita a montagem do ListBox e do Relatório
   '--------------------------------------------------------------------------------------------------
   Set rs = CurrentDb.OpenRecordset("select * From " & tblTemp & " ORDER BY dataMovimento,IdMovimento")
   Do While Not rs.EOF
       Acumulado = Acumulado + (Nz(rs!ValorDebito, 0) - Nz(rs!ValorCredito, 0))
       rs.Edit
           rs!SaldoLinha = Acumulado
       rs.Update
       rs.MoveNext
   Loop
   rs.Close
   Set rs = Nothing
   '--------------------------------------------------------------
   'Carrega a listbox com todos os registros da tabela temporaria
   '--------------------------------------------------------------
   Call fncCarregaLista("idcaixa = " & Me.IdCaixa & "")
End If
1:
End Function

Private Sub fncCarregaLista(Optional filtro As String, Optional Ordem As String)
Dim strSQL As String
strSQL = "Select idMovimento,jAlinhaQry(DataMovimento,12,'dd/mm/yyyy',2) AS Data,space(0) & Historico AS Movimento, Rubrica, Entidade, iif(valorDebito=0,'',jAlinhaQry(valorDebito,14,'Currency',3)) As Débito, "
strSQL = strSQL & "iif(valorcredito=0,'',jAlinhaQry(valorCredito,14,'Currency',3)) AS Crédito, "
strSQL = strSQL & "jAlinhaQry(SaldoLinha,14,'Currency',3) as Saldo FROM " & tblTemp & " WHERE " & filtro & " ORDER BY dataMovimento,idmovimento;"
Me!Lista.RowSource = strSQL

End Sub

Private Sub fncAcumularSaldo()
Dim DataLimite As Date
Dim strFiltro As String
Dim SaldoAcumulado As Double
Dim DataMaxSaldoAcumulado As Date
'-----------------------------------------------------------------------------------------------------------------------------------------
'Data limite para acumular o saldo. Estou aqui estipulando que acumule o saldo a partir do centésimo dia, em relação ao último lançamento
'-----------------------------------------------------------------------------------------------------------------------------------------

If Nz(DCount("*", "[tblMovimento]")) = 0 Then
Exit Sub
End If

DataLimite = DMax("DataMovimento", "tmp_tblMovimento") - 100

strFiltro = "idCaixa = " & Me.IdCaixa & " And cdbl([dataMovimento]) <= " & CDbl(DataLimite)
SaldoAcumulado = Nz(DSum("[valordebito]-[valorcredito]", "tblMovimento", strFiltro), 0)


'-----------------------------------------------------------------------------------------
'Se não tiver saldo acumulado, para ser armazenado na tabela auxiliar tblConfig, encerra.
'-----------------------------------------------------------------------------------------
If SaldoAcumulado = 0 Then Exit Sub

DataMaxSaldoAcumulado = DMax("dataMovimento", "tblMovimento", strFiltro)
'-------------------------------------------------------------------------------------------------------------------------------------
'Toda transação que envolver mais de uma tabela sendo atualizada, devemos colocar dentro da estrutura Bigin <==> Commit
'Se não utilizar esta estrutura e uma das duas atualizações falhar, as contas ficarão desequilibradas.
'A realização dessas alterações, dentro da estrutura begin <==> Commit, garante que todas as alterações, ou nenhuma delas, ocorram.
'--------------------------------------------------------------------------------------------------------------------------------------
On Error GoTo trataerro
BeginTrans
   CurrentDb.Execute "UPDATE tblConfig SET DataSaldo ='" & DataMaxSaldoAcumulado & "', Saldocaixa = Saldocaixa + val('" & SaldoAcumulado & "');"
   CommitTrans

sair:
   Exit Sub
trataerro:
   Rollback
   Resume sair
End Sub

Private Sub btImprimir_Click()
If Nz(DCount("*", "[tblMovimento]")) = 0 Then
MsgBox "Não Existe Movimento Para Imprimir.", vbInformation, "Gestão Bancária"
Else

If MsgBox("Confirma a Impressão dos Movimentos Selecionados ? ", vbYesNo, "Gestão Bancária") = vbYes Then
DoCmd.OpenReport "Extrato", acNormal
If MsgBox("Criar Documento em P. D. F. ? ", vbYesNo, "P. D. F.") = vbYes Then
Dim Caminho As String
Caminho = CurrentProject.path & "\PDF\"
Dim strArquivo As String
Dim strLocal As String
strArquivo = "Extrato " & Forms.menu.Conta & "" & Forms.menu.Conta & "" & " - " & Format$(Date, "dd-mm-yyyy")
strLocal = Caminho & strArquivo & ".pdf"
If Len(Dir(strLocal)) > 0 Then
MsgBox "Este Documento Já Existe em PDF ", vbInformation, "Aviso"
Exit Sub
Else
DoCmd.OutputTo acOutputReport, "Extrato", acFormatPDF, strLocal
MsgBox "PDF Criado Com Sucesso ", vbInformation, "Aviso"
End If

If Err = 2501 Then
Err.Clear
DoCmd.Close
Me.Foco.SetFocus
End If
Else
Me.Foco.SetFocus
End If
End If
End If

End Sub

Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
If DCount("*", "Banco") = 0 Then
MsgBox "Tem de Criar pelo Menos 1(UM) Banco antes de entrar neste Menú", vbQuestion, "Gestão Bancária"
DoCmd.Close acForm, "frmMovimentoCaixa"
Exit Sub
Else

'Me.Lista.Requery


'------
If Forms.menu.DataMenu <> Date Then

MsgBox "Atenção A Data Do Sistema ! " & vbCrLf & "Não Está na Data Atual ", vbCritical, "Gestão Bancária"
If MsgBox("Deseja Continuar no Ano Anterior ? ", vbYesNo, "Aviso") = vbYes Then
Else
Forms.menu.DataMenu = Date
Forms.menu.Requery
DoCmd.Close acForm, "frmMovimentoCaixa"
End If
End If

'-------

shell CurrentProject.path & "\Teclado.exe", vbHide


If Year(Forms.menu.DataMenu) < Year(Date) Then

MsgBox "Atenção Está no Ano Anterior ! " & vbCrLf & "Para Registar Anos Anteriores" & vbCrLf & "Tenha em Atenção às Datas Inseridas ", vbCritical, "Gestão Bancária"
If MsgBox("Deseja Continuar no Ano Anterior ? ", vbYesNo, "Aviso") = vbYes Then
Else
Forms.menu.DataMenu = Date
Forms.menu.Requery
DoCmd.Close acForm, "frmMovimentoCaixa"

End If
End If
End If
End Sub

Private Sub Form_Timer()

Me.Caption = "Registar Novos Movimentos - " & Format$(Now(), "DDDD, d MMMM, yyyy  h:nn:ss")
Ajuda1.Visible = Not Ajuda1.Visible
'Me.Quadro.Requery
End Sub

Private Sub Lista_AfterUpdate()
If Nz(DLookup("idmovimento", "tblMovimento", "idmovimento = " & CLng(Me.Lista.Column(0)) & " and " & "Reconciliado=" & True)) + 1 > 1 Then
MsgBox "O Movimento Selecionado Não pode ser Alterado nem Anulado ! " & vbCrLf & "Pois já Foi Reconciliado !", vbInformation, "Gestão Bancária"
'Call Form_Load
 
Exit Sub
Else

Call fncLimpaCampos(True)
Me.Comando65.Enabled = False
Me.Comando96.Visible = True
Me.Comando97.Visible = True
Me.Comando68.Enabled = True

Me!txIdMovimento = DLookup("[idmovimento]", "[tblmovimento]", "[IDmovimento] = " & Me!Lista.Column(0) & "")
Me!txtHistorico = DLookup("[historico]", "[tblmovimento]", "[IDmovimento] = " & Me!Lista.Column(0) & "")
Me!txtData = DLookup("[datamovimento]", "[tblmovimento]", "[IDmovimento] = " & Me!Lista.Column(0) & "")
Me!Rubrica = DLookup("[Rubrica]", "[tblmovimento]", "[IDmovimento] = " & Me!Lista.Column(0) & "")
Me!Entidade = DLookup("[entidade]", "[tblmovimento]", "[IDmovimento] = " & Me!Lista.Column(0) & "")
Me!TxtDoc = DLookup("[doc]", "[tblmovimento]", "[IDmovimento] = " & Me!Lista.Column(0) & "")
Me!ValorMovimento = DLookup("[valormovimento]", "[tblmovimento]", "[IDmovimento] = " & Me!Lista.Column(0) & "")

If Not IsNull(Me.TipoMov) Then
Me.TipoMov = Me.txtHistorico.Column(1)
End If

If Me!Lista.Column(2) = "Saldo Inicial" Then
Me.TipoMov = "D"
End If
End If
Me.Lista.Requery
End Sub

Public Function fncFiltrar(NomeCampoFoco As String)
Dim X As String, strSplit As String
Dim F(4) As String, cp(4) As Variant

Dim K As Variant, P As Byte
Dim booPos As Boolean
'------------------------------------------------------------------
' Variável x recebe o valor digitado na caixa de texto de filtragem
'-------------------------------------------------------------------
X = Me(NomeCampoFoco).Text: P = 0
'--------------------------------------------------------------------------------------
'Passa para a matrix Cp() todos os valores digitados nas caixas de texto de filtragens
'--------------------------------------------------------------------------------------
For P = 0 To 3
   cp(P) = IIf(InStr(NomeCampoFoco, "tx" & P + 1) > 0, X, Me("tx" & P + 1))
Next
'----------------------------------------------------------------------------------------------------------------------------
' Passa para a matrix f() os campos a serem filtrados, com os respectivos valores digitados nas caixas de texto de filtragens
'-----------------------------------------------------------------------------------------------------------------------------
F(0) = IIf(cp(0) = Chr(32), "historico=''", "Historico Like '*" & cp(0) & "*'")
F(1) = "Datamovimento Like '*" & cp(1) & "*'"
F(2) = "Rubrica Like '*" & cp(2) & "*'"
F(3) = "Entidade Like '*" & cp(3) & "*'"
'------------------------------------------------------------------------------------------
'Passa para variável strSplit o comprimento de texto da cada caixa de texto de filtragens
'Comprimento zero(0) significa que a caixa de texto de filtragem se encontra vazia
'Exemplo: strSplit = 2|0|1|0
'Significa que os campos 2 e 4 não receberam valores para serem filtrados
'------------------------------------------------------------------------------------------
strSplit = Len(cp(0) & "") & "|" & Len(cp(1) & "") & "|" & Len(cp(2) & "") & "|" & Len(cp(3) & "")

K = Split(strSplit, "|")
'----------------------------------------------------------------------------------------------
'Filtro assume todos os valores de registros caso todos os campos de filtragens estejam limpos
'----------------------------------------------------------------------------------------------
'filtro = "idcaixa > 0": p = 0
filtro = "idcaixa = " & Me.IdCaixa & "": P = 0
'------------------------------------------------------------------------------------------
'Monta a variável filtro com todos os campos de filtragens que possuirem valores digitados
'------------------------------------------------------------------------------------------
For P = 0 To UBound(K)
   If Val(K(P)) > 0 Then
       If booPos = False Then
           filtro = F(P): booPos = True
       Else
           filtro = filtro & " AND " & F(P)
       End If
   End If
Next P
'--------------------------------------------
'Carrga a listbox com os registros filtrados
'--------------------------------------------
Call fncCarregaLista(filtro)
End Function

Private Sub fncPintaTexto(cor As Integer)
Me!txtHistorico.ForeColor = cor
Me!txtData.ForeColor = cor
Me!Rubrica.ForeColor = cor
Me!TxtDoc.ForeColor = cor
Me!Entidade.ForeColor = cor
Me!ValorMovimento.ForeColor = cor
Me!txIdMovimento.ForeColor = cor
End Sub

Public Function fncLimpaCampos(Optional booLimpa As Boolean)

If Not booLimpa Then Me!Lista.Value = -1
Me!txVelho = "" 'Null
Call fncPintaTexto(0)
End Function



Private Sub LISTA_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call MouseCursor(32649&)
End Sub

Private Sub Pendente_Click()
'on error resume next
DoCmd.OpenForm "valorespendentes"
End Sub

Private Sub Pendente_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call MouseCursor(32649&)
End Sub

Private Sub Quadro_AfterUpdate()
Call fncMontaSaldo
Call Form_Current
Me.txtData.SetFocus
End Sub

Private Sub RPendente_Click()

Me.Foco.SetFocus
DoCmd.OpenForm "valoresPendentes"

End Sub

Private Sub RPendente_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call MouseCursor(32649&)
End Sub

Private Sub Rubrica_AfterUpdate()
On Error Resume Next
Me.TipoRub = Me.Rubrica.Column(1)
End Sub

Private Sub Rubrica_Change()

If Nz(Me!txVelho) <> Nz(Me!Rubrica.Text) Then fncPintaTexto (255)
Dim I As Integer, intSomaCarateres As Integer

'By JPaulo ® Maximo Access

'Limita o campo a 20 carateres
   If Len(Me.Rubrica.Text) > 20 Then

'Informa o usuário, através de mensagem
MsgBox "Tamanho máximo do campo, excedido...", vbCritical
'Me.Rubrica = "" 'Null
End If
'Inicia o contador a zero
   intSomaCarateres = 0
For I = 1 To Me.Rubrica.SelStart
       intSomaCarateres = I
   Next I
'Coloca no campo do total de carateres, um a um
Me.txtTotalCarateres.Value = intSomaCarateres
'Se o usuário apagar os carateres um a um e chegar a zero, limpa a caixa
   If Me.txtTotalCarateres.Value = 0 Then
       Me.txtTotalCarateres.Value = ""
End If
End Sub



Private Sub Rubrica_Enter()
If IsNull(Me.txtHistorico) Then
MsgBox "Falta Preencher o Movimento", vbInformation, "Campo Obrigatório"
Me.txtHistorico.SetFocus
Else
End If
End Sub

Private Sub Rubrica_GotFocus()

Call fcor(Me!Rubrica, "am")
Me.txVelho = Me.Rubrica.Value
With Me
   .ActiveControl.Requery
   .ActiveControl.Dropdown


End With
End Sub

Private Sub Rubrica_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Me.txtHistorico.SetFocus
End Sub

Private Sub Rubrica_LostFocus()
Me.Rubrica.BackColor = vbWhite
End Sub

Private Sub Rubrica_NotInList(NewData As String, Response As Integer)
Response = acDataErrContinue 'inibe msg padrão do Access.

'If NewData = "Sld" Or NewData = "s l d" Then
If NewData = "Sld" Or NewData = "s l d" Or NewData = "Transferência" Then

MsgBox "Rubrica " & FirstCaps([NewData]) & "  Não Permitida....", vbCritical, "Gestão Bancária"
Response = acDataErrContinue
Rubrica = "" 'Null
Exit Sub
Else

If MsgBox("Tipo de Rubrica " & FirstCaps([NewData]) & " Não Registada !" & vbCrLf _
       & "Deseja Actualizar ?", 32 + vbYesNo, "Nova Rubrica ?") = 6 Then
       DoCmd.OpenForm "Inserir Novas Rubricas", , , , acFormAdd, _
       acDialog, NewData
       Rubrica = FirstCaps([NewData])  'Transforma primeira para maiúsculas.
       Response = acDataErrAdded
   Else
       Response = acDataErrContinue
       Me.Rubrica = "" 'Null
End If
End If
End Sub



Private Sub txtData_Change()

If Nz(Me!txVelho) <> Nz(Me!txtData.Text) Then fncPintaTexto (255)

End Sub




Private Sub txtData_GotFocus()
'shell CurrentProject.path & "\Teclado.exe", vbHide

Call fcor(Me!txtData, "am")
Me.txtData = Date
Me.txtData.SelStart = 0
Me.txVelho = Me.txtData
Me.Comando68.Enabled = False
Me.Comando65.Enabled = False

Call fncMontaSaldo
Me.Lista.Requery

End Sub

Private Sub txtData_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Me.bt_sair.SetFocus


End Sub

Private Sub txtData_LostFocus()
Me.txtData.BackColor = vbWhite
End Sub

Private Sub TxtDoc_Change()
If Nz(Me!txVelho) <> Nz(Me!TxtDoc.Text) Then fncPintaTexto (255)
End Sub

Private Sub txtHistorico_AfterUpdate()
On Error Resume Next
Me.TipoMov = Me.txtHistorico.Column(1)
Me.Comando68.Enabled = True
End Sub

Private Sub txtHistorico_Change()

If Nz(Me!txVelho) <> Nz(Me!txtHistorico.Text) Then fncPintaTexto (255)

'By JPaulo ® Maximo Access
Dim I As Integer, intSomaCarateres As Integer

'Limita o campo a 20 carateres
   If Len(Me.txtHistorico.Text) > 20 Then
'Se chegar aos 20 carateres, mantem apenas os 20 digitados à esquerda
       Me.txtHistorico.Text = Left(Me.txtHistorico.Text, 20)
   Me.txtHistorico.SelStart = 20
'Informa o usuário, através de mensagem
MsgBox "Tamanho Máximo do Campo, Excedido...", vbCritical
'Me.txtHistorico = "" 'Null
End If
'Inicia o contador a zero
   intSomaCarateres = 0
For I = 1 To Me.txtHistorico.SelStart
       intSomaCarateres = I
   Next I
'Coloca no campo do total de carateres, um a um
Me.txtTotalCarateres.Value = intSomaCarateres
'Se o usuário apagar os carateres um a um e chegar a zero, limpa a caixa
   If Me.txtTotalCarateres.Value = 0 Then
       Me.txtTotalCarateres.Value = ""
End If

On Error Resume Next
Me.Rubrica.Requery
Me.Rubrica = "" 'Null
Me.TipoRub = "" 'Null
Me.Entidade = "" 'Null

End Sub

Private Sub txtHistorico_Enter()
On Error Resume Next
Dim strMsg
   Dim strFeriado As String
   
   'se ""'Null sai
   If IsNull(txtData) Then Exit Sub
   
   'atribuir descrição do feriado à variavel
   strFeriado = Nz(DLookup("Descrição", "FeriadosFixos", "[DataFeriado] = #" & Format(Me.txtData, "mm/dd/yyyy") & "#"), "")
   
   If Weekday(txtData) = 1 Or Weekday(txtData) = 7 Or Len(strFeriado) > 0 Then
       
       'mensagem fim de semana
       If Weekday(txtData) = 1 Or Weekday(txtData) = 7 Then strMsg = "O Dia Digitado " & txtData & " Não é Dia Útil. " & vbCr & vbCr & "É um - " & Format(txtData, "dddd")
       
       'mensagem de feriado
       If Len(strFeriado) > 0 Then strMsg = "O Dia Digitado " & txtData & "" & vbCr & vbCr & " É Feriado -  " & strFeriado & "."
       
           
           'codigo como estava
           If MsgBox(strMsg & vbCr & vbCr & "Quer Alterar para o Primeiro Dia Útil Seguinte ?", vbYesNo, "Aviso") = vbYes Then
               Do
IncrementaData:
                   txtData = DateAdd("d", 1, txtData)
                   If Weekday(txtData) = 1 Or Weekday(txtData) = 7 Or (Not IsNull(DLookup("[Dataferiado]", "feriadosFixos", "[Dataferiado] =#" & Format(Me.txtData, "mm/dd/yyyy") & "#"))) Then
                       GoTo IncrementaData
                   Else
                       Exit Do
                   End If
               Loop
           End If
       End If

End Sub

Private Sub txtHistorico_GotFocus()

Call fcor(Me!txtHistorico, "am")
Me.txVelho = Me.txtHistorico.Value

With Me
   .ActiveControl.Requery
   .ActiveControl.Dropdown


   
End With
End Sub

Private Sub txtHistorico_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Me.txtData.SetFocus

End Sub

Private Sub txtHistorico_LostFocus()
Me.txtHistorico.BackColor = vbWhite
End Sub

Private Sub txtHistorico_NotInList(NewData As String, Response As Integer)

Response = acDataErrContinue 'inibe msg padrão do Access.

If NewData = "Saldo Inicial" Or NewData = "Saldo Inícial" Then
MsgBox "Movimento " & FirstCaps([NewData]) & "  Não Permitido....", vbCritical, "Gestão Bancária"
Response = acDataErrContinue
txtHistorico = "" 'Null
Exit Sub
Else

If MsgBox("Tipo de Movimento " & FirstCaps([NewData]) & " Não Registado !" & vbCrLf _
       & "Deseja Actualizar ?", 32 + vbYesNo, "Novo Movimento ?") = 6 Then
       DoCmd.OpenForm "Inserir Novos Movimentos", , , , acFormAdd, _
          acDialog, NewData
       txtHistorico = FirstCaps([NewData])  'Transforma primeira para maiúsculas.
       Response = acDataErrAdded
   Else
       Response = acDataErrContinue
         Me.txtHistorico = "" 'Null
End If
End If

End Sub

Private Sub ValorMovimento_Change()
If Nz(Me!txVelho) <> Nz(Me!ValorMovimento.Text) Then fncPintaTexto (255)

'By JPaulo ® Maximo Access
Dim I As Integer, intSomaCarateres As Integer
'Limita o campo a 13 carateres
   If Len(Me.ValorMovimento.Text) > 13 Then
'Se chegar aos 13 carateres, mantem apenas os 13 digitados à esquerda
       Me.ValorMovimento.Text = Left(Me.ValorMovimento.Text, 13)
   Me.ValorMovimento.SelStart = 13
'Informa o usuário, através de mensagem
MsgBox "Tamanho Máximo do Campo, Excedido...", vbCritical
'Me.ValorMovimento = "" 'Null
End If
'Inicia o contador a zero
   intSomaCarateres = 0
For I = 1 To Me.ValorMovimento.SelStart
       intSomaCarateres = I
   Next I
'Coloca no campo do total de carateres, um a um
Me.txtTotalCarateres.Value = intSomaCarateres
'Se o usuário apagar os carateres um a um e chegar a zero, limpa a caixa
   If Me.txtTotalCarateres.Value = 0 Then
       Me.txtTotalCarateres.Value = ""
End If

Dim dblValor As Double
On Error Resume Next
dblValor = Replace(Replace(Me!ValorMovimento.Text, ".", ""), ",", "")
Me!ValorMovimento = Format(dblValor / 100, "#,##0.00 €")
Me!ValorMovimento.SelStart = Len(Me!ValorMovimento) - 2

If IsNull(Me.txtHistorico) And IsNull(Me.Rubrica) And IsNull(Me.Entidade) And IsNull(Me.TxtDoc) Then

Me.Comando65.Enabled = False
Me.ValorMovimento = "0.00 €"
Me.txtData.SetFocus
ElseIf Me.Lista.ItemsSelected.Count >= 1 Then
Me.Comando65.Enabled = False
Me.Comando68.Enabled = False

Else

End If

End Sub

Private Sub ValorMovimento_Exit(Cancel As Integer)


Me.ValorMovimento.BackColor = vbWhite

End Sub

Private Sub ValorMovimento_GotFocus()
Call fcor(Me!ValorMovimento, "am")
End Sub

Private Sub ValorMovimento_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Me.Entidade.SetFocus
Me.Comando65.Enabled = True

End Sub

Private Sub ValorMovimento_KeyPress(KeyAscii As Integer)
KeyAscii = SemLetras(KeyAscii)

End Sub

Olá Assis, extenso o código.
Indentação ainda é uma miragem
Estou no table, mas não encontrei a sub no evento conforme o JPaulo indicou.
No código tem incluída a sugestão do JPaulo?
Abraço

Olá Teixeira

Mensagem 12 Editada com a dica do JPaulo , no Load do form

Olá Assis,
Onde colocou o código ainda não tinah "montado o saldo", possivelmente a "lista" ainda não tem dados, será isso?
Teste assim:

Código:

Private Sub Form_Load()

ReSizeForm Me
Call Center(Me)

'If Me!txtc.Value < 15 Then
'Me!Quadro.Value = 4
'Else
'Me!Quadro.Value = 3
'End If

Me.Texto94 = Me.Conta
Me.Texto362 = Forms.menu.Ano
Call fncMontaSaldo
Call fncMontaEventos(Me)
Call Form_Current

Dim ListControl As Control

Set ListControl = Me.Lista

DoEvents

With ListControl
Select Case .ListCount
 Case Is <= 15
   Me.Quadro.Value = 4
 Case Is > 15
   Me.Quadro.Value = 3
End Select
End With



Dim X As Long
Dim rst, rst1 As Recordset

Set rst = CurrentDb.OpenRecordset("select * from tblmovimentoData")
Set rst1 = CurrentDb.OpenRecordset("select * from tblmovimento")

X = 0

If rst.RecordCount = 0 Then Exit Sub

rst.MoveLast
rst.MoveFirst

Do While Not rst.EOF
    
    If rst.Fields("datamovimento").Value <= Date Then
        X = X + 1
        rst1.AddNew
        rst1.Fields("ordenar").Value = rst.Fields("ordenar").Value
        rst1.Fields("DataMovimento").Value = rst.Fields("DataMovimento").Value
        rst1.Fields("idcaixa").Value = rst.Fields("idcaixa").Value
        rst1.Fields("Historico").Value = rst.Fields("Historico").Value
        rst1.Fields("Rubrica").Value = rst.Fields("Rubrica").Value
        rst1.Fields("entidade").Value = rst.Fields("entidade").Value
        rst1.Fields("Doc").Value = rst.Fields("doc").Value
        rst1.Fields("valordebito").Value = rst.Fields("valordebito").Value
        rst1.Fields("valorcredito").Value = rst.Fields("valorcredito").Value
        rst1.Fields("Reconciliado").Value = rst.Fields("Reconciliado").Value
        rst1.Fields("Valormovimento").Value = rst.Fields("Valormovimento").Value
        'adiciona na tabela tblmovimento
        rst1.Update
        'apaga na tabela tblmovimentoData
        rst.Delete
    Else
        'se não encontra não faz nada
    End If
    
    rst.MoveNext
Loop

If X > 0 Then
    MsgBox X & " Movimento(s) Pendente(s) Registado(s)", vbQuestion, "Gestão Bancária"
Else
End If

Set rst = Nothing

End Sub

Abraço

Boa tarde Teixeira

Colocando a dica do JPaulo no local que o amigo indicou acontece que a caixa de listagem "Lista" abre sem registros.

Obrigado

Boa tarde Amigos

Up ...

Olá Assis,

Quando tiver com um PC irei fazer a leitura do código.
Não é fácil, mas a ver se encontramos onde está a falhar.
Abraço

Bom dia Assis,

Eu percebo pouco disto, mas o que tu procuras não será qualquer coisa deste tipo:

SQL = "SELECT * FROM tbls WHERE data < 30 dias"

set SQLres = dbs.OpenRecordset (SQL)

If SQLres.RecordCount < 16 Then
Me.Lista.RowSource = SQL
Me.Lista.Requery
Me.Quadro.Value = 4

else
SQL = "SELECT * FROM tbls WHERE data < 15 dias"
Me.Lista.RowSource = SQL
Me.Lista.Requery
Me.Quadro.Value = 3
end if

Pela tua imagem parece isto, porque ao alterar o valor do quadro alteras também o sql da lista.

Abraço

Não Nuno Obrigado

A caixa de listagem " Lista "carrega assim:

Private Sub fncCarregaLista(Optional Filtro As String, Optional Ordem As String)
Dim strSql As String
strSql = "Select idMovimento,jAlinhaQry(DataMovimento,12,'dd/mm/yyyy',2) AS Data,space(0) & Historico AS Movimento, Rubrica, Entidade, iif(valorDebito=0,'',jAlinhaQry(valorDebito,14,'Currency',3)) As Débito, "
strSql = strSql & "iif(valorcredito=0,'',jAlinhaQry(valorCredito,14,'Currency',3)) AS Crédito, "
strSql = strSql & "jAlinhaQry(SaldoLinha,14,'Currency',3) as Saldo FROM " & tblTemp & " WHERE " & Filtro & " ORDER BY dataMovimento,idmovimento;"
Me!Lista.RowSource = strSql

End Sub

Olá Assis,

Teste assim e diga o que acontece:

Código:

Private Sub Form_Load()
ReSizeForm Me
Call Center(Me)

MsgBox Me.Lista.ListCount, vbInformation, "Total da lista"
'If Me!txtc.Value < 15 Then
'Me!Quadro.Value = 4
'Else
'Me!Quadro.Value = 3
'End If
Dim ListControl As Control

Set ListControl = Me.Lista

With ListControl
Select Case .ListCount
 Case Is <= 15
  Me.Quadro.Value = 4
 Case Is > 15
  Me.Quadro.Value = 3
End Select
End With
Me.Texto94 = Me.Conta
Me.Texto362 = Forms.menu.Ano
Call fncMontaSaldo
Call fncMontaEventos(Me)
Call Form_Current




Dim X As Long
Dim rst, rst1 As Recordset

Set rst = CurrentDb.OpenRecordset("select * from tblmovimentoData")
Set rst1 = CurrentDb.OpenRecordset("select * from tblmovimento")

X = 0

If rst.RecordCount = 0 Then Exit Sub

rst.MoveLast
rst.MoveFirst

Do While Not rst.EOF

If rst.Fields("datamovimento").Value <= Date Then
X = X + 1
rst1.AddNew
rst1.Fields("ordenar").Value = rst.Fields("ordenar").Value
rst1.Fields("DataMovimento").Value = rst.Fields("DataMovimento").Value
rst1.Fields("idcaixa").Value = rst.Fields("idcaixa").Value
rst1.Fields("Historico").Value = rst.Fields("Historico").Value
rst1.Fields("Rubrica").Value = rst.Fields("Rubrica").Value
rst1.Fields("entidade").Value = rst.Fields("entidade").Value
rst1.Fields("Doc").Value = rst.Fields("doc").Value
rst1.Fields("valordebito").Value = rst.Fields("valordebito").Value
rst1.Fields("valorcredito").Value = rst.Fields("valorcredito").Value
rst1.Fields("Reconciliado").Value = rst.Fields("Reconciliado").Value
rst1.Fields("Valormovimento").Value = rst.Fields("Valormovimento").Value
'adiciona na tabela tblmovimento
rst1.Update
'apaga na tabela tblmovimentoData
rst.Delete
Else
'se não encontra não faz nada
End If
rst.MoveNext
Loop
If X > 0 Then
MsgBox X & " Movimento(s) Pendente(s) Registado(s)", vbQuestion, "Gestão Bancária"
Else
End If

Set rst = Nothing


End Sub


Abraço

Teixeira

Private Sub Form_Current()

Me.txtc = "Total de Movimento no Periodo - " & Me.Lista.ListCount

End Sub

O resultado está certo.

'---------------------------------------------------------------------------------------

Mas o mesmo código se estiver em outro acontecimento como no Load por exemplo:


Private Sub Form_Load()

Me.txtc = "Total de Movimento no Periodo - " & Me.Lista.ListCount

End Sub

O resultado dá 1 ( um )

Portanto a MsgBox agora colocada dá sempre 1 (um) o valor do quadro não altera

Obrigado

Porquê ?

Assis e os demais;

Este tópico já vai longo com uma coisa bem simples de resolver.
Assis, se o amigo não quiser anexar aqui parte do seu banco e quiser enviar para o meu email, esteja á vontade que depois posto aqui a solução.

Desta forma, sem depurar os códigos é extremamente dificil.

Ola;

No form "frmMovimentoCaixa", criei uma função publica;

Código:

Public Function fncAlteraQuadro()
'JPaulo maximoaccess 20-09-2017
Dim intCont%
intCont = Nz(DCount("*", "[tmp_tblMovimento]"), "[idcaixa] = Me.IdCaixa And [Datamovimento] Between Me.DtInicio and Me.DtFim")

    Select Case intCont
       ' Case Is < 5
       '     Me.Quadro.Value = 1 '=3
       ' Case 6 To 7
       '     Me.Quadro.Value = 2 '=7
        Case Is >= 15
            Me.Quadro.Value = 3 '=15
        Case Else
            Me.Quadro.Value = 4 '=30
    End Select
Me.Quadro.Requery
End Function

Agora é só chamar depois do Me.Lista.Requery, entre outros trechos de código.

Banco reenviado para email, devido a conter informação confidencial.

Bom dia JPaulo

Funfa perfeito

Obrigado

Fico feliz.

Obrigado pelo retorno o forum agradece.