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.
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
Gostaria de obter a planilha
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
Olá, pretendo adquirir o curso, obrigado!!!
Oi Rodrigo, você pode entrar em contato pelo WhatsApp: https://api.whatsapp.com/send?phone=5591984578188
Fico Muito Grato por Este Projetos Seus