[Resolvido]Criar calendário Semanal tipo Planner

Tenho um calendário mensal que carrega eventos de uma tabela (agenda) conforme o mês selecionado.

Gostaria da ajuda dos colegas para fazer desse um calendário SEMANAL, tipo planner, iniciando na segunda-feira da semana cuja data seja escolhida, ou ainda projetando a agenda para a data + 6 dias.

Tentei mexer nesse código aqui, mas juro que não entendi... peguei ele de um outro modelo aqui!

Consegui aqui!


Coloquei uma caixa de texto com a data (txtData) e a partir dela ele joga os 7 dias!


Fica o código pra quem quiser usar:

Código:

Option Explicit


Private intMonth As Integer
Private intYear As Integer
Private lngFirstDayOfMonth As Long
Private intFirstWeekday As Integer
Private intDaysInMonth As Integer
Private myArray() As Variant



'''tips

Dim TTip As clsToolTip, TTip1 As clsToolTip


Private Sub Form_Open(Cancel As Integer)
Me.CriarTips
End Sub

Sub CriarTips()
Set TTip = New clsToolTip
Set TTip1 = New clsToolTip
On Error Resume Next

With TTip
    Call .Create(Me)
    .DelayTime = 2000
   
    '.SetToolTipTitle "Dica inceptionApp:", 1
    ' ToolTip text colors
    ' .ForeColor = 16711165
    ' .BackColor = 4390912
   
    'tooltips form
    .SetToolText Me.imgCal, "Abra sua agenda sincronizada no Google!"
    .SetToolText Me.imgCalAdd, "Adicione um compromisso na sua agenda"

End With


End Sub
Private Sub Form_Load()


If Forms!weekplanner!frm_countAg![Count].Value > 0 Then
Call Main
Me.txtfoco.SetFocus

Else
If MsgBox("Não há nenhum evento na agenda a ser carregado. Crie um evento primeiro, para poder visualizar essa tela corretamente. Deseja criar um evento agora?", vbYesNo, "Nenhum evento cadastrado [inceptionApp]") = vbYes Then
DoCmd.Close acForm, "frmCal", acSaveYes
DoCmd.OpenForm "xAgenda", acNormal
DoCmd.GoToRecord , , acNewRec
Else
DoCmd.Close acForm, "frmCal", acSaveYes
MsgBox "Crie um evento antes de abrir essa agenda da próxima vez, ok?", vbOKOnly, "Ação necessária [inceptionApp]"
End If
End If

End Sub

Public Sub Main()
On Error GoTo ErrorHandler

Call InitVariables
Call InitArray
Call LoadArray
Call PrintArray

ExitSub:
    Exit Sub
ErrorHandler:
    MsgBox "erro no main"
    Resume ExitSub
End Sub

Private Sub InitVariables()
On Error GoTo ErrorHandler

intMonth = Month(txtData)
intYear = Year(txtData)
lngFirstDayOfMonth = CLng(DateSerial(intYear, intMonth, 1))
intFirstWeekday = getFirstWeekday(lngFirstDayOfMonth)
intDaysInMonth = getDaysInMonth(intMonth, intYear)

ExitSub:
    Exit Sub

ErrorHandler:
    MsgBox "erro no init var"
    Resume ExitSub
End Sub


Private Sub InitArray()
Dim i As Integer

ReDim myArray(0 To 7, 0 To 2)

For i = 0 To 7

    myArray(i, 0) = txtData + i
    If Month(myArray(i, 0)) = intMonth Then
        myArray(i, 1) = True
        myArray(i, 2) = Day(myArray(i, 0))
    Else
        myArray(i, 1) = False
   
    End If
Next i

End Sub

Private Sub LoadArray()

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFiltered As DAO.Recordset
Dim strSQL As String
Dim i As Integer

strSQL = "SELECT * from agenda order by agenda.[data dia]"
   
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
   
    If Not rs.BOF And Not rs.EOF Then
       
        For i = LBound(myArray) To UBound(myArray)
           
            If myArray(i, 1) Then
                rs.Filter = "[data dia]=" & myArray(i, 0)
               
                Set rsFiltered = rs.OpenRecordset
               
                Do While (Not rsFiltered.EOF)
                   
                    Dim concluir As String
                    If rsFiltered![Concluído] = True Then
                    concluir = "EVENTO REALIZADO"
                    Else
                    concluir = "EVENTO NÃO REALIZADO"
                    End If
                   
                    myArray(i, 2) = myArray(i, 2) & vbNewLine & vbNewLine _
                    & rsFiltered![Data Dia] & " - " _
                    & rsFiltered![Data Hora] & vbNewLine _
                    & rsFiltered![Evento] & vbNewLine _
                    & rsFiltered![ClienteNome] & " | " _
                    & rsFiltered![processo] & vbNewLine _
                    & rsFiltered![Detalhe] & vbNewLine _
                    & concluir & vbNewLine & vbNewLine
                   
                   
                    rsFiltered.MoveNext
                   
                Loop
           
            End If
        Next i
       
    End If
   
    rsFiltered.Close
    rs.Close

Set rsFiltered = Nothing
Set rs = Nothing
Set db = Nothing


End Sub

Private Sub PrintArray()
On Error GoTo ErrorHandler

Dim strCtlName As String
Dim i As Integer

For i = LBound(myArray) To UBound(myArray)
    strCtlName = "txt" & CStr(i + 1)
    Controls(strCtlName).Tag = i
    Controls(strCtlName) = ""
    Controls(strCtlName) = myArray(i, 2)
Next i

ExitSub:
    Exit Sub
ErrorHandler:
    MsgBox "erro no print"
    Resume ExitSub

End Sub

Private Sub OpenContinuousForm(ctlName As String)
On Error GoTo ErrorHandler

Dim ctlValue As Integer
Dim dayOfMonth As Long


ctlValue = Controls(ctlName).Tag
dayOfMonth = myArray(ctlValue, 0)

DoCmd.OpenForm "frmClassDataEntry", , , "[Data Dia]=" & dayOfMonth, acFormEdit

ExitSub:
    Exit Sub
ErrorHandler:
    MsgBox "erro no open cont"
    Resume ExitSub

End Sub

Private Sub AtualizaTitulos()



End Sub

Private Sub imgCal_Click()
Dim GC As Object
Dim WebUrl As String
Dim NavigatorAddress As String

    Let NavigatorAddress = "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe"
    Set GC = CreateObject("InternetExplorer.Application")
     
'''
Let WebUrl = "https://calendar.google.com/"
    Shell (NavigatorAddress & " -url " & WebUrl)


End Sub

Private Sub imgCalAdd_Click()
DoCmd.OpenForm "xAgenda", acNormal
DoCmd.GoToRecord , , acNewRec
End Sub

Private Sub txt1_Click()

If Me.ActiveControl.Text <> "" Then
    OpenContinuousForm Me.ActiveControl.Name
End If

End Sub

Private Sub txt2_Click()

If Me.ActiveControl.Text <> "" Then
    OpenContinuousForm Me.ActiveControl.Name
End If

End Sub

Private Sub txt3_Click()

If Me.ActiveControl.Text <> "" Then
    OpenContinuousForm Me.ActiveControl.Name
End If

End Sub




Private Sub txt4_Click()

If Me.ActiveControl.Text <> "" Then
    OpenContinuousForm Me.ActiveControl.Name
End If

End Sub

Private Sub txt5_Click()

If Me.ActiveControl.Text <> "" Then
    OpenContinuousForm Me.ActiveControl.Name
End If

End Sub

Private Sub txt6_Click()

If Me.ActiveControl.Text <> "" Then
    OpenContinuousForm Me.ActiveControl.Name
End If

End Sub

Private Sub txt7_Click()

If Me.ActiveControl.Text <> "" Then
    OpenContinuousForm Me.ActiveControl.Name
End If

End Sub



Private Sub txtData_AfterUpdate()
On Error GoTo ErrorHandler

Call Main

ExitSub:
    Exit Sub

ErrorHandler:
    MsgBox "There has been an error. Please reload the form"
    Resume ExitSub
End Sub


Oi Anna, bom dia

Como vc faz para colorir os eventos que estão a realizar e realizados?
Eu vi que vc colocou uma formação condicional mas colocou a expressão

Código:

contemRealiza([txt2])=Falso

, mas não localizei essa função.

Você tem o exemplo dela ai e poderia passar?

Gostei bastante da forma que ficou e gostaria de implementar no meu projeto.

Abs

bom dia a todos quero somente acompanhar o topico

acompanhando também