MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    [Resolvido]Criar calendário Semanal tipo Planner

    annissima
    annissima
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Feminino
    Localização : Brasil
    Mensagens : 146
    Registrado : 24/10/2017

    [Resolvido]Criar calendário Semanal tipo Planner Empty [Resolvido]Criar calendário Semanal tipo Planner

    Mensagem  annissima em 20/11/2020, 18:17

    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!
    Anexos
    [Resolvido]Criar calendário Semanal tipo Planner AttachmentPlanner.zip
    Você não tem permissão para fazer download dos arquivos anexados.
    (41 Kb) Baixado 12 vez(es)
    annissima
    annissima
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Feminino
    Localização : Brasil
    Mensagens : 146
    Registrado : 24/10/2017

    [Resolvido]Criar calendário Semanal tipo Planner Empty Re: [Resolvido]Criar calendário Semanal tipo Planner

    Mensagem  annissima em 21/11/2020, 15:32

    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

      Data/hora atual: 29/11/2020, 15:53