Site da Vetorial Treinamentos

Sistema Cadastro de Clientes

Sistema de agendamento de visitas com Excel VBA

Nesse projeto, iremos desenvolver um sistema de agendamento de visitas usando o Excel VBA contendo cadastro, alteração e exclusão tarefas. Trata-se de um sistema completo, e que poderá ser usado dentro de qualquer estabelecimento que trabalhe com agendamento de clientes, como: Clinicas Odontológicas, Barbearias, Centros de Estéticas, Salão de Beleza, Spa e muito mais.

A forma como os dados serão apresentadas nesse Sistema de Agendamento será de fácil leitura e interpretação. Todos os agendamentos do dia atual, serão apresentados dentro de um ListView destacado em tamanho maior, e os agendamentos ou tarefas dos próximos dias, serão apresentados em controles ListView menores. Todos em forma de tabela, contendo colunas que trazem as informações de cada agendamento, como cliente, horário, serviço e funcionário.

Para esse projeto, teremos como controle principal, novamente, o Controle ListView, então, sugiro que veja o Post ListView VBA – Uso e Aplicação do Controle ListView VBA e também o Post Criando um ListView Editável, que são base para o desenvolvimento desse Projeto.

Diferentemente dos projetos anteriores que desenvolvemos até aqui, que também tiveram como controle principal, o controle ListView, nessa aplicação, a alteração dos dados acontecerá graças a adição de controles criados em “Runtime”, que ficarão alinhados à direita do ListView. Conforme ilustração da imagem abaixo, teremos um botão de alteração e outro de exclusão para cada linha de subitens do ListView.

Tanto a criação dos controles em “Runtime” quanto a execução das ações de alterações e exclusões de tarefas, se darão com a utilização de Módulos de Classe. Além disso, os efeitos de Click(), MouseMove() e MouseDown() também serão realizados com a criação de Classes. O cadastro de novo agendamento é a única tarefa que será executada isoladamente, por meio de um formulário simples de cadastro. Todos os demais eventos, subs e functions, serão executados dentro do formulário de agendamento principal.

Sistema de Agendamento em Excel
Private Sub UserForm_Initialize()

Dim cor1    As Variant
Dim cor2    As Variant
Dim contl   As control
Dim f       As Integer

cor1 = RGB(21, 21, 21)
cor2 = RGB(7, 247, 138)
'-----------------------------------------------------------------------
With Me.ImageList1.ListImages

  .Add , "img1", LoadPicture(ThisWorkbook.Path & "\Imagens\horario.jpg")
  .Add , "img2", LoadPicture(ThisWorkbook.Path & "\Imagens\servico.jpg")
  .Add , "img3", LoadPicture(ThisWorkbook.Path & "\Imagens\cliente.jpg")
  .Add , "img4", LoadPicture(ThisWorkbook.Path & "\Imagens\prof.jpg")

End With

'-----------------------------------------------------------------------
For Each contl In Agenda.Controls
    If TypeName(contl) = "Frame" Then
        contl.BackColor = cor1
    End If
Next contl

'-----------------------------------------------------------------------
Set contl = Nothing

For f = 1 To 5
    Me.Controls("lvAgenda" & f).BackColor = cor1
Next

'-----------------------------------------------------------------------
lvAgenda.ForeColor = cor2
Label1.ForeColor = cor2
lblNomeDia.ForeColor = cor2
lvAgenda.BackColor = cor1

End Sub
Sub Datas()

Dim Data As Date
Dim cor1 As Variant
Dim cor2 As Variant
Dim cor3 As Variant
Dim cor4 As Variant

cor1 = &H80FF&    'RGB(7, 247, 138) '
cor2 = RGB(7, 247, 138)
cor3 = &HFFFF&
cor4 = rgbRed

Data = DataPsq.Value

D1.Caption = Format(Data + 1, "dd")
D2.Caption = Format(Data + 2, "dd")
D3.Caption = Format(Data + 3, "dd")
D4.Caption = Format(Data + 4, "dd")
D5.Caption = Format(Data + 5, "dd")

S1.Caption = Application.WorksheetFunction.Proper(Format(Data + 1, "dddd"))
S2.Caption = Application.WorksheetFunction.Proper(Format(Data + 2, "dddd"))
S3.Caption = Application.WorksheetFunction.Proper(Format(Data + 3, "dddd"))
S4.Caption = Application.WorksheetFunction.Proper(Format(Data + 4, "dddd"))
S5.Caption = Application.WorksheetFunction.Proper(Format(Data + 5, "dddd"))

lblNomeDia.Caption = Application.WorksheetFunction.Proper(Format(Data, "dddd"))
lblDiaSemana.Caption = Application.WorksheetFunction.Proper(Format(Data, "dd"))

If S1 = "Domingo" Then
    F1.BackColor = cor4
    S1.ForeColor = cor4
    D1.ForeColor = cor4
Else
    F1.BackColor = cor1
    S1.ForeColor = cor3
    D1.ForeColor = cor2
End If

If S2 = "Domingo" Then
    F2.BackColor = cor4
    S2.ForeColor = cor4
    D2.ForeColor = cor4
Else
    F2.BackColor = cor1
    S2.ForeColor = cor3
    D2.ForeColor = cor2
End If

If S3 = "Domingo" Then
    F3.BackColor = cor4
    S3.ForeColor = cor4
    D3.ForeColor = cor4
Else
    F3.BackColor = cor1
    S3.ForeColor = cor3
    D3.ForeColor = cor2
End If

If S4.Caption = "Domingo" Then
    F4.BackColor = cor4
    S4.ForeColor = cor4
    D4.ForeColor = cor4
Else
    F4.BackColor = cor1
    S4.ForeColor = cor3
    D4.ForeColor = cor2
End If

If S5 = "Domingo" Then
    F5.BackColor = cor4
    S5.ForeColor = cor4
    D5.ForeColor = cor4
Else
    F5.BackColor = cor1
    S5.ForeColor = cor3
    D5.ForeColor = cor2
End If

End Sub
Private Sub direito2_Click()

Dim Proximo     As Date
Dim Data        As Date

Data = DataPsq.Value

Proximo = Data + 1
DataPsq.Value = Proximo

lblNomeDia.Caption = Application.WorksheetFunction.Proper(Format(Proximo, "dddd"))
lblDiaSemana.Caption = Format(Proximo, "dd")

End Sub
Sub CarregarInicio()

Dim lvItem          As ListItem
Dim PAg             As Worksheet
Dim lin             As Long
Dim dtProcurada     As Date
Dim dtPlanilha      As Date

Set PAg = Planilha4

lin = 2
dtProcurada = DataPsq.Value

lvAgenda.ListItems.Clear
lvAgenda1.ListItems.Clear
lvAgenda2.ListItems.Clear
lvAgenda3.ListItems.Clear
lvAgenda4.ListItems.Clear
lvAgenda5.ListItems.Clear

PAg.Activate
PAg.Select
    
With PAg
    While .Cells(lin, 2).Value <> ""
    dtPlanilha = .Cells(lin, 2).Value
        
        '--------------------------------------------------------------Principal
        If dtPlanilha >= dtProcurada And dtPlanilha <= dtProcurada Then
            With lvAgenda
                .View = lvwReport
                .FullRowSelect = True
                .SmallIcons = ImageList1
'                .Gridlines = True
                .FullRowSelect = False
                With .ColumnHeaders
                        .Clear
                        .Add , , "Item", 0
                        .Add , , "Horário", 65, 2
                        .Add , , "Serviço", 170
                        .Add , , "Cliente", 170
                        .Add , , "Profissional", 170
                        .Add , , "Data", 0
                End With
            Set lvItem = lvAgenda.ListItems.Add(, , PAg.Cells(lin, "a").Value)
                With lvItem.ListSubItems
                        .Add , , Format(PAg.Cells(lin, "c").Value, "h:mm"), 1
                        .Add , , PAg.Cells(lin, "d").Value, 2
                        .Add , , PAg.Cells(lin, "e").Value, 3
                        .Add , , PAg.Cells(lin, "f").Value, 4
                        .Add , , PAg.Cells(lin, "b").Value, 4
                End With
            End With
        End If
        
     '-----------------------------------------------------------------1
        If dtPlanilha >= dtProcurada + 1 And dtPlanilha <= dtProcurada + 1 Then
            With lvAgenda1
                '.Gridlines = True
                .View = lvwReport
                .FullRowSelect = True
                With .ColumnHeaders
                        .Clear
                        .Add , , "Item", 0
                        .Add , , "Horário", 36, 2
                        .Add , , "Serviço", 82
                        .Add , , "Cliente", 82
                        .Add , , "Profissional", 82
                End With
            Set lvItem = lvAgenda1.ListItems.Add(, , PAg.Cells(lin, "a").Value)
                With lvItem.ListSubItems
                        .Add , , Format(PAg.Cells(lin, "c").Value, "h:mm")
                        .Add , , PAg.Cells(lin, "d").Value
                        .Add , , PAg.Cells(lin, "e").Value
                        .Add , , PAg.Cells(lin, "f").Value

                End With
            End With
        End If
    '-----------------------------------------------------------------2
        If dtPlanilha >= dtProcurada + 2 And dtPlanilha <= dtProcurada + 2 Then
            With lvAgenda2
                '.Gridlines = True
                .View = lvwReport
                .FullRowSelect = True
                With .ColumnHeaders
                        .Clear
                        .Add , , "Item", 0
                        .Add , , "Horário", 36, 2
                        .Add , , "Serviço", 82
                        .Add , , "Cliente", 82
                        .Add , , "Profissional", 82
                End With
            Set lvItem = lvAgenda2.ListItems.Add(, , PAg.Cells(lin, "a").Value)
                With lvItem.ListSubItems
                        .Add , , Format(PAg.Cells(lin, "c").Value, "h:mm")
                        .Add , , PAg.Cells(lin, "d").Value
                        .Add , , PAg.Cells(lin, "e").Value
                        .Add , , PAg.Cells(lin, "f").Value
                End With
            End With
        End If
    '-----------------------------------------------------------------3
        If dtPlanilha >= dtProcurada + 3 And dtPlanilha <= dtProcurada + 3 Then
            With lvAgenda3
                '.Gridlines = True
                .View = lvwReport
                .FullRowSelect = True
                With .ColumnHeaders
                        .Clear
                        .Add , , "Item", 0
                        .Add , , "Horário", 36, 2
                        .Add , , "Serviço", 82
                        .Add , , "Cliente", 82
                        .Add , , "Profissional", 82
                End With
            Set lvItem = lvAgenda3.ListItems.Add(, , PAg.Cells(lin, "a").Value)
                With lvItem.ListSubItems
                        .Add , , Format(PAg.Cells(lin, "c").Value, "h:mm")
                        .Add , , PAg.Cells(lin, "d").Value
                        .Add , , PAg.Cells(lin, "e").Value
                        .Add , , PAg.Cells(lin, "f").Value
                End With
            End With
        End If
    '-----------------------------------------------------------------4
        If dtPlanilha >= dtProcurada + 4 And dtPlanilha <= dtProcurada + 4 Then
            With lvAgenda4
                '.Gridlines = True
                .View = lvwReport
                .FullRowSelect = True
                With .ColumnHeaders
                        .Clear
                        .Add , , "Item", 0
                        .Add , , "Horário", 36, 2
                        .Add , , "Serviço", 82
                        .Add , , "Cliente", 82
                        .Add , , "Profissional", 82
                End With
            Set lvItem = lvAgenda4.ListItems.Add(, , PAg.Cells(lin, "a").Value)
                With lvItem.ListSubItems
                        .Add , , Format(PAg.Cells(lin, "c").Value, "h:mm")
                        .Add , , PAg.Cells(lin, "d").Value
                        .Add , , PAg.Cells(lin, "e").Value
                        .Add , , PAg.Cells(lin, "f").Value
                End With
            End With
        End If
    '-----------------------------------------------------------------5
        If dtPlanilha >= dtProcurada + 5 And dtPlanilha <= dtProcurada + 5 Then
            With lvAgenda5
                .View = lvwReport
                .FullRowSelect = True
                With .ColumnHeaders
                        .Clear
                        .Add , , "Item", 0
                        .Add , , "Horário", 36, 2
                        .Add , , "Serviço", 82
                        .Add , , "Cliente", 82
                        .Add , , "Profissional", 82
                End With
            Set lvItem = lvAgenda5.ListItems.Add(, , PAg.Cells(lin, "a").Value)
                With lvItem.ListSubItems
                        .Add , , Format(PAg.Cells(lin, "c").Value, "h:mm")
                        .Add , , PAg.Cells(lin, "d").Value
                        .Add , , PAg.Cells(lin, "e").Value
                        .Add , , PAg.Cells(lin, "f").Value
                End With
            End With
        End If
    '-----------------------------------------------------------------
    lin = lin + 1
    Wend
End With
        
End Sub
Sub Transforma()

Dim ultItem     As Integer
Dim i           As Integer
Dim novLbl      As MSForms.control
Dim novLb2      As MSForms.control
Dim imag        As String
Dim wkb         As Workbook
Dim ObjetoBt    As Object
Dim BtSelec     As Long

ultItem = lvAgenda.ColumnHeaders.Count

imag = ThisWorkbook.Path & "\Imagens\editar.jpg"

For i = 1 To lvAgenda.ListItems.Count
    
    Set novLbl = Agenda.FrameMae.Add("Forms.Label.1")
    With novLbl
        .Name = "lbEdit" & Format(i, "00")
        .Left = lvAgenda.ColumnHeaders(ultItem).Left + lvAgenda.Left + 2
        .Top = lvAgenda.ListItems(i).Top + lvAgenda.Top
        .Height = lvAgenda.ListItems(i).Height
        .Width = 25
        .BackColor = RGB(21, 21, 21)
        .Caption = ""
        .BorderStyle = 0
        .Picture = LoadPicture(imag)
        .PicturePosition = 7
        .ControlTipText = "Editar"
    End With

Next i

imag = ThisWorkbook.Path & "\Imagens\excluir.jpg"

For i = 1 To lvAgenda.ListItems.Count
    
    Set novLb2 = Agenda.FrameMae.Add("Forms.Label.1")
    With novLb2
        .Name = "lbExcl" & Format(i, "00")
        .Left = lvAgenda.ColumnHeaders(ultItem).Left + lvAgenda.Left + 25
        .Top = lvAgenda.ListItems(i).Top + lvAgenda.Top
        .Height = lvAgenda.ListItems(i).Height
        .Width = 25
        .BackColor = RGB(21, 21, 21)
        .Caption = ""
        .BorderStyle = 0
        .Picture = LoadPicture(imag)
        .PicturePosition = 7
        .ControlTipText = "Excluir"
    End With

Next i

End Sub
Sub limpaTudo()

Dim corf As control

For Each corf In Agenda.Controls
    If TypeName(corf) = "Label" And Left(corf.Name, 6) = "lbEdit" Then
        Me.Controls.Remove corf.Name
    End If
Next corf

Set corf = Nothing

For Each corf In Agenda.Controls
    If TypeName(corf) = "Label" And Left(corf.Name, 6) = "lbExcl" Then
        Me.Controls.Remove corf.Name
    End If
Next corf
Set corf = Nothing

End Sub
Option Explicit

Public WithEvents aplicamod As MSForms.Label

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

Dim img1    As String
Dim img2    As String
Dim wkb     As Workbook

img1 = ThisWorkbook.Path & "\Imagens\editarfoco.jpg"
img2 = ThisWorkbook.Path & "\Imagens\excluirfoco.jpg"

If Left(aplicamod.Name, 6) = "lbEdit" Then
    aplicamod.Picture = LoadPicture(img1)
End If

If Left(aplicamod.Name, 6) = "lbExcl" Then
    aplicamod.Picture = LoadPicture(img2)
End If

End Sub

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

If Left(aplicamod.Name, 6) = "lbEdit" Then
    aplicamod.SpecialEffect = fmSpecialEffectSunken
End If

If Left(aplicamod.Name, 6) = "lbExcl" Then
    aplicamod.SpecialEffect = fmSpecialEffectSunken
End If

End Sub
Option Explicit

Function TiraEfeitos()

    Dim contForm As control
    Dim img1    As String
    Dim img2    As String
    Dim wkb     As Workbook
    
    img1 = ThisWorkbook.Path & "\Imagens\editar.jpg"
    img2 = ThisWorkbook.Path & "\Imagens\excluir.jpg"

    For Each contForm In Agenda.Controls
        If TypeName(contForm) = "Label" And Left(contForm.Name, 6) = "lbEdit" Then
            contForm.SpecialEffect = 0
            contForm.Picture = LoadPicture(img1)
        ElseIf TypeName(contForm) = "Label" And Left(contForm.Name, 6) = "lbExcl" Then
            contForm.SpecialEffect = 0
            contForm.Picture = LoadPicture(img2)
        End If
    Next contForm
    Set contForm = Nothing
End Function
Dim BtAtual() As ClasseEfeito

ReDim BtAtual(1 To Me.Controls.Count)

For Each ObjetoBt In Me.Controls
If TypeName(ObjetoBt) = "Label" Then
    BtSelec = BtSelec + 1
    Set BtAtual(BtSelec) = New ClasseEfeito
    Set BtAtual(BtSelec).aplicamod = ObjetoBt
End If

Next ObjetoBt
Set ObjetoBt = Nothing

ReDim Preserve BtAtual(1 To BtSelec)
Private Sub aplicamod_Click()

Dim X           As Integer
Dim Y           As Integer
Dim linLv       As Integer
Dim lvAg        As ListView
Dim imag        As String
Dim wkb         As Workbook
Dim ObjetoBt    As Object
Dim BtSelec     As Long
'--------------------------
Dim cod         As Long
Dim wPlan       As Worksheet
Dim R           As Range
Dim lvLin       As Integer

imag = ThisWorkbook.Path & "\Imagens\salvar.jpg"

If Left(aplicamod.Name, 6) = "lbEdit" Then

Y = Format(Right(aplicamod.Name, 2), "0")

linLv = Format(Y, "0")

    X = 1
    
    Set lvAg = Agenda.lvAgenda
    
    Agenda.linhaTxt.Value = lvAg.ListItems(linLv)
    Agenda.linhaLv.Value = linLv
    
    For X = 1 To 4
    
        With Agenda.Controls("Frame" & X)
            
            .Visible = True
            .Top = lvAg.ListItems(Y).Top + lvAg.Top
            .Left = lvAg.ColumnHeaders(X + 1).Left + lvAg.ListItems(Y).Left
            .Width = lvAg.ColumnHeaders(X + 1).Width
            .Height = lvAg.ListItems(Y).Height
            
            .ZOrder msoBringToFront
            
        End With
        
        With Agenda.Controls("ComboBox" & X)
            
            .Visible = True
            .Text = lvAg.ListItems(Y).ListSubItems(X).Text
            .Top = 0
            .Left = 0
            .Width = lvAg.ColumnHeaders(X + 1).Width
            .Height = lvAg.ListItems(Y).Height
            .SelLength = Len(.Text)
            
        End With
        
    Next X
    
ElseIf Left(aplicamod.Name, 6) = "lbExcl" Then

    Set wPlan = Planilha4
    Set lvAg = Agenda.lvAgenda
    
    lvLin = Format(Right(aplicamod.Name, 2), "0")

    cod = lvAg.ListItems(lvLin).Text

    wPlan.Activate
    wPlan.Select
    
    '------------------------------------------------------------------------------------------------
    With wPlan.Range("A:A")
        Set R = .Find(cod, LookIn:=xlValues, LookAt:=xlWhole)
            If Not R Is Nothing Then
                R.Select
                Selection.EntireRow.Delete
            Else
            End If
    End With
    
    Set wPlan = Nothing

End If

End Sub
Sub EditaDados()
    
Dim lin         As Integer
Dim col         As Integer
Dim vLinTxt     As Integer
Dim vLinLv      As Integer
Dim nValor      As String
Dim cod         As Long
Dim wPlan       As Worksheet
Dim R           As Range

If linhaTxt.Value <> "" Then

    Set wPlan = Planilha4
    
    vLinTxt = linhaTxt.Value
    vLinLv = linhaLv.Value
    col = 1
    
    lvAgenda.ListItems(vLinLv).SubItems(1) = ComboBox1.Value
    lvAgenda.ListItems(vLinLv).SubItems(col + 1) = ComboBox2.Value
    lvAgenda.ListItems(vLinLv).SubItems(col + 2) = ComboBox3.Value
    lvAgenda.ListItems(vLinLv).SubItems(col + 3) = ComboBox4.Value
    
    wPlan.Activate
    wPlan.Select
    
    '------------------------------------------------------------------------------------------------
    With wPlan.Range("A:A")
        Set R = .Find(vLinTxt, LookIn:=xlValues, LookAt:=xlWhole)
            If Not R Is Nothing Then
                R.Select
                R.Offset(0, 2).Value = ComboBox1.Value
                R.Offset(0, 3).Value = ComboBox2.Value
                R.Offset(0, 4).Value = ComboBox3.Value
                R.Offset(0, 5).Value = ComboBox4.Value
    
            Else
            End If
    End With
    
    Set wPlan = Nothing
End If

End Sub

5 thoughts on “Sistema de agendamento de visitas com Excel VBA”

  1. Gostaria de saber para vc colocar para mim este agendamento sem essas cores e eu conseguir usar somente ele qual seria o valor pois não estou conseguindo colocar dentro do meu formulario

Leave a Comment

O seu endereço de email não será publicado. Campos obrigatórios marcados com *