CONTROLE CALENDAR

' No User Control
' (F) GetWDay(d,c)
'   Retorna uma seqà¼ência de caracteres de acordo com a data insirida.
'   Onde d é obrigatório e representa um número inteiro de 1 à  7 obtido
'   pela função Weekday. E c é um opcional que diz qual o tamanho máximo
'   dessa seqà¼ência a ser retornada.
' (F) GetMLen(m,y)
'   Retorna o número de dias no mês.
'   Onde m representa os mesese de 1 à  12 obtidos por Month(), Obrigatório.
'   E y que equivale ao ano, também obrigatório, serve para definir se o ano
'   é ou não bissexto para que seja possível retornar a qtd certa de dias no mês
'   de Fevereiro.
' (F) GetMName(m)
'   Retorna o nome dos meses de acordo com seus números.
'   Onde m é uma varável de 1 à  12 representando os meses, Obrigatório.
' (F) GetMNum(m)
'   Função inversa da anterior, essa retorna o número equivalente aos meses pela
'   variável OBRIGATÓ“RIA m onde se encontra o nome dos meses por extenso e com a 1Âê
'   letra do nome em maiúscula.
' (F) DrawCal()
'   Função mestra, serve para formar o calendário expondo os dias nas casas certas
'   usando Day(MyDate), Month(MyDate), Year(MyDate), Weekday(MyFDay) a as datas no
'   formato "1/" & MyMonth & "/" & MyYear.
'   para conseguir saber qual foi o dia da semana que iniciou o mês usei a seguinte síntese:
'   Weekday("1/" & MyMonth & "/" & MyYear), isso para retornar o número de 1 à  7 do 1º dia do mês.
'   Maiores informações verificar o escopo da função.

Function GetWDay(ByVal d As Integer, Optional ByRef c As String) As String
Dim s
Select Case d
    Case 1
        s = "Domingo"
    Case 2
        s = "Segunda"
    Case 3
        s = "Terça"
    Case 4
        s = "Quarta"
    Case 5
        s = "Quinta"
    Case 6
        s = "Sexta"
    Case 7
        s = "Sábado"
End Select
If c = "s*" Then
    GetWDay = Left(s, Len(s))
ElseIf c = "sss" Then
    GetWDay = Left(s, 3)
ElseIf c = "ss" Then
    GetWDay = Left(s, 2)
ElseIf c = "s" Then
    GetWDay = Left(s, 1)
Else
    GetWDay = Left(s, Len(s))
End If
End Function

Function GetMLen(ByVal m As Integer, ByVal Y As Integer)
Select Case m
    Case 1
        GetMLen = 31
    Case 2
        'GetMLen = ""
        If (Y Mod 4) = 0 Then: GetMLen = 29: Else: GetMLen = 28
    Case 3
        GetMLen = 31
    Case 4
        GetMLen = 30
    Case 5
        GetMLen = 31
    Case 6
        GetMLen = 30
    Case 7
        GetMLen = 31
    Case 8
        GetMLen = 31
    Case 9
        GetMLen = 30
    Case 10
        GetMLen = 31
    Case 11
        GetMLen = 30
    Case 12
        GetMLen = 31
End Select
End Function

Function GetMName(ByVal m As Integer)
Select Case m
    Case 1
        GetMName = "Janeiro"
    Case 2
        GetMName = "Fevereiro"
    Case 3
        GetMName = "Março"
    Case 4
        GetMName = "Abril"
    Case 5
        GetMName = "Maio"
    Case 6
        GetMName = "Junho"
    Case 7
        GetMName = "Julho"
    Case 8
        GetMName = "Agosto"
    Case 9
        GetMName = "Setembro"
    Case 10
        GetMName = "Outubro"
    Case 11
        GetMName = "Novembro"
    Case 12
        GetMName = "Dezembro"
End Select
End Function

Function GetMNum(ByVal m As String) As Integer
Select Case m
    Case "Janeiro"
        GetMNum = 1
    Case "Fevereiro"
        GetMNum = 2
    Case "Março"
        GetMNum = 3
    Case "Abril"
        GetMNum = 4
    Case "Maio"
        GetMNum = 5
    Case "Junho"
        GetMNum = 6
    Case "Julho"
        GetMNum = 7
    Case "Agosto"
        GetMNum = 8
    Case "Setembro"
        GetMNum = 9
    Case "Outubro"
        GetMNum = 10
    Case "Novembro"
        GetMNum = 11
    Case "Dezembro"
        GetMNum = 12
End Select
End Function

Function DrawCal()
Dim MyFDay
MyDay = Day(MyDate) ' alocando na variável MyDay o dia da data MyDate Ex: (31)/1/2003
MyMonth = Month(MyDate) ' alocando na variável MyMonth o mes da data MyDate Ex: 31/(1)/2003
MyYear = Year(MyDate) ' alocando na variável MyYear o ano da data MyDate Ex: 31/1/(2003)
MyFDay = "1/" & MyMonth & "/" & MyYear 'Formando uma nova data usando os valores das variáveis MyMonth e MyYear para descobrir o 1º dia do mês e o aloca na variável local MyFDay
MyWeekDay = Weekday(MyFDay) ' alocando na variável MyWeekDay o valor retornado da variável MyFDay que diz em que semana o mês começou.

'lblValor.Caption = MyDate ' Colocando o valor do calendário no rótulo certo.
cmbMês.Text = GetMName(MyMonth) ' Selecionando o mês atual do cal. no combobox.
cmbAno.Text = MyYear ' Selecionando o ano atual do cal. no combobox.

Dim i As Integer ' declarando a variável local i que é inteira.
For i = 0 To picDias.Count - 1 ' Informando as condições para o loop for.
If i = (MyWeekDay - 1) Then ' Insturi ao loop for a só começar a colocar os dias quando ele estiver na posição certa na semana. Ex: sábado, 1/3/2003 só vai ser posto o nº 1 quando o loop estiver com i em 7
If i = GetMLen(MyMonth, MyYear) + (MyWeekDay - 2) Then ' Instrui ao loop a parar de adicionar os números quando o mês estiver acabado. Ex: segunda, 31/3/2003 quando o loop chegar à  38 (já que 1/3/2003 caiu
'num sábado, e 38-7 é igual a 31 o máximo de dias em Março.)
picDias(i).Tag = (i + 1) - (MyWeekDay - 1) 'Imprime na tag do picture box o dia certo.
Else
'lblDias(i).Caption = "-" 'Imprime no calendário um hífen aonde não se tem dias.
picDias(i).Tag = "-"
End If
Else
'lblDias(i).Caption = "-" 'Imprime no calendário um hífen aonde não se tem dias.
picDias(i).Tag = "-"
End If

PaintButtons i

'Verifica se o caption do lblDias atual é o que contem o dia a ser marcado.
If picDias(i).Tag = MyDay Then
'marca o picDias se for verdadeiro.
lblDias_Click i
'SelectButtons i
End If
Next i 'indica que o loop atingiu o fim.
RaiseEvent DataModificada
End Function

Private Sub ReFreshButtons()
Dim cmdBtn As cmProps
Dim i As Integer
For i = 0 To picDias.Count - 1
picDias(i).AutoRedraw = True
picDias(i).ScaleMode = 3
picDias(i).BorderStyle = 0
picDias(i).BackColor = vbButtonFace
picDias(i).Cls
'-1 button up, 0 button down and 1 to flat button
If m_Aparencia = [3D] Then
    m_Status = cmdOutSet
Else
    m_Status = cmdFlat
End If
If m_Status = cmdInSet Then m_Status = cmdOutSet
cmdBtn.cmdState = m_Status
cmdBtn.cmdBevel = 1
cmdBtn.cmdFont.ftName = "Arial"
cmdBtn.cmdFont.ftSize = 8.25
cmdBtn.cmdFont.ftBold = bolditalic
cmdBtn.cmdFont.ftItalic = bolditalic
cmdBtn.cmdFont.ftUnderline = False
cmdBtn.cmdFont.ftColor = vbButtonText
cmdBtn.cmdText = picDias(i).Tag
cmdBtn.cmdVAlign = cmdVCenter
cmdBtn.cmdHAlign = cmdHCenter
cmdBtn.cmdMultiline = False
cmdBtn.cmdFocus = focus
DrawCmdBtn cmdBtn, picDias(i)
Next
End Sub

Private Sub SelectButtons(index As Integer)
Dim cmdBtn As cmProps
picDias(index).AutoRedraw = True
picDias(index).ScaleMode = 3
picDias(index).BorderStyle = 0
picDias(index).BackColor = vb3DShadow
'-1 button up, 0 button down and 1 to flat button
If m_Aparencia = [3D] Then
    cmdBtn.cmdState = cmdInSet
    m_Status = cmdInSet
Else
    cmdBtn.cmdState = cmdFlat
    m_Status = cmdFlat
End If
cmdBtn.cmdBevel = 1
cmdBtn.cmdFont.ftName = "Arial"
cmdBtn.cmdFont.ftSize = 8.25
cmdBtn.cmdFont.ftBold = bolditalic
cmdBtn.cmdFont.ftItalic = bolditalic
cmdBtn.cmdFont.ftUnderline = False
cmdBtn.cmdFont.ftColor = vb3DHighlight
cmdBtn.cmdText = picDias(index).Tag
cmdBtn.cmdVAlign = cmdVCenter
cmdBtn.cmdHAlign = cmdHCenter
cmdBtn.cmdMultiline = False
cmdBtn.cmdFocus = True
DrawCmdBtn cmdBtn, picDias(index)
End Sub

Private Sub PaintButtons(index As Integer)
Dim cmdBtn As cmProps
picDias(index).AutoRedraw = True
picDias(index).ScaleMode = 3
picDias(index).BorderStyle = 0
picDias(index).BackColor = vbButtonFace
'-1 button up, 0 button down and 1 to flat button
If m_Aparencia = [3D] Then
    m_Status = cmdOutSet
Else
    m_Status = cmdFlat
End If
If m_Status = cmdInSet Then m_Status = cmdOutSet
cmdBtn.cmdState = m_Status
cmdBtn.cmdBevel = 1
cmdBtn.cmdFont.ftName = "Arial"
cmdBtn.cmdFont.ftSize = 8.25
cmdBtn.cmdFont.ftBold = bolditalic
cmdBtn.cmdFont.ftItalic = bolditalic
cmdBtn.cmdFont.ftUnderline = False
cmdBtn.cmdFont.ftColor = vbButtonText
cmdBtn.cmdText = picDias(index).Tag
cmdBtn.cmdVAlign = cmdVCenter
cmdBtn.cmdHAlign = cmdHCenter
cmdBtn.cmdMultiline = False
cmdBtn.cmdFocus = False
DrawCmdBtn cmdBtn, picDias(index)
End Sub

'No Módulo:

Option Explicit

'Estrutura de tipos de Fontes
Type ftType
  ftName As String
  ftSize As Integer
  ftBold As Boolean
  ftItalic As Boolean
  ftUnderline As Boolean
  ftColor  As OLE_COLOR
End Type

'Estrutura de tipo do "Botão", sendo que não precisa ser necessáriamente ser um.
Type cmProps
    cmdState As cmdState
    cmdBevel As Integer
    cmdFont As ftType
    cmdText As String
    cmdVAlign As cmdVAlign
    cmdHAlign As cmdHAlign
    cmdMultiline As Boolean
    cmdFocus As Boolean
End Type
'Estrutura de Alinhamento
Enum cmdHAlign
    cmdHLeft = -1
    cmdHCenter = 0
    cmdHRight = 1
End Enum
Enum cmdVAlign
    cmdVTop = -1
    cmdVCenter = 0
    cmdVBotton = 1
End Enum
'Estrutura de Estado da Imagem a ser Gerada.
Enum cmdState
    cmdOutSet = -1
    cmdInSet = 0
    cmdFlat = 1
End Enum

Sub DrawBtnTxt(inPct As PictureBox, lbLeft, lbTop, lbRight, lbBottom, lbText, lbHorzAlign, txVertAlign, inMultiLine)

'Called from within this module to draw text on picturebox and align accordingly
'within area passed in.  The vertical alignment of the text is a percent of
'distance from the top of the area - pass in one of these - 0 = top,
'.5 = middle, 1 = bottom.

'The Multi-Line will split on words that have a space between them as well
'   as split up long words.  If the word is to long to fit horizontal on the
'   button it will be split between two or more lines.  It also implements
'   a char by char compare instead of using instr for the word break so that
'   individual chars can be filtered out and acted upon specifically
'   i.e. as with the CRLFChr.  The CRLFChr "~" acts as an immediate break
'   at the word and starts the new text on the next line.
'   This can be modified for the '&' character as well.
   
   Dim inBegin As Integer      'Beginning position
   Dim inEnd As Integer        'Ending position
   Dim inBreak As Integer      'Where to break the line
   Dim inTextLen As Integer    'Length of text to be output
   Dim inPctTOLen As Integer   'Text Output Length
   Dim strText As String       'Work String
   Dim txChar As String        'Character working with
   Dim inElement As Integer    'Element working with
   Dim arText()  As String     'Array of text
   Dim inTextHeight As Integer 'Height of all text lines
   Dim lbVertAlign As Single   'Vertical Alignment of Text
   Const CRLFChr = "~"         'Character to act as CRLF

   'Set the vertical alignment - Default is "center"
   If txVertAlign = -1 Then
      lbVertAlign = 0
   ElseIf LCase(txVertAlign) = 1 Then
      lbVertAlign = 1
   Else
      lbVertAlign = 0.5
   End If

   inPctTOLen = lbRight - lbLeft  'Text Output Length
   inTextLen = inPct.TextWidth(lbText) 'Length of text

   'This checks to see if the line needs to be split
   '   Always split if it is a multi-line
   If inMultiLine Or ((inTextLen  inPctTOLen) And inMultiLine) Then
      inBegin = 1        'Begin with first position
      inElement = 1      'We know we have at least 1 element

      For inEnd = 1 To Len(lbText) + 1  'Look at all chrs
         txChar = Mid$(lbText, inEnd, 1)
         If txChar = " " Then
            inBreak = inEnd    'Keep Break on a space position
         End If

         'This is where the check for CRLFChr is
         If (inPct.TextWidth(strText) + inPct.TextWidth(txChar))  inPctTOLen And txChar  "" And txChar  CRLFChr Then
            strText = strText & txChar
         Else
           
            ReDim Preserve arText(inElement)
            If txChar = "" Then  'End of text
               inBreak = inEnd
            End If
            If txChar = CRLFChr Then  'CRLF character
               inBreak = inEnd
            End If
            If inBreak = 0 Then  'Break on words
               inBreak = inEnd - 1
               arText(inElement) = Mid$(strText, 1, inEnd - inBegin)
            Else
               arText(inElement) = Mid$(strText, 1, inBreak - inBegin)
            End If
            
            'Text height of each line for centering
            inTextHeight = inTextHeight + inPct.TextHeight(arText(inElement))

            'End of Text ?
            If txChar  "" Then
               strText = ""
               inBegin = inBreak + 1
               inEnd = inBreak
               inBreak = 0
               inElement = inElement + 1
            End If
         End If
         
      Next
      
   Else
      'We still need to move the text to be processed
      ReDim arText(1)   'There is only 1 element
      arText(1) = lbText 'Move the text in
      inTextHeight = inPct.TextHeight(arText(1)) 'Get the heigth of text
   End If
   
   'Calculate the Y position
   inPct.CurrentY = lbTop + (((lbBottom - lbTop) * lbVertAlign) - (inTextHeight * lbVertAlign))
   
   'Don't let it go over the top
   If inPct.CurrentY  lbTop Then
      inPct.CurrentY = lbTop
   End If
   
   For inElement = 1 To UBound(arText) 'Loop thru all element strings

      Select Case lbHorzAlign
         Case -1
            inPct.CurrentX = lbLeft
   
         Case 1
            inPct.CurrentX = lbRight - inPct.TextWidth(arText(inElement))
   
         Case 0
            inPct.CurrentX = lbLeft + (((lbRight - lbLeft) / 2) - (inPct.TextWidth(arText(inElement)) / 2))
         Case Else  'Default "center"
            inPct.CurrentX = lbLeft + (((lbRight - lbLeft) / 2) - (inPct.TextWidth(arText(inElement)) / 2))
      End Select
    
      inPct.Print arText(inElement)
   Next

   ReDim arText(0)
End Sub

Sub DrawCmdBtn(inCmd As cmProps, inPct As PictureBox)
 
'Called each time the button changes focus or up/down

    Dim X%, Y%

    inPct.Cls                  'Used to clear text (not need if not using picture)
    Select Case inCmd.cmdFocus 'Draw button according to focus state
       Case True
          inPct.FillStyle = 1
          inPct.Line (0, 0)-(inPct.ScaleWidth - 1, inPct.ScaleHeight - 1), 0, B
          'Focus rectangle in these two loops
          For X = inCmd.cmdBevel + 4 To inPct.ScaleWidth - inCmd.cmdBevel - 4 Step 2
             inPct.PSet (X, inCmd.cmdBevel + 3), vbHighlightText
             inPct.PSet (X, inPct.ScaleHeight - inCmd.cmdBevel - 4), vbHighlightText
          Next
          For Y = inCmd.cmdBevel + 4 To inPct.ScaleHeight - inCmd.cmdBevel - 4 Step 2
             inPct.PSet (inCmd.cmdBevel + 3, Y), vbHighlightText
             inPct.PSet (inPct.ScaleWidth - inCmd.cmdBevel - 4, Y), vbHighlightText
          Next
       Case False
          inPct.Line (0, inPct.ScaleHeight - 1)-(inPct.ScaleWidth, inPct.ScaleHeight - 1), vb3DDKShadow
          inPct.Line (inPct.ScaleWidth - 1, 0)-(inPct.ScaleWidth - 1, inPct.ScaleHeight), vb3DDKShadow
    End Select
    
    SetFonts inCmd.cmdFont, inPct 'Prepare font settings
    
    Select Case inCmd.cmdState
      Case -1                     'Button up - outset
         For X = 0 To inCmd.cmdBevel - 1
           inPct.Line (1 + X, inPct.ScaleHeight - 2 - X)-(inPct.ScaleWidth - 2 - X + 1, inPct.ScaleHeight - 2 - X), vb3DShadow ' RGB(92, 92, 92)
           inPct.Line (1 + X, 1 + X)-(inPct.ScaleWidth - 2 - X + 1, 1 + X), vb3DHighlight ' RGB(255, 255, 255)
           inPct.Line (inPct.ScaleWidth - 2 - X, 1 + X)-(inPct.ScaleWidth - 2 - X, inPct.ScaleHeight - 2 - X), vb3DShadow ' RGB(92, 92, 92)
           inPct.Line (1 + X, 1 + X)-(1 + X, inPct.ScaleHeight - 2 - X), vb3DHighlight ' RGB(255, 255, 255)
         Next
         DrawBtnTxt inPct, inCmd.cmdBevel + 3, inCmd.cmdBevel + 1, inPct.ScaleWidth - inCmd.cmdBevel - 3, inPct.ScaleHeight - inCmd.cmdBevel - 3, inCmd.cmdText, inCmd.cmdHAlign, inCmd.cmdVAlign, inCmd.cmdMultiline
      Case 0                      'Button down - inset
         For X = 0 To inCmd.cmdBevel - 1
           inPct.Line (1 + X, inPct.ScaleHeight - 2 - X)-(inPct.ScaleWidth - 2 - X + 1, inPct.ScaleHeight - 2 - X), vb3DHighlight ' RGB(92, 92, 92)
           inPct.Line (1 + X, 1 + X)-(inPct.ScaleWidth - 2 - X + 1, 1 + X), vb3DDKShadow ' RGB(255, 255, 255)
           inPct.Line (inPct.ScaleWidth - 2 - X, 1 + X)-(inPct.ScaleWidth - 2 - X, inPct.ScaleHeight - 2 - X), vb3DHighlight ' RGB(92, 92, 92)
           inPct.Line (1 + X, 1 + X)-(1 + X, inPct.ScaleHeight - 2 - X), vb3DDKShadow ' RGB(255, 255, 255)
         Next
         'MsgBox inCmd.cmdText
         DrawBtnTxt inPct, inCmd.cmdBevel + 4, inCmd.cmdBevel + 5, inPct.ScaleWidth - inCmd.cmdBevel - 1, inPct.ScaleHeight - inCmd.cmdBevel - 2, inCmd.cmdText, inCmd.cmdHAlign, inCmd.cmdVAlign, inCmd.cmdMultiline
      Case 1                      'Button flat
         'isert flat cod.
         'inPct.Line (0, inPct.ScaleHeight - 0)-(inPct.ScaleWidth, inPct.ScaleHeight - 0), vb3DDKShadow
         'inPct.Line (inPct.ScaleWidth - 0, 0)-(inPct.ScaleWidth - 0, inPct.ScaleHeight), vb3DDKShadow
         inPct.Line (0 + X, inPct.ScaleHeight - 1 - X)-(inPct.ScaleWidth - 1 - X + 0, inPct.ScaleHeight - 1 - X), vb3DDKShadow ' RGB(92, 92, 92)
         inPct.Line (0 + X, 0 + X)-(inPct.ScaleWidth - 1 - X + 1, 0 + X), vb3DDKShadow ' RGB(255, 255, 255)
         inPct.Line (inPct.ScaleWidth - 1 - X, 1 + X)-(inPct.ScaleWidth - 1 - X, inPct.ScaleHeight - 1 - X), vb3DDKShadow ' RGB(92, 92, 92)
         inPct.Line (0 + X, 0 + X)-(0 + X, inPct.ScaleHeight - 1 - X), vb3DDKShadow ' RGB(255, 255, 255)
         DrawBtnTxt inPct, 0, 0, inPct.ScaleWidth, inPct.ScaleHeight, inCmd.cmdText, inCmd.cmdHAlign, inCmd.cmdVAlign, inCmd.cmdMultiline
    End Select

End Sub

Sub SetFonts(inFont As ftType, inPct As PictureBox)
    
'Called from within this module to set the fonts of the picturebox.  The font
'name will not be checked for correct spelling (if errors - check name spelling first).
    
    inPct.FontName = inFont.ftName
    inPct.FontSize = inFont.ftSize
    inPct.FontBold = inFont.ftBold
    inPct.FontItalic = inFont.ftItalic
    inPct.FontUnderline = inFont.ftUnderline
    inPct.ForeColor = inFont.ftColor
    
End Sub