' A ver si les gusta este:
Option Strict On
' Coloca en el Form un Panel y tres Textbox
' Copia este codigo completo y es todo
Public Class Form1
WithEvents Calendario1 As New CALENDARIOX
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Calendario1.FORECOLOR_ = Color.Blue
Calendario1.FONT_STYLE_ = FontStyle.Bold
Calendario1.BACKCOLOR_ = Color.White
Calendario1.DD_MMM_YYYY_ = True ' D/M/Y o M/D/Y
Calendario1.CONTENEDOR_ = Panel1 : Panel1.Size = New Size(10, 10) : Panel1.AutoSize = True : Panel1.BorderStyle = BorderStyle.FixedSingle ' a elección
Calendario1.COLOR_CALENDARIO_ = Panel1.BackColor ' También
End Sub
Private Sub FECHA_Calendario1() Handles Calendario1.CAMBIO_DE_FECHA
TextBox1.Text = Calendario1.FECHA_SELECCIONADA_CORTA
TextBox2.Text = Calendario1.FECHA_SELECCIONADA_MMM
TextBox3.Text = Calendario1.FECHA_SELECCIONADA_LARGA
TextBox3.ForeColor = Calendario1.COLOR_ROJO_SI_NO_ES_HOY_
End Sub
End Class
Friend Class CALENDARIOX ' completo
Public Event CAMBIO_DE_FECHA()
Dim CALENDARIO As New Panel
Dim FECHA_SEL_CORTA As String, FECHA_SEL_MMM As String, FECHA_SEL_LARGA As String
Dim FORMATO_FECHA As Boolean
Dim COLOR_CALENDARIO As Color = Color.White
Dim FORECOLOR As Color = Color.Black
Dim BACKCOLOR As Color = Color.White
Dim FONTSTYLE As FontStyle = FontStyle.Regular
Dim COLOR_ROJO_SI_NO_ES_HOY As Color = FORECOLOR
WithEvents HScrollBar_DIA As New HScrollBar
WithEvents HScrollBar_MES As New HScrollBar
WithEvents HScrollBar_YAR As New HScrollBar
Dim LBLDIA As New Label
Dim LBLMES As New Label
Dim LBLYAR As New Label
Dim MESES As String = "1 ENE 2 FEB 3 MAR 4 ABR 5 MAY 6 JUN 7 JUL 8 AGO 9 SEP 10OCT 11NOV 12DIC"
WithEvents TMR As New Timer
Dim DD_MMM_YYYY As Boolean = True
Dim CONTENEDOR As New Object
Sub RUN_SI_PROPIEDADES_ESTAN_COMPLETAS()
CALENDARIO.Visible = False
CALENDARIO.Location = New Point(0, 0)
CALENDARIO.Size = CType(New Point(251, 32), Size)
HScrollBar_DIA.Location = New Point(97, 8) : Dim LOC_BAR_DIA As Point = New Point(97 - 16, 8)
HScrollBar_DIA.Size = CType(New Point(61, 19), Size)
HScrollBar_DIA.Minimum = 1
HScrollBar_DIA.Maximum = 31
HScrollBar_DIA.LargeChange = 1
HScrollBar_DIA.Value = Today.Day
CALENDARIO.Controls.Add(HScrollBar_DIA)
HScrollBar_DIA.BringToFront()
LBLDIA.Location = New Point(114, 9) : Dim LOC_LBL_DIA As Point = New Point(114 - 16, 9)
LBLDIA.Size = CType(New Point(25, 17), Size)
LBLDIA.BorderStyle = CType(1, BorderStyle)
LBLDIA.TextAlign = ContentAlignment.MiddleCenter
LBLDIA.Text = Today.Day.ToString
CALENDARIO.Controls.Add(LBLDIA)
LBLDIA.BringToFront()
HScrollBar_MES.Location = New Point(13, 8) : Dim LOC_BAR_MES As Point = HScrollBar_MES.Location
HScrollBar_MES.Size = CType(New Point(77, 19), Size)
HScrollBar_MES.Maximum = 12
HScrollBar_MES.Minimum = 1
HScrollBar_MES.LargeChange = 1
HScrollBar_MES.Value = Today.Month
CALENDARIO.Controls.Add(HScrollBar_MES)
LBLMES.Location = New Point(32, 9) : Dim LOC_LBL_MES As Point = LBLMES.Location
LBLMES.Size = CType(New Point(40, 17), Size)
LBLMES.BorderStyle = CType(1, BorderStyle)
LBLMES.TextAlign = ContentAlignment.MiddleCenter
LBLMES.Text = Mid(MESES, InStr(MESES, Today.Month.ToString) + 2, 3)
CALENDARIO.Controls.Add(LBLMES)
LBLMES.BringToFront()
HScrollBar_YAR.Location = New Point(165, 8)
HScrollBar_YAR.Size = CType(New Point(77, 19), Size)
HScrollBar_YAR.Minimum = Today.Year - 5
HScrollBar_YAR.Maximum = Today.Year + 2
HScrollBar_YAR.LargeChange = 1
HScrollBar_YAR.Value = Today.Year
CALENDARIO.Controls.Add(HScrollBar_YAR)
LBLYAR.Location = New Point(184, 9)
LBLYAR.Size = CType(New Point(40, 17), Size)
LBLYAR.BorderStyle = CType(1, BorderStyle)
LBLYAR.TextAlign = ContentAlignment.MiddleCenter
LBLYAR.Text = Today.Year.ToString
CALENDARIO.Controls.Add(LBLYAR)
LBLYAR.BringToFront()
'AddHandler HScrollBar_DIA.Scroll, AddressOf ScrollBar_DIA
'AddHandler HScrollBar_MES.Scroll, AddressOf ScrollBar_MES
'AddHandler HScrollBar_YAR.Scroll, AddressOf ScrollBar_YAR
FORMATO_FECHA = DD_MMM_YYYY
If DD_MMM_YYYY = True Then
HScrollBar_DIA.Location = LOC_BAR_MES
LBLDIA.Location = LOC_LBL_MES
HScrollBar_MES.Location = LOC_BAR_DIA
LBLMES.Location = LOC_LBL_DIA
End If
CALENDARIO.BringToFront()
Application.DoEvents()
CALENDARIO.Visible = True
TMR.Interval = 800
TMR.Enabled = False
ScrollBar_DIA()
If HScrollBar_MES.Value = 2 Then
Bisiesto()
End If
End Sub
Private Sub ScrollBar_DIA() Handles HScrollBar_DIA.Scroll
LBLDIA.Text = CStr(HScrollBar_DIA.Value)
Application.DoEvents()
DIA_SELECCIONADO()
End Sub
Private Sub ScrollBar_MES() Handles HScrollBar_MES.Scroll
Dim ESTE_MES As Integer = HScrollBar_MES.Value
LBLMES.Text = Mid(MESES, InStr(MESES, ESTE_MES.ToString) + 2, 3)
Select Case ESTE_MES
Case 2
Bisiesto()
Case 1, 3, 5, 6, 7, 8, 10, 12
HScrollBar_DIA.Maximum = 31
Case 4, 9, 11
HScrollBar_DIA.Maximum = 30
If CInt(LBLDIA.Text) > 30 Then
LBLDIA.Text = "30"
End If
End Select
Application.DoEvents()
DIA_SELECCIONADO()
End Sub
Private Sub ScrollBar_YAR() Handles HScrollBar_YAR.Scroll
LBLYAR.Text = CStr(HScrollBar_YAR.Value)
If HScrollBar_MES.Value = 2 Then
Bisiesto()
End If
Application.DoEvents()
DIA_SELECCIONADO()
End Sub
Private Sub Bisiesto()
Dim YEARS As String = "2012 2016 2020 2024 2028 2032 2036 2040 2044 2048 2052 2056 2060"
If InStr(YEARS, LBLYAR.Text) = 0 Then
HScrollBar_DIA.Maximum = 28
If CInt(LBLDIA.Text) > 28 Then
LBLDIA.Text = "28"
End If
Else
HScrollBar_DIA.Maximum = 29
If CInt(LBLDIA.Text) > 29 Then
LBLDIA.Text = "29"
End If
End If
Application.DoEvents()
End Sub
Private Sub DIA_SELECCIONADO()
TMR.Stop()
TMR.Start()
End Sub
Private Sub TMR_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles TMR.Tick
Dim MES As String = Trim(Mid(MESES, InStr(MESES, LBLMES.Text) - 2, 2))
Select Case MES
Case "1"
LBLMES.Text = "JAN"
Case "4"
LBLMES.Text = "APR"
Case "8"
LBLMES.Text = "AUG"
Case "12"
LBLMES.Text = "DEC"
End Select
If FORMATO_FECHA = True Then
FECHA_SEL_CORTA = Trim(LBLDIA.Text) & "/" & MES & "/" & LBLYAR.Text
FECHA_SEL_MMM = Trim(LBLDIA.Text) & "/" & LBLMES.Text & "/" & LBLYAR.Text
Else
FECHA_SEL_CORTA = MES & "/" & Trim(LBLDIA.Text) & "/" & LBLYAR.Text
FECHA_SEL_MMM = LBLMES.Text & "/" & Trim(LBLDIA.Text) & "/" & LBLYAR.Text
End If
Select Case LBLMES.Text
Case "JAN"
LBLMES.Text = "ENE"
Case "APR"
LBLMES.Text = "ABR"
Case "AUG"
LBLMES.Text = "AGO"
Case "DEC"
LBLMES.Text = "DIC"
End Select
Try
Dim FT As Date = CDate(LBLDIA.Text & "/" & MES & "/" & LBLYAR.Text)
FECHA_SEL_LARGA = FECHA_LARGA(FT)
Application.DoEvents()
Catch ex As Exception
Try
Dim FT As Date = CDate(MES & "/" & LBLDIA.Text & "/" & LBLYAR.Text)
FECHA_SEL_LARGA = FECHA_LARGA(FT)
Application.DoEvents()
Catch exx As Exception
FECHA_SEL_LARGA = "ERROR"
End Try
End Try
If HScrollBar_DIA.Value = Today.Day And HScrollBar_MES.Value = Today.Month And HScrollBar_YAR.Value = Today.Year Then
COLOR_ROJO_SI_NO_ES_HOY = FORECOLOR
Else
COLOR_ROJO_SI_NO_ES_HOY = Color.Red
End If
Application.DoEvents()
RaiseEvent CAMBIO_DE_FECHA()
TMR.Enabled = False
End Sub
Private Function FECHA_LARGA(ByVal EF As Date) As String
Dim DIAS As String = "1 Lunes 2 Martes 3 Miercoles 4 Jueves 5 Viernes 6 Sabado 0 Domingo "
Dim ESTE_DIA As String = EF.DayOfWeek.ToString
Dim ESTE_MES As Integer = EF.Month
Return Trim(Mid(DIAS, InStr(DIAS, ESTE_DIA) + 2, 9)) & " " & EF.Day.ToString & " de " & Trim(Mid(MESES, InStr(MESES, ESTE_MES.ToString) + 2, 3)) & " " & EF.Year.ToString
End Function
Public WriteOnly Property CONTENEDOR_ As Control
Set(ByVal value As Control)
Dim CTRL As Control = CType(value, Control)
CTRL = value
RUN_SI_PROPIEDADES_ESTAN_COMPLETAS()
CTRL.Controls.Add(CALENDARIO)
End Set
End Property
Public WriteOnly Property COLOR_CALENDARIO_ As Color
Set(ByVal value As Color)
COLOR_CALENDARIO = value
CALENDARIO.BackColor = COLOR_CALENDARIO
End Set
End Property
Public WriteOnly Property FORECOLOR_ As Color
Set(ByVal value As Color)
FORECOLOR = value
LBLDIA.ForeColor = FORECOLOR
LBLMES.ForeColor = FORECOLOR
LBLYAR.ForeColor = FORECOLOR
End Set
End Property
Public WriteOnly Property FONT_STYLE_ As FontStyle
Set(ByVal value As FontStyle)
FONTSTYLE = value
LBLDIA.Font = New Font("Arial", 8.25, FONTSTYLE)
LBLMES.Font = New Font("Arial", 8.25, FONTSTYLE)
LBLYAR.Font = New Font("Arial", 8.25, FONTSTYLE)
End Set
End Property
Public WriteOnly Property BACKCOLOR_ As Color
Set(ByVal value As Color)
BACKCOLOR = value
LBLDIA.BackColor = BACKCOLOR
LBLMES.BackColor = BACKCOLOR
LBLYAR.BackColor = BACKCOLOR
End Set
End Property
Public WriteOnly Property DD_MMM_YYYY_ As Boolean
Set(ByVal value As Boolean)
DD_MMM_YYYY = value
RUN_SI_PROPIEDADES_ESTAN_COMPLETAS()
End Set
End Property
Public ReadOnly Property COLOR_ROJO_SI_NO_ES_HOY_ As Color
Get
Return COLOR_ROJO_SI_NO_ES_HOY
End Get
End Property
Public ReadOnly Property FECHA_SELECCIONADA_MMM As String
Get
Return FECHA_SEL_MMM
End Get
End Property
Public ReadOnly Property FECHA_SELECCIONADA_CORTA As String
Get
Return FECHA_SEL_CORTA
End Get
End Property
Public ReadOnly Property FECHA_SELECCIONADA_LARGA As String
Get
Return FECHA_SEL_LARGA
End Get
End Property
End Class
