VAB Access... isto esta a dar-me um erro... alguém saber dizer porque?

[Thorn Gilts]

  Dim dbCorrespondence As DAO.Database
   Dim rstTracking As DAO.Recordset

   Set dbCorrespondence = CurrentDb
   Set rstTracking = dbCorrespondence.OpenRecordset("Correspondence Tracking")

   rstTracking.Move ID

   rstTracking.Edit
   rstTracking("Ano").Value = "2013"
   rstTracking.Update

[Thorn Gilts]

Esta funciona

 Dim db As Database
  Dim rs As DAO.Recordset

  Set db = CurrentDb
  Set rs = db.OpenRecordset("Correspondence Tracking")

  rs.AddNew
  rs("Ano").Value = "2016"
  rs.Update

End Sub

[Thorn Gilts]

  Dim db As Database
  Dim rs As DAO.Recordset

  Set db = CurrentDb
  Set rs = db.OpenRecordset("Correspondence Tracking")
 
 

  rs.AddNew
  rs("Nome").Value = Nome
  rs("Email").Value = Email
  rs("Field1").Add = Field1
  rs("Ano").Value = Year(Now)
  rs.Update



.... O Field1 é um attachment inserido via Acess no proprio form... como gravo na base de dados? Parece que o Add ou o Value nao funciona.

[Robusto]

Nesta última que colocaste, acho que o código para adicionar attachments foge um pouco da lógica dos anteriores... viste este link?

http://stackoverflow.com/questions/18237180/add-view-attachments-using-ms-access-vba


Naquele código no outro post, talvez o problema esteja nas References que seleccionaste para o projecto. Já validaste isso?

[Thorn Gilts]

Nesta última que colocaste, acho que o código para adicionar attachments foge um pouco da lógica dos anteriores... viste este link?

http://stackoverflow.com/questions/18237180/add-view-attachments-using-ms-access-vba


Naquele código no outro post, talvez o problema esteja nas References que seleccionaste para o projecto. Já validaste isso?

As references estão bem... todas... o Add foi uma forma de tentar outra forma.

[Thorn Gilts]

Ask the user for the file
    Dim filepath As String
    filepath = SelectFile()

    ' Check that the user selected something
    If Len(filepath) = 0 Then
        Debug.Assert "No file selected!"
        Exit Sub
    End If

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("tblAttach")

    ' Add a new row and an attachment
    rst.AddNew
    AddAttachment rst, "Files", filepath
    rst.Update

Penso que ai vai-me ajudar...

Queria acabar isto para implementar... numa empresa da minha irmã e em outras...

A ideia é:

1. Imprimir o cabeçalho de cartas já numeradas de acordo com o login da pessoa, o ano e sequência.
2. Arquivar os dados referentes às cartas (nr, assunto, destinatário, obs, a carta digitalizada em attach, etc).
3. Permitir a pesquisa por nr, ano, assunto, tipo, etc..
4. Permitir relacionar cartas (tanto com outras enviadas como com as recebidas)
5. Graficos dinamicos, estatisticas, etc.

Eu fiz uma coisa para o BCP em que utilizava todos estes conceitos de programação mas para algo muito complexo na area de investimento, na altura demorou muitas semanas e nunca tinha trabalho no Access... mas agora estou muito esquecido e preciso disto para segunda-feira... Vamos lá ver...

[Thorn Gilts]

  Call DOCNR

  Set db = CurrentDb
  Set rs = db.OpenRecordset("Correspondence Tracking")
 
   
  rs.AddNew
  rs("Nome").Value = Nome
  rs("Email").Value = Email
  rs("Organizacao").Value = Organizacao
  rs("Morada").Value = Morada
  rs("Codigo_Postal").Value = Codigo_Postal
  rs("Nr_Paginas").Value = Nr_Paginas
  rs("Data_Envio").Value = Data_Envio
  rs("Data_Recebido").Value = Data_Recebido
  rs("OBS").Value = OBS
  rs("NRef").Value = NRef
  rs("VRef").Value = VRef
  rs("Timestamp").Value = Now
  rs("Utilizador") = Utilizador
  rs("Ano").Value = Year(Now)
  rs("Nr_Doc") = NRDOC
  ' o attach é o Field1
  rs.Update
   

MsgBox "Registo da correspondência gravada com sucesso pelo utilizador " & Utilizador & " em " & Now & " com a N/Ref. " & NRef & "."

Este é o meu codigo...

O attach já esta no campo Field1  só não o consigo gravar.

So consigo gravar com uma macro daquelas já embebidas no access...


 

[Thorn Gilts]

Option Compare Database

Private Sub Código_Postal_GotFocus()
If Forms![CORRESPONDÊNCIA ENVIADA].Codigo_Postal = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA ENVIADA].Codigo_Postal = Empty
Me.Código_Postal.ForeColor = vbBlack
Me.Código_Postal.FontItalic = False
Me.Código_Postal.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub Localidade_GotFocus()
If Forms![CORRESPONDÊNCIA ENVIADA].Localidade = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA ENVIADA].Localidade = Empty
Me.Localidade.ForeColor = vbBlack
Me.Localidade.FontItalic = False
Me.Localidade.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub Morada_GotFocus()
If Forms![CORRESPONDÊNCIA ENVIADA].Morada = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA ENVIADA].Morada = ""
Me.Morada.ForeColor = vbBlack
Me.Morada.FontItalic = False
Me.Morada.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub Nome_destinatário_GotFocus()
If Forms![CORRESPONDÊNCIA ENVIADA].Nome = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA ENVIADA].Nome = ""
Me.Nome_destinatário.ForeColor = vbBlack
Me.Nome_destinatário.FontItalic = False
Me.Nome_destinatário.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub gravar_Click()

' Gerir erros de registo em caso de estarem apagados (#Deleted)
On Error GoTo ErrorDeletedHandlder
If Me.Nome.Value = Null Then
End If
GoTo Code

' Abre novo registo em caso de erro (ex. #Deleted)
ErrorDeletedHandlder:
DoCmd.GoToRecord , , acNewRec
Exit Sub

' começa aqui o processo se tudo estiver bem.
Code:

  Call DOCNR
  Me.Refresh

 ' verificar campos vazios
 If Len(Me.Nome & vbNullString) = 0 Then
 MsgBox "O campo do nome é de preenchimento obrigatório"
 Me.Label3.FontBold = True
 Me.Label3.ForeColor = vbRed
 Forms![CORRESPONDÊNCIA ENVIADA].Nome = "Preenchimento obrigatório"
 Me.Nome_destinatário.ForeColor = RGB(127, 127, 127)
 Me.Nome_destinatário.FontItalic = True
 Me.Nome_destinatário.FontSize = 8
 Me.Refresh
    Call queimar_tempo
 Me.Label3.FontBold = False
 Me.Label3.ForeColor = RGB(127, 127, 127)
 Me.Refresh
 Exit Sub
 End If
 
 If Len(Me.Email & vbNullString) = 0 Then

    If Len(Me.Morada & vbNullString) = 0 Then
    MsgBox "O campo da Morada (ou então o de email) é de preenchimento obrigatório"
    Me.Label12.FontBold = True
    Me.Label12.ForeColor = vbRed
    Forms![CORRESPONDÊNCIA ENVIADA].Morada = "Preenchimento obrigatório"
    Me.Morada.ForeColor = RGB(127, 127, 127)
    Me.Morada.FontItalic = True
    Me.Morada.FontSize = 8
    Me.Refresh
        Call queimar_tempo
    Me.Label12.FontBold = False
    Me.Label12.ForeColor = RGB(127, 127, 127)
    Me.Refresh
    Exit Sub
    End If
 
    If Len(Me.Codigo_Postal & vbNullString) = 0 Then
    MsgBox "O campo do Código Postal é de preenchimento obrigatório"
    Me.Label15.FontBold = True
    Me.Label15.ForeColor = vbRed
    Forms![CORRESPONDÊNCIA ENVIADA].Codigo_Postal = "Preenchimento obrigatório"
    Me.Código_Postal.ForeColor = RGB(127, 127, 127)
    Me.Código_Postal.FontItalic = True
    Me.Código_Postal.FontSize = 8
    Me.Refresh
      Call queimar_tempo
    Me.Label15.FontBold = False
    Me.Label15.ForeColor = RGB(127, 127, 127)
    Me.Refresh
    Exit Sub
    End If
   
    If Len(Me.Localidade & vbNullString) = 0 Then
    MsgBox "O campo da Localidade a é de preenchimento obrigatório"
    Me.Label18.FontBold = True
    Me.Label18.ForeColor = vbRed
    Forms![CORRESPONDÊNCIA ENVIADA].Localidade = "Preenchimento obrigatório"
    Me.Localidade.ForeColor = RGB(127, 127, 127)
    Me.Localidade.FontItalic = True
    Me.Localidade.FontSize = 8
    Me.Refresh
      Call queimar_tempo
    Me.Label18.FontBold = False
    Me.Label18.ForeColor = RGB(127, 127, 127)
    Me.Refresh
    Exit Sub
    End If
End If
 
' confirmar dados
If Len(Me.Email & vbNullString) = 0 And Len(Me.Morada & vbNullString) = 0 Then
    If Len(Me.Email & vbNullString) = 0 Then
    resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Morada: " & Morada & ", " & Codigo_Postal & ", " & Localidade & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
        If resposta = vbCancel Then
        Exit Sub
        End If
    Else
    resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Email: " & Email & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
        If resposta = vbCancel Then
        Exit Sub
        End If
    End If
Else
    If Len(Me.Email & vbNullString) > 0 And Len(Me.Morada & vbNullString) > 0 Then
    resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Email: " & Email & vbNewLine & "Morada: " & Morada & ", " & Codigo_Postal & ", " & Localidade & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
    Else
        If Len(Me.Email & vbNullString) = 0 Then
        resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Morada: " & Morada & ", " & Codigo_Postal & ", " & Localidade & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
           If resposta = vbCancel Then
           Exit Sub
           End If
        Else
        resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Email: " & Email & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
           If resposta = vbCancel Then
          Exit Sub
           End If
        End If
    End If
End If
 
REFERENCIA = NRef

 
    On Error Resume Next
    DoCmd.GoToRecord , "", acNewRec
    If (MacroError <> 0) Then
        Beep
        MsgBox MacroError.Description, vbOKOnly, ""
    End If
 
 

  Set db = CurrentDb
  Set rs = db.OpenRecordset("Correspondence Tracking")
 
  rs.MoveLast
  rs.Edit
  rs("Timestamp").Value = Now
  rs("Utilizador") = Environ$("Username")
  rs("Ano").Value = Year(Now)
  ' Nr de documento
    On Error Resume Next
    Dim NRDOC As Variant
    NRDOC = DMax("[Nr_Doc]", "Correspondence Tracking", "[Ano] = " & Year(Now)) + 1
    If NRDOC > 0 Then
    ' ok
    Else
    NRDOC = "00001"
    End If
  rs("Nr_Doc") = NRDOC
  rs.Update
  Me.Refresh
   
MsgBox "Registo da correspondência gravada com sucesso pelo utilizador " & Environ$("Username") & " em " & Now & " com a referência " & REFERENCIA & "."
End Sub

Sub queimar_tempo()
        ' queimar tempo
        Dim PauseTimeA, StartA
        PauseTimeA = 1
        StartA = Timer
        Do While Timer < StartA + PauseTimeA
        DoEvents
        Loop
End Sub

Private Sub Data_de_envio_AfterUpdate()
Call DOCNR
End Sub

Private Sub Data_de_recepção_AfterUpdate()
Call DOCNR
End Sub

Private Sub Email_AfterUpdate()
Call DOCNR
End Sub


Private Sub Localidade_AfterUpdate()
Call DOCNR
End Sub

Private Sub Morada_AfterUpdate()
Call DOCNR
End Sub

Private Sub N_Ref_GotFocus()
Call DOCNR
End Sub

Private Sub Código_Postal_AfterUpdate()
Call DOCNR
End Sub

Private Sub Nome_destinatário_AfterUpdate()
Call DOCNR
End Sub

Private Sub Número_de_Páginas_AfterUpdate()
Call DOCNR
End Sub

Private Sub Observações_AfterUpdate()
Call DOCNR
End Sub

Private Sub Organização_AfterUpdate()
Call DOCNR
End Sub

Private Sub Timestamp_AfterUpdate()
Call DOCNR
End Sub

Private Sub Utilizador_AfterUpdate()
Call DOCNR
End Sub

Private Sub V_Ref_AfterUpdate()
Call DOCNR
End Sub

Sub DOCNR()

' timestamp
Timestamp.Value = Now

' clear
USERDOC = Empty

' user windows name
User = (Environ$("Username"))

' select user name document
Select Case User
    Case "HOME"
        USERDOC = "OV"
    Case "xxx"
        USERDOC = "OV"
End Select

' if doesn't exist in the list case
If USERDOC = Empty Then
USERDOC = User
End If

' Nome utilizador
Utilizador.Value = USERDOC


' Nr de documento
    On Error Resume Next
    Dim DOCNR As Variant
    DOCNR = DMax("[Nr_Doc]", "Correspondence Tracking", "[Ano] = " & Year(Now)) + 1
    If DOCNR > 0 Then
    ' ok
    Else
    DOCNR = "00001"
    End If
  ' verificar tamanho do numero
  If Len(DOCNR) = 1 Then
  DOCNR = "0000" & DOCNR
  End If
  If Len(DOCNR) = 2 Then
  DOCNR = "000" & DOCNR
  End If
  If Len(DOCNR) = 3 Then
  DOCNR = "00" & DOCNR
  End If
  If Len(DOCNR) = 4 Then
  DOCNR = "0" & DOCNR
  End If
' save document number
NRef.Value = DOCNR & "/" & USERDOC & "/" & Year(Now)
Me.Refresh
End Sub
'------------------------------------------------------------
' Apagar_Click
'
'------------------------------------------------------------
Private Sub Apagar_Click()
On Error GoTo Apagar_Click_Err

    On Error Resume Next
    DoCmd.GoToControl Screen.PreviousControl.Name
    Err.Clear
    If (Not Form.NewRecord) Then
        DoCmd.RunCommand acCmdDeleteRecord
    End If
    If (Form.NewRecord And Not Form.Dirty) Then
        Beep
    End If
    If (Form.NewRecord And Form.Dirty) Then
        DoCmd.RunCommand acCmdUndo
    End If
    If (MacroError <> 0) Then
        Beep
        MsgBox MacroError.Description, vbOKOnly, ""
    End If


Apagar_Click_Exit:
    Exit Sub

Apagar_Click_Err:
    MsgBox Error$
    Resume Apagar_Click_Exit

End Sub

8 horas de trabalho (pensei que conseguia fazer isto em 1 hora) mas a primeira parte (registo) já funciona perfeitamente.

Agora só falta a pesquisa, o apagar (com código de autorização e/ou de acordo com o user) e o imprimir o cabeça-lho.

Eventualmente ainda pondero que cada registo de carta seja enviado para um determinado email para controlo...

Falta também o código de entrada na página, com mensagens, etc...

[Robusto]

Deste-lhe bem! Estas a usar o visual express, ou é diretamente em vba?

[Thorn Gilts]

Deste-lhe bem! Estas a usar o visual express, ou é diretamente em vba?

VBA

[Thorn Gilts]

VBA no Report

Option Compare Database

Private Sub apagar_registo_Click()

'On Error GoTo Errorhandler

Set db = CurrentDb
Set rs = db.OpenRecordset("Correspondence Tracking")

If Not Environ$("Username") = "OV" Or _
Environ$("Username") = "INT" Or _
Environ$("Username") = "ADM" Then
    pass_word = InputBox("O seu nível de acesso não lhe permite apagar registos directamente, tem de introduzir a palavra-passe:", "APAGAR REGISTOS", "Introduza a palavra-passe.")
    If Not pass_word = "XXXXXX" Then
    MsgBox "NÃO AUTORIZADO", vbCritical, "APAGAR REGISTOS"
    Exit Sub
    End If
End If


ID_input = InputBox("Por favor, introduza o ID do registo que pretende apagar da base de dados.", "APAGAR REGISTOS", "ID do registo a apagar")


intCounter = 0
    Do Until rs.EOF
        Dim a As Integer
        Dim b As Integer
        a = rs("ID")
        b = ID_input
        If a = b Then
            rs.Delete
            intCounter = intCounter + 1
            MsgBox "O ID """ & b & """ foi apagado com sucesso.", vbInformation, "APAGAR REGISTOS"
        End If
        If Not rs.EOF Then
            rs.MoveNext
        End If
    Loop

  If intCounter = 0 Then
  MsgBox "O ID """ & ID_input & """ não foi encontrado ou não é válido", vbCritical, "APAGAR REGISTOS"
  End If

  Set db = Nothing
  Set rs = Nothing
 
Exit Sub

Errorhandler:

MsgBox "Tem de introduzir um ID válido ou então a base de dados está corrompida", vbCritical, "APAGAR REGISTOS"
 
End Sub

Private Sub close_report_Click()
On Error Resume Next
    resposta = MsgBox("Tem a certeza que pretende fechar a consulta do Registo de Correspondência Recebida?", vbYesNo, "REGISTO DE CORRESPONDÊNCIA RECEBIDA - FECHAR CONSULTA")
    If resposta = vbYes Then
    DoCmd.Close acReport, "CORRESPONDÊNCIA RECEBIDA - CONSULTA"
    End If
End Sub


Private Sub excel_Click()
On Error GoTo excel_Click_Err

    DoCmd.OutputTo acOutputReport, "CORRESPONDÊNCIA RECEBIDA - CONSULTA", "", "", False, "", 0


excel_Click_Exit:
    Exit Sub

excel_Click_Err:
    MsgBox Error$
    Resume excel_Click_Exit

End Sub

Private Sub desactivar_filtro_Click()
Me.FilterOn = False
Me.ano_lista = ""
Me.nrdoc_lista = ""
Me.nref_lista = ""
Me.vref_lista = ""
Me.utilizador_lista = ""
Me.nome_lista = ""
Me.organizacao_lista = ""
Me.email_lista = ""
Me.morada_lista = ""
Me.codigo_postal_lista = ""


MsgBox "Filtro desactivado.", vbOKOnly, "REGISTO DE CORRESPONDÊNCIA RECEBIDA - FILTRO"

End Sub

Private Sub filtro_Click()

On Error GoTo Errorhandler

' ano
If Me.ano_lista.ItemsSelected.Count > 0 Then
filtroano = "[ID] = " & Me.ano_lista.Value
tipofiltro = "Ano"
Else
filtroano = ""
End If

' nr doc
If Me.nrdoc_lista.ItemsSelected.Count > 0 Then
    If Me.ano_lista.ItemsSelected.Count > 0 Then
    filtronrdoc = "AND" & "[ID] = " & Me.nrdoc_lista.Value
    tipofiltro = tipofiltro & ", Nr. Documento"
    Else
    filtronrdoc = "[ID] = " & Me.nrdoc_lista.Value
    tipofiltro = tipofiltro & "Nr. Documento"
    End If
Else
filtronrdoc = ""
End If

' N/Ref
If Me.nref_lista.ItemsSelected.Count > 0 Then
    If Me.ano_lista.ItemsSelected.Count > 0 Or _
       Me.nrdoc_lista.ItemsSelected.Count > 0 Then
    filtronref = "AND" & "[ID] = " & Me.nref_lista.Value
    tipofiltro = tipofiltro & ", N/Ref."
    Else
    filtronref = "[ID] = " & Me.nref_lista.Value
    tipofiltro = tipofiltro & "N/Ref."
    End If
Else
filtronref = ""
End If

' V/Ref
If Me.vref_lista.ItemsSelected.Count > 0 Then
    If Me.ano_lista.ItemsSelected.Count > 0 Or _
       Me.nrdoc_lista.ItemsSelected.Count > 0 Or _
       Me.nref_lista.ItemsSelected.Count > 0 Then
    filtrovref = "AND" & "[ID] = " & Me.vref_lista.Value
    tipofiltro = tipofiltro & ", V/Ref."
    Else
    filtrovref = "[ID] = " & Me.vref_lista.Value
    tipofiltro = tipofiltro & "V/Ref."
    End If
Else
filtrovref = ""
End If

' Utilizador
If Me.utilizador_lista.ItemsSelected.Count > 0 Then
    If Me.ano_lista.ItemsSelected.Count > 0 Or _
       Me.nrdoc_lista.ItemsSelected.Count > 0 Or _
       Me.nref_lista.ItemsSelected.Count > 0 Or _
       Me.vref_lista.ItemsSelected.Count > 0 Then
    filtroutilizador = "AND" & "[ID] = " & Me.utilizador_lista.Value
    tipofiltro = tipofiltro & ", Utilizador"
    Else
    filtroutilizador = "[ID] = " & Me.utilizador_lista.Value
    tipofiltro = tipofiltro & ", Utilizador"
    End If
Else
filtroutilizador = ""
End If

' Nome do destinatário
If Me.nome_lista.ItemsSelected.Count > 0 Then
    If Me.ano_lista.ItemsSelected.Count > 0 Or _
       Me.nrdoc_lista.ItemsSelected.Count > 0 Or _
       Me.nref_lista.ItemsSelected.Count > 0 Or _
       Me.vref_lista.ItemsSelected.Count > 0 Or _
       Me.utilizador_lista.ItemsSelected.Count > 0 Then
    filtronome = "AND" & "[ID] = " & Me.nome_lista.Value
    tipofiltro = tipofiltro & ", Nome do destinatário"
    Else
    filtronome = "[ID] = " & Me.nome_lista.Value
    tipofiltro = tipofiltro & ", Nome do destinatário"
    End If
Else
filtronome = ""
End If

' Organização do destinatario
If Me.organizacao_lista.ItemsSelected.Count > 0 Then
    If Me.ano_lista.ItemsSelected.Count > 0 Or _
       Me.nrdoc_lista.ItemsSelected.Count > 0 Or _
       Me.nref_lista.ItemsSelected.Count > 0 Or _
       Me.vref_lista.ItemsSelected.Count > 0 Or _
       Me.utilizador_lista.ItemsSelected.Count > 0 Or _
       Me.nome_lista.ItemsSelected.Count > 0 Then
    filtroorganizacao = "AND" & "[ID] = " & Me.organizacao_lista.Value
    tipofiltro = tipofiltro & ", Organização do destinatário"
    Else
    filtroorganizacao = "[ID] = " & Me.organizacao_lista.Value
    tipofiltro = tipofiltro & "Organização do destinatário"
    End If
Else
filtroorganizacao = ""
End If

' Email do destinatário
If Me.email_lista.ItemsSelected.Count > 0 Then
    If Me.ano_lista.ItemsSelected.Count > 0 Or _
       Me.nrdoc_lista.ItemsSelected.Count > 0 Or _
       Me.nref_lista.ItemsSelected.Count > 0 Or _
       Me.vref_lista.ItemsSelected.Count > 0 Or _
       Me.utilizador_lista.ItemsSelected.Count > 0 Or _
       Me.nome_lista.ItemsSelected.Count > 0 Or _
       Me.organizacao_lista.ItemsSelected.Count > 0 Then
    filtroemail = "AND" & "[ID] = " & Me.email_lista.Value
    tipofiltro = tipofiltro & ", Email do destinatário"
    Else
    filtroemail = "[ID] = " & Me.email_lista.Value
    tipofiltro = tipofiltro & "Email do destinatário"
    End If
Else
filtroemail = ""
End If

' Morada do destinatário
If Me.morada_lista.ItemsSelected.Count > 0 Then
    If Me.ano_lista.ItemsSelected.Count > 0 Or _
       Me.nrdoc_lista.ItemsSelected.Count > 0 Or _
       Me.nref_lista.ItemsSelected.Count > 0 Or _
       Me.vref_lista.ItemsSelected.Count > 0 Or _
       Me.utilizador_lista.ItemsSelected.Count > 0 Or _
       Me.nome_lista.ItemsSelected.Count > 0 Or _
       Me.organizacao_lista.ItemsSelected.Count > 0 Or _
       Me.email_lista.ItemsSelected.Count > 0 Then
    filtromorada = "AND" & "[ID] = " & Me.morada_lista.Value
    tipofiltro = tipofiltro & ", Morada do destinatário"
    Else
    filtromorada = "[ID] = " & Me.morada_lista.Value
    tipofiltro = tipofiltro & ", Morada do destinatário"
    End If
Else
filtromorada = ""
End If

' Codigo postal
If Me.codigo_postal_lista.ItemsSelected.Count > 0 Then
    If Me.ano_lista.ItemsSelected.Count > 0 Or _
       Me.nrdoc_lista.ItemsSelected.Count > 0 Or _
       Me.nref_lista.ItemsSelected.Count > 0 Or _
       Me.vref_lista.ItemsSelected.Count > 0 Or _
       Me.utilizador_lista.ItemsSelected.Count > 0 Or _
       Me.nome_lista.ItemsSelected.Count > 0 Or _
       Me.organizacao_lista.ItemsSelected.Count > 0 Or _
       Me.email_lista.ItemsSelected.Count > 0 Or _
       Me.morada_lista.ItemsSelected.Count > 0 Then
    filtrocodigo_postal = "AND" & "[ID] = " & Me.codigo_postal_lista.Value
    tipofiltro = tipofiltro & ", Código postal"
    Else
    filtrocodigo_postal = "[ID] = " & Me.codigo_postal_lista.Value
    tipofiltro = tipofiltro & "Código postal"
    End If
Else
filtrocodigo_postal = ""
End If

' Localidade
If Me.localidade_lista.ItemsSelected.Count > 0 Then
    If Me.ano_lista.ItemsSelected.Count > 0 Or _
       Me.nrdoc_lista.ItemsSelected.Count > 0 Or _
       Me.nref_lista.ItemsSelected.Count > 0 Or _
       Me.vref_lista.ItemsSelected.Count > 0 Or _
       Me.utilizador_lista.ItemsSelected.Count > 0 Or _
       Me.nome_lista.ItemsSelected.Count > 0 Or _
       Me.organizacao_lista.ItemsSelected.Count > 0 Or _
       Me.email_lista.ItemsSelected.Count > 0 Or _
       Me.morada_lista.ItemsSelected.Count > 0 Or _
       Me.codigo_postal_lista.ItemsSelected.Count > 0 Then
    filtrolocalidade = "AND" & "[ID] = " & Me.localidade_lista.Value
    tipofiltro = tipofiltro & ", Localidade"
    Else
    filtrolocalidade = "[ID] = " & Me.localidade_lista.Value
    tipofiltro = tipofiltro & "Localidade"
    End If
Else
filtrolocalidade = ""
End If

If tipofiltro = Empty Then
GoTo Errorhandler
End If

MsgBox "Respultados filtrados por: " & tipofiltro


' FILTRO
Me.Filter = filtroano & filtronrdoc & filtronref & filtrovref & filtroutilizador & filtronome & filtroorganizacao & filtroemail & filtromorada & filtrocodigo_postal & filtrolocalidade
Me.FilterOn = True
Exit Sub

Errorhandler:
MsgBox "Selectione pelo menos um filtro (o campo selecionado deve ficar cinzento escuro).", vbOKOnly, "REGISTO DE CORRESPONDÊNCIA RECEBIDA - FILTRO"

End Sub

No FORM

Option Compare Database

Private Sub imprimir_Click()

On Error GoTo imprimir_Click_Err

    DoCmd.RunCommand acCmdSelectRecord
    DoCmd.RunCommand acCmdPrintSelection


imprimir_Click_Exit:
    Exit Sub

imprimir_Click_Err:
    MsgBox Error$
    Resume imprimir_Click_Exit

End Sub


Private Sub novo_Click()

On Error GoTo novo_Click_Err

    DoCmd.GoToRecord , "", acLast
    DoCmd.GoToRecord , ""

novo_Click_Exit:
    Exit Sub

novo_Click_Err:
    MsgBox Error$
    Resume novo_Click_Exit

End Sub




Private Sub procurar_Click()
On Error GoTo procurar_Click_Err


    On Error Resume Next
    DoCmd.GoToControl Screen.PreviousControl.Name
    Err.Clear
    DoCmd.RunCommand acCmdFind
    If (MacroError <> 0) Then
        Beep
        MsgBox MacroError.Description, vbOKOnly, ""
            End If


procurar_Click_Exit:
    Exit Sub

procurar_Click_Err:
    MsgBox Error$
    Resume procurar_Click_Exit

End Sub


Private Sub consulta_Click()
On Error Resume Next
Me.Refresh
DoCmd.OpenReport "CORRESPONDÊNCIA RECEBIDA - CONSULTA", acViewReport
End Sub

Private Sub Form_Load()
DoCmd.Maximize
End Sub

Private Sub Form_Open(Cancel As Integer)
DoCmd.Maximize
End Sub
Private Sub Código_Postal_GotFocus()
If Forms![CORRESPONDÊNCIA RECEBIDA].Codigo_Postal = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA RECEBIDA].Codigo_Postal = Empty
Me.Código_Postal.ForeColor = vbBlack
Me.Código_Postal.FontItalic = False
Me.Código_Postal.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub Localidade_GotFocus()
If Forms![CORRESPONDÊNCIA RECEBIDA].Localidade = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA RECEBIDA].Localidade = Empty
Me.Localidade.ForeColor = vbBlack
Me.Localidade.FontItalic = False
Me.Localidade.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub Morada_GotFocus()
If Forms![CORRESPONDÊNCIA RECEBIDA].Morada = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA RECEBIDA].Morada = ""
Me.Morada.ForeColor = vbBlack
Me.Morada.FontItalic = False
Me.Morada.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub Nome_destinatário_GotFocus()
If Forms![CORRESPONDÊNCIA RECEBIDA].Nome = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA RECEBIDA].Nome = ""
Me.Nome_destinatário.ForeColor = vbBlack
Me.Nome_destinatário.FontItalic = False
Me.Nome_destinatário.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub gravar_Click()

' Gerir erros de registo em caso de estarem apagados (#Deleted)
On Error GoTo ErrorDeletedHandlder
If Me.Nome.Value = Null Then
End If
GoTo Code

' Abre novo registo em caso de erro (ex. #Deleted)
ErrorDeletedHandlder:
DoCmd.GoToRecord , , acNewRec
Exit Sub

' começa aqui o processo se tudo estiver bem.
Code:

On Error GoTo Error_handler

  Call DOCNR
  Me.Refresh

 ' verificar campos vazios
 If Len(Me.Nome & vbNullString) = 0 Or _
 Forms![CORRESPONDÊNCIA RECEBIDA].Nome = "Preenchimento obrigatório" Then
 MsgBox "O campo do nome é de preenchimento obrigatório"
 Me.Label3.FontBold = True
 Me.Label3.ForeColor = vbRed
 Forms![CORRESPONDÊNCIA RECEBIDA].Nome = "Preenchimento obrigatório"
 Me.Nome_destinatário.ForeColor = RGB(127, 127, 127)
 Me.Nome_destinatário.FontItalic = True
 Me.Nome_destinatário.FontSize = 8
 Me.Refresh
    Call queimar_tempo
 Me.Label3.FontBold = False
 Me.Label3.ForeColor = RGB(127, 127, 127)
 Me.Refresh
 Exit Sub
 End If
 
 If Len(Me.Email & vbNullString) = 0 Then

    If Len(Me.Morada & vbNullString) = 0 Or _
    Forms![CORRESPONDÊNCIA RECEBIDA].Morada = "Preenchimento obrigatório" Then
    MsgBox "O campo da Morada (ou então o de email) é de preenchimento obrigatório"
    Me.Label12.FontBold = True
    Me.Label12.ForeColor = vbRed
    Forms![CORRESPONDÊNCIA RECEBIDA].Morada = "Preenchimento obrigatório"
    Me.Morada.ForeColor = RGB(127, 127, 127)
    Me.Morada.FontItalic = True
    Me.Morada.FontSize = 8
    Me.Refresh
        Call queimar_tempo
    Me.Label12.FontBold = False
    Me.Label12.ForeColor = RGB(127, 127, 127)
    Me.Refresh
    Exit Sub
    End If
 
    If Len(Me.Codigo_Postal & vbNullString) = 0 Or _
    Forms![CORRESPONDÊNCIA RECEBIDA].Codigo_Postal = "Preenchimento obrigatório" Then
    MsgBox "O campo do Código Postal é de preenchimento obrigatório"
    Me.Label15.FontBold = True
    Me.Label15.ForeColor = vbRed
    Forms![CORRESPONDÊNCIA RECEBIDA].Codigo_Postal = "Preenchimento obrigatório"
    Me.Código_Postal.ForeColor = RGB(127, 127, 127)
    Me.Código_Postal.FontItalic = True
    Me.Código_Postal.FontSize = 8
    Me.Refresh
      Call queimar_tempo
    Me.Label15.FontBold = False
    Me.Label15.ForeColor = RGB(127, 127, 127)
    Me.Refresh
    Exit Sub
    End If
   
    If Len(Me.Localidade & vbNullString) = 0 Or _
    Forms![CORRESPONDÊNCIA RECEBIDA].Localidade = "Preenchimento obrigatório" Then
    MsgBox "O campo da Localidade a é de preenchimento obrigatório"
    Me.Label18.FontBold = True
    Me.Label18.ForeColor = vbRed
    Forms![CORRESPONDÊNCIA RECEBIDA].Localidade = "Preenchimento obrigatório"
    Me.Localidade.ForeColor = RGB(127, 127, 127)
    Me.Localidade.FontItalic = True
    Me.Localidade.FontSize = 8
    Me.Refresh
      Call queimar_tempo
    Me.Label18.FontBold = False
    Me.Label18.ForeColor = RGB(127, 127, 127)
    Me.Refresh
    Exit Sub
    End If
End If
 
' confirmar dados
If Len(Me.Email & vbNullString) = 0 And Len(Me.Morada & vbNullString) = 0 Then
    If Len(Me.Email & vbNullString) = 0 Then
    resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Morada: " & Morada & ", " & Codigo_Postal & ", " & Localidade & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
        If resposta = vbCancel Then
        Exit Sub
        End If
    Else
    resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Email: " & Email & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
        If resposta = vbCancel Then
        Exit Sub
        End If
    End If
Else
    If Len(Me.Email & vbNullString) > 0 And Len(Me.Morada & vbNullString) > 0 Then
    resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Email: " & Email & vbNewLine & "Morada: " & Morada & ", " & Codigo_Postal & ", " & Localidade & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
    Else
        If Len(Me.Email & vbNullString) = 0 Then
        resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Morada: " & Morada & ", " & Codigo_Postal & ", " & Localidade & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
           If resposta = vbCancel Then
           Exit Sub
           End If
        Else
        resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Email: " & Email & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
           If resposta = vbCancel Then
          Exit Sub
           End If
        End If
    End If
End If
 
REFERENCIA = NRef

 
    On Error Resume Next
    DoCmd.GoToRecord , "", acNewRec
    If (MacroError <> 0) Then
        Beep
        MsgBox MacroError.Description, vbOKOnly, ""
    End If
   
  Set db = CurrentDb
  Set rs = db.OpenRecordset("Correspondence Tracking")
 
  If Not rs("Nr_Doc") = Empty Then
  rs("Timestamp").Value = rs("Timestamp").Value & "Editado em: " & Now
  rs("Utilizador") = rs("Utilizador") & "Editado por: " & Environ$("Username")
  rs.Update
  Set db = Nothing
  Set rs = Nothing
  Me.Refresh
  MsgBox "Registo da correspondência actualizada com sucesso pelo utilizador " & Environ$("Username") & " em " & Now & " com a referência " & REFERENCIA & "."
  Exit Sub
  End If

  rs.MoveLast
  rs.Edit
  rs("Timestamp").Value = Now
  rs("Utilizador") = Environ$("Username")
  rs("Ano").Value = Year(Now)
  ' Nr de documento
    On Error Resume Next
    Dim NRDOC As Variant
    NRDOC = DMax("[Nr_Doc]", "Correspondence Tracking", "[Ano] = " & Year(Now)) + 1
    If NRDOC > 0 Then
    ' ok
    Else
    NRDOC = "00001"
    End If
  rs("Nr_Doc") = NRDOC
  rs.Update
  Set db = Nothing
  Set rs = Nothing
  Me.Refresh
     
MsgBox "Registo da correspondência gravada com sucesso pelo utilizador " & Environ$("Username") & " em " & Now & " com a referência " & REFERENCIA & "."
Exit Sub
Error_handler:
MsgBox "Algum erro aconteceu, confirme por favor o registo.", vbCritical
End Sub

Sub queimar_tempo()
        ' queimar tempo
        Dim PauseTimeA, StartA
        PauseTimeA = 1
        StartA = Timer
        Do While Timer < StartA + PauseTimeA
        DoEvents
        Loop
End Sub

Private Sub Data_de_envio_AfterUpdate()
Call DOCNR
End Sub

Private Sub Data_de_recepção_AfterUpdate()
Call DOCNR
End Sub

Private Sub Email_AfterUpdate()
Call DOCNR
End Sub


Private Sub Localidade_AfterUpdate()
Call DOCNR
End Sub

Private Sub Morada_AfterUpdate()
Call DOCNR
End Sub

Private Sub N_Ref_GotFocus()
Call DOCNR
End Sub

Private Sub Código_Postal_AfterUpdate()
Call DOCNR
End Sub

Private Sub Nome_destinatário_AfterUpdate()
Call DOCNR
End Sub

Private Sub Número_de_Páginas_AfterUpdate()
Call DOCNR
End Sub

Private Sub Observações_AfterUpdate()
Call DOCNR
End Sub

Private Sub Organização_AfterUpdate()
Call DOCNR
End Sub



Private Sub Timestamp_AfterUpdate()
Call DOCNR
End Sub

Private Sub Utilizador_AfterUpdate()
Call DOCNR
End Sub

Private Sub V_Ref_AfterUpdate()
Call DOCNR
End Sub

Private Sub sair_Click()

    resposta = MsgBox("Tem a certeza que pretende fechar o Registo de Correspondência Recebida?", vbYesNo, "REGISTO DE CORRESPONDÊNCIA RECEBIDA - FECHAR")
    If resposta = vbYes Then
    Application.Quit
    End If

End Sub

Sub DOCNR()


' timestamp
Timestamp.Value = Now

' USERDOC
If Len(Me.NRef & vbNullString) > 0 Then
Dim USERDOCArray() As String
USERDOCArray = Split(NRef.Value, "/", 3)
USERDOC = USERDOCArray(1)
    ' aviso de USERDOC diferente
    If Not USERDOC = (Environ$("Username")) Then
    MsgBox "O documento vai ser registado com um N/Ref que contém o utilizador ''" & USERDOC & "'' em vez do utilizador ''" & (Environ$("Username")) & "'' a usar este computador.", vbInformation, "UTILIZADOR - AVISO"
    End If
Else
USERDOC = (Environ$("Username"))
End If


' Nome utilizador
Utilizador.Value = (Environ$("Username"))

' Nr de documento
    On Error Resume Next
    Dim DOCNR As Variant
    DOCNR = DMax("[Nr_Doc]", "Correspondence Tracking", "[Ano] = " & Year(Now)) + 1
    If DOCNR > 0 Then
    ' ok
    Else
    DOCNR = "00001"
    End If
  ' verificar tamanho do numero
  If Len(DOCNR) = 1 Then
  DOCNR = "0000" & DOCNR
  End If
  If Len(DOCNR) = 2 Then
  DOCNR = "000" & DOCNR
  End If
  If Len(DOCNR) = 3 Then
  DOCNR = "00" & DOCNR
  End If
  If Len(DOCNR) = 4 Then
  DOCNR = "0" & DOCNR
  End If
' save document number
NRef.Value = DOCNR & "/" & USERDOC & "/" & Year(Now)
Me.Refresh
End Sub

Private Sub Apagar_Click()

On Error GoTo Apagar_Click_Err

    On Error Resume Next
   
   
    DoCmd.GoToControl Screen.PreviousControl.Name
    Err.Clear
    If (Not Form.NewRecord) Then
        DoCmd.RunCommand acCmdDeleteRecord
    End If
    If (Form.NewRecord And Not Form.Dirty) Then
        Beep
    End If
    If (Form.NewRecord And Form.Dirty) Then
        DoCmd.RunCommand acCmdUndo
    End If
    If (MacroError <> 0) Then
        Beep
        MsgBox MacroError.Description, vbOKOnly, ""
    End If


Apagar_Click_Exit:
    Exit Sub

Apagar_Click_Err:
    MsgBox Error$
    Resume Apagar_Click_Exit

End Sub

[Robusto]

Obrigado por partilhares! Eu em breve, provavelmente vou ter que criar algo do género, um ficheiro excel que tenha várias atividades realizadas com Access (pesquisa, storage de anexos, etc).

Mas neste caso em específico, não seria mais rentável adquirires uma licença de um software de gestão documental? Ou tinha que ser mesmo "tailor made"?

[Thorn Gilts]

Obrigado por partilhares! Eu em breve, provavelmente vou ter que criar algo do género, um ficheiro excel que tenha várias atividades realizadas com Access (pesquisa, storage de anexos, etc).

Mas neste caso em específico, não seria mais rentável adquirires uma licença de um software de gestão documental? Ou tinha que ser mesmo "tailor made"?

Já esta feito e de acordo com o que pretendia (e não encontrava por ai à venda)... Permita ainda editar como quiser e o desgin (bem giro) esta exactamente como eu quero, tanto o do form, como o do report.

Entetanto o código já foi alterado um pouco... tem um erro no algortimo e uma password de acesso ao login... depois de se aceder com a password uma vez num computador, já não é necessário mais vezes.

Option Compare Database
Private Sub Form_Load()
DoCmd.Maximize
If DCount("[USER]", "[user_login]", "[USER]='" & Environ$("Username") & "'") > 0 Then
MsgBox "Acesso concedido ao utilizador: " & Environ$("Username"), vbInformation, "LOGIN"
Else
password_login = InputBox("O utilizador " & Environ$("Username") & " não tem permissão para aceder. Por favor introduza a password de acesso.", "LOGIN", "palavra-passe de login")
    If password_login = "XXXXXX" Then
    ' gravar na base
    Dim db_login As DAO.Database
    Dim rs_login As DAO.Recordset
    Set db_login = CurrentDb
    Set rs_login = db_login.OpenRecordset("user_login")
    rs_login.AddNew
    rs_login("USER") = Environ$("Username")
    rs_login("Timestamp").Value = Now
    rs_login.Update
    Set db_login = Nothing
    Set rs_login = Nothing
    MsgBox "Acesso concedido ao utilizador: " & Environ$("Username"), vbInformation, "LOGIN"
    Else
    MsgBox "Falhou o login!", vbCritical, "LOGIN - FALHOU"
 
    Application.CloseCurrentDatabase
    End If
End If
End Sub

Private Sub Form_Open(Cancel As Integer)
DoCmd.Maximize
End Sub


Private Sub imprimir_Click()

On Error GoTo imprimir_Click_Err

    DoCmd.RunCommand acCmdSelectRecord
    DoCmd.RunCommand acCmdPrintSelection


imprimir_Click_Exit:
    Exit Sub

imprimir_Click_Err:
    MsgBox Error$
    Resume imprimir_Click_Exit

End Sub


Private Sub novo_Click()

On Error GoTo novo_Click_Err

    DoCmd.GoToRecord , "", acLast
    DoCmd.GoToRecord , ""

novo_Click_Exit:
    Exit Sub

novo_Click_Err:
    MsgBox Error$
    Resume novo_Click_Exit

End Sub




Private Sub procurar_Click()
On Error GoTo procurar_Click_Err


    On Error Resume Next
    DoCmd.GoToControl Screen.PreviousControl.Name
    Err.Clear
    DoCmd.RunCommand acCmdFind
    If (MacroError <> 0) Then
        Beep
        MsgBox MacroError.Description, vbOKOnly, ""
            End If


procurar_Click_Exit:
    Exit Sub

procurar_Click_Err:
    MsgBox Error$
    Resume procurar_Click_Exit

End Sub


Private Sub consulta_Click()
On Error Resume Next
Me.Refresh
DoCmd.OpenReport "CORRESPONDÊNCIA ENVIADA - CONSULTA", acViewReport
End Sub

Private Sub Código_Postal_GotFocus()
If Forms![CORRESPONDÊNCIA ENVIADA].Codigo_Postal = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA ENVIADA].Codigo_Postal = Empty
Me.Código_Postal.ForeColor = vbBlack
Me.Código_Postal.FontItalic = False
Me.Código_Postal.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub Assunto_GotFocus()
If Forms![CORRESPONDÊNCIA ENVIADA].Localidade = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA ENVIADA].Localidade = Empty
Me.Assunto.ForeColor = vbBlack
Me.Assunto.FontItalic = False
Me.Assunto.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub Morada_GotFocus()
If Forms![CORRESPONDÊNCIA ENVIADA].Morada = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA ENVIADA].Morada = ""
Me.Morada.ForeColor = vbBlack
Me.Morada.FontItalic = False
Me.Morada.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub Nome_destinatário_GotFocus()
If Forms![CORRESPONDÊNCIA ENVIADA].Nome = "Preenchimento obrigatório" Then
Forms![CORRESPONDÊNCIA ENVIADA].Nome = ""
Me.Nome_destinatário.ForeColor = vbBlack
Me.Nome_destinatário.FontItalic = False
Me.Nome_destinatário.FontSize = 11
Me.Refresh
End If
End Sub

Private Sub gravar_Click()

' Gerir erros de registo em caso de estarem apagados (#Deleted)
On Error GoTo ErrorDeletedHandlder
If Me.Nome.Value = Null Then
End If
GoTo Code

' Abre novo registo em caso de erro (ex. #Deleted)
ErrorDeletedHandlder:
DoCmd.GoToRecord , , acNewRec
Exit Sub

' começa aqui o processo se tudo estiver bem.
Code:

On Error GoTo Error_handler

  Call DOCNR
  Me.Refresh

 ' verificar campos vazios
 If Len(Me.Nome & vbNullString) = 0 Or _
 Forms![CORRESPONDÊNCIA ENVIADA].Nome = "Preenchimento obrigatório" Then
 MsgBox "O campo do nome é de preenchimento obrigatório"
 Me.Label3.FontBold = True
 Me.Label3.ForeColor = vbRed
 Forms![CORRESPONDÊNCIA ENVIADA].Nome = "Preenchimento obrigatório"
 Me.Nome_destinatário.ForeColor = RGB(127, 127, 127)
 Me.Nome_destinatário.FontItalic = True
 Me.Nome_destinatário.FontSize = 8
 Me.Refresh
    Call queimar_tempo
 Me.Label3.FontBold = False
 Me.Label3.ForeColor = RGB(127, 127, 127)
 Me.Refresh
 Exit Sub
 End If
 
 If Len(Me.Email & vbNullString) = 0 Then

    If Len(Me.Morada & vbNullString) = 0 Or _
    Forms![CORRESPONDÊNCIA ENVIADA].Morada = "Preenchimento obrigatório" Then
    MsgBox "O campo da Morada (ou então o de email) é de preenchimento obrigatório"
    Me.Label12.FontBold = True
    Me.Label12.ForeColor = vbRed
    Forms![CORRESPONDÊNCIA ENVIADA].Morada = "Preenchimento obrigatório"
    Me.Morada.ForeColor = RGB(127, 127, 127)
    Me.Morada.FontItalic = True
    Me.Morada.FontSize = 8
    Me.Refresh
        Call queimar_tempo
    Me.Label12.FontBold = False
    Me.Label12.ForeColor = RGB(127, 127, 127)
    Me.Refresh
    Exit Sub
    End If
 
    If Len(Me.Codigo_Postal & vbNullString) = 0 Or _
    Forms![CORRESPONDÊNCIA ENVIADA].Codigo_Postal = "Preenchimento obrigatório" Then
    MsgBox "O campo do Código Postal é de preenchimento obrigatório"
    Me.Label15.FontBold = True
    Me.Label15.ForeColor = vbRed
    Forms![CORRESPONDÊNCIA ENVIADA].Codigo_Postal = "Preenchimento obrigatório"
    Me.Código_Postal.ForeColor = RGB(127, 127, 127)
    Me.Código_Postal.FontItalic = True
    Me.Código_Postal.FontSize = 8
    Me.Refresh
      Call queimar_tempo
    Me.Label15.FontBold = False
    Me.Label15.ForeColor = RGB(127, 127, 127)
    Me.Refresh
    Exit Sub
    End If
End If
 
' verificar se assunto esta vazio
If Len(Me.Localidade & vbNullString) = 0 Or _
    Forms![CORRESPONDÊNCIA ENVIADA].Localidade = "Preenchimento obrigatório" Then
    MsgBox "O campo do Assunto é de preenchimento obrigatório"
    Me.Label18.FontBold = True
    Me.Label18.ForeColor = vbRed
    Forms![CORRESPONDÊNCIA ENVIADA].Localidade = "Preenchimento obrigatório"
    Me.Assunto.ForeColor = RGB(127, 127, 127)
    Me.Assunto.FontItalic = True
    Me.Assunto.FontSize = 8
    Me.Refresh
      Call queimar_tempo
    Me.Label18.FontBold = False
    Me.Label18.ForeColor = RGB(127, 127, 127)
    Me.Refresh
    Exit Sub
End If
 
 
' confirmar dados
If Len(Me.Email & vbNullString) = 0 And Len(Me.Morada & vbNullString) = 0 Then
    If Len(Me.Email & vbNullString) = 0 Then
    resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Assunto:" & Assunto & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Morada: " & Morada & ", " & Codigo_Postal & ", " & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
        If resposta = vbCancel Then
        Exit Sub
        End If
    Else
    resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Assunto:" & Assunto & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Email: " & Email & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
        If resposta = vbCancel Then
        Exit Sub
        End If
    End If
Else
    If Len(Me.Email & vbNullString) > 0 And Len(Me.Morada & vbNullString) > 0 Then
    resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Assunto:" & Assunto & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Email: " & Email & vbNewLine & "Morada: " & Morada & ", " & Codigo_Postal & ", " & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
    Else
        If Len(Me.Email & vbNullString) = 0 Then
        resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Assunto:" & Assunto & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Morada: " & Morada & ", " & Codigo_Postal & ", " & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
           If resposta = vbCancel Then
           Exit Sub
           End If
        Else
        resposta = MsgBox("Confirme os dados introduzidos: " & vbNewLine & vbNewLine & "Assunto:" & Assunto & vbNewLine & vbNewLine & "Nome do destinatário: " & Nome & vbNewLine & "Email: " & Email & vbNewLine & vbNewLine & "Este documento tem a referência: " & NRef, vbOKCancel, "Confirmação de dados")
           If resposta = vbCancel Then
          Exit Sub
           End If
        End If
    End If
End If

' confirmar dados de codigo postal
If Len(Me.Morada & vbNullString) > 0 Then
    If Len(Me.Codigo_Postal & vbNullString) = 0 Or _
    Forms![CORRESPONDÊNCIA ENVIADA].Codigo_Postal = "Preenchimento obrigatório" Then
    MsgBox "O campo do Código Postal é de preenchimento obrigatório"
    Me.Label15.FontBold = True
    Me.Label15.ForeColor = vbRed
    Forms![CORRESPONDÊNCIA ENVIADA].Codigo_Postal = "Preenchimento obrigatório"
    Me.Código_Postal.ForeColor = RGB(127, 127, 127)
    Me.Código_Postal.FontItalic = True
    Me.Código_Postal.FontSize = 8
    Me.Refresh
      Call queimar_tempo
    Me.Label15.FontBold = False
    Me.Label15.ForeColor = RGB(127, 127, 127)
    Me.Refresh
    Exit Sub
    End If
End If
 
REFERENCIA = NRef
 
 
    On Error Resume Next
    DoCmd.GoToRecord , "", acNewRec
    If (MacroError <> 0) Then
        Beep
        MsgBox MacroError.Description, vbOKOnly, ""
    End If
   
  Set db = CurrentDb
  Set rs = db.OpenRecordset("Correspondence Tracking")
  rs.MoveLast
  If Not rs("Nr_Doc") = Empty Then
  rs("Timestamp").Value = rs("Timestamp").Value & "Editado em: " & Now
  rs("Utilizador") = rs("Utilizador") & "Editado por: " & Environ$("Username")
  rs.Update
  Set db = Nothing
  Set rs = Nothing
  Me.Refresh
  MsgBox "Registo da correspondência actualizada com sucesso pelo utilizador " & Environ$("Username") & " em " & Now & " com a referência " & REFERENCIA & "."
  Exit Sub
  End If

  rs.MoveLast
  rs.Edit
  rs("Timestamp").Value = Now
  rs("Utilizador") = Environ$("Username")
 

  rs("Ano").Value = Year(Now)
  ' Nr de documento
    On Error Resume Next
    Dim NRDOC As Variant
    NRDOC = DMax("[Nr_Doc]", "Correspondence Tracking", "[Ano] = " & Year(Now)) + 1
    If NRDOC > 0 Then
    ' ok
    Else
    NRDOC = "00001"
    End If
   rs("Nr_Doc") = NRDOC
  rs.Update
  Set db = Nothing
  Set rs = Nothing
  Me.Refresh
     
MsgBox "Registo da correspondência gravada com sucesso pelo utilizador " & Environ$("Username") & " em " & Now & " com a referência " & REFERENCIA & "."
Exit Sub
Error_handler:
MsgBox "Algum erro aconteceu, confirme por favor o registo.", vbCritical
End Sub

Sub queimar_tempo()
        ' queimar tempo
        Dim PauseTimeA, StartA
        PauseTimeA = 1
        StartA = Timer
        Do While Timer < StartA + PauseTimeA
        DoEvents
        Loop
End Sub

Private Sub Data_de_envio_AfterUpdate()
Call DOCNR
End Sub

Private Sub Data_de_recepção_AfterUpdate()
Call DOCNR
End Sub

Private Sub Email_AfterUpdate()
Call DOCNR
End Sub


Private Sub Localidade_AfterUpdate()
Call DOCNR
End Sub

Private Sub Morada_AfterUpdate()
Call DOCNR
End Sub

Private Sub N_Ref_GotFocus()
Call DOCNR
End Sub

Private Sub Código_Postal_AfterUpdate()
Call DOCNR
End Sub

Private Sub Nome_destinatário_AfterUpdate()
Call DOCNR
End Sub

Private Sub Número_de_Páginas_AfterUpdate()
Call DOCNR
End Sub

Private Sub Observações_AfterUpdate()
Call DOCNR
End Sub

Private Sub Organização_AfterUpdate()
Call DOCNR
End Sub



Private Sub Timestamp_AfterUpdate()
Call DOCNR
End Sub

Private Sub Utilizador_AfterUpdate()
Call DOCNR
End Sub

Private Sub V_Ref_AfterUpdate()
Call DOCNR
End Sub

Private Sub sair_Click()

    resposta = MsgBox("Tem a certeza que pretende fechar o Registo de Correspondência Enviada?", vbYesNo, "REGISTO DE CORRESPONDÊNCIA ENVIADA - FECHAR")
    If resposta = vbYes Then
    Application.Quit
    End If

End Sub

Sub DOCNR()


' timestamp
Timestamp.Value = Now

' USERDOC
If Len(Me.NRef & vbNullString) > 0 Then
Dim USERDOCArray() As String
USERDOCArray = Split(NRef.Value, "/", 3)
USERDOC = USERDOCArray(1)
    ' aviso de USERDOC diferente
    If Not USERDOC = (Environ$("Username")) Then
    MsgBox "O documento vai ser registado com um N/Ref que contém o utilizador ''" & USERDOC & "'' em vez do utilizador ''" & (Environ$("Username")) & "'' a usar este computador.", vbInformation, "UTILIZADOR - AVISO"
    End If
Else
USERDOC = (Environ$("Username"))
End If


' Nome utilizador
Utilizador.Value = (Environ$("Username"))


' Nr de documento
    On Error Resume Next
    Dim DOCNR As Variant
    DOCNR = DMax("[Nr_Doc]", "Correspondence Tracking", "[Ano] = " & Year(Now)) + 1
    If DOCNR > 0 Then
    ' ok
    Else
    DOCNR = "00001"
    End If

   
  ' verificar tamanho do numero
  If Len(DOCNR) = 1 Then
  DOCNR = "0000" & DOCNR
  End If
  If Len(DOCNR) = 2 Then
  DOCNR = "000" & DOCNR
  End If
  If Len(DOCNR) = 3 Then
  DOCNR = "00" & DOCNR
  End If
  If Len(DOCNR) = 4 Then
  DOCNR = "0" & DOCNR
  End If
' save document number

NRef.Value = DOCNR & "/" & USERDOC & "/" & Year(Now)
Me.Refresh
End Sub

Private Sub Apagar_Click()

On Error GoTo Apagar_Click_Err

    On Error Resume Next
   
   
    DoCmd.GoToControl Screen.PreviousControl.Name
    Err.Clear
    If (Not Form.NewRecord) Then
        DoCmd.RunCommand acCmdDeleteRecord
    End If
    If (Form.NewRecord And Not Form.Dirty) Then
        Beep
    End If
    If (Form.NewRecord And Form.Dirty) Then
        DoCmd.RunCommand acCmdUndo
    End If
    If (MacroError <> 0) Then
        Beep
        MsgBox MacroError.Description, vbOKOnly, ""
    End If


Apagar_Click_Exit:
    Exit Sub

Apagar_Click_Err:
    MsgBox Error$
    Resume Apagar_Click_Exit

End Sub

[Robusto]

Consegues colocar um hyperlink numa lisbox?

[Thorn Gilts]

Consegues colocar um hyperlink numa lisbox?

Sim... é so colocares o hyperlink na listbox em vez de outro texto qualquer... se funciona como hyperlink depois não sei, nunca tentei.