VERSION 5.00
Begin VB.Form Dates 
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Date"
   ClientHeight    =   5460
   ClientLeft      =   2430
   ClientTop       =   1275
   ClientWidth     =   3570
   ClipControls    =   0   'False
   ControlBox      =   0   'False
   FillColor       =   &H0080FFFF&
   ForeColor       =   &H00800000&
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   NegotiateMenus  =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   5460
   ScaleWidth      =   3570
   ShowInTaskbar   =   0   'False
   Begin VB.ListBox lst_Year 
      Height          =   2205
      Left            =   2520
      TabIndex        =   15
      Top             =   1680
      Visible         =   0   'False
      Width           =   732
   End
   Begin VB.ListBox lst_Month 
      Height          =   2205
      Left            =   1440
      TabIndex        =   14
      Top             =   1680
      Visible         =   0   'False
      Width           =   612
   End
   Begin VB.ListBox lst_Day 
      Height          =   2205
      Left            =   360
      TabIndex        =   13
      Top             =   1680
      Visible         =   0   'False
      Width           =   612
   End
   Begin VB.Frame Frame1 
      Caption         =   "Date choice"
      Height          =   735
      Left            =   0
      TabIndex        =   8
      Top             =   600
      Width           =   3555
      Begin VB.OptionButton opt_Reset 
         Caption         =   "Reset"
         Height          =   252
         Left            =   2460
         TabIndex        =   12
         Top             =   300
         Width           =   1032
      End
      Begin VB.OptionButton opt_Direct 
         Caption         =   "Directly"
         Height          =   252
         Left            =   1260
         TabIndex        =   10
         Top             =   300
         Width           =   1152
      End
      Begin VB.OptionButton opt_List 
         Caption         =   "List"
         Height          =   252
         Left            =   180
         TabIndex        =   9
         Top             =   300
         Width           =   1032
      End
   End
   Begin VB.PictureBox pic_pic 
      BackColor       =   &H00FFFFFF&
      Height          =   585
      Left            =   0
      ScaleHeight     =   525
      ScaleWidth      =   3495
      TabIndex        =   5
      Top             =   0
      Width           =   3555
      Begin VB.PictureBox pic_quit 
         Appearance      =   0  'Flat
         AutoSize        =   -1  'True
         BackColor       =   &H80000005&
         BorderStyle     =   0  'None
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H80000008&
         Height          =   384
         Left            =   900
         ScaleHeight     =   390
         ScaleWidth      =   390
         TabIndex        =   7
         Top             =   60
         Width           =   384
      End
      Begin VB.PictureBox pic_Save 
         Appearance      =   0  'Flat
         AutoSize        =   -1  'True
         BackColor       =   &H00FFFFFF&
         BorderStyle     =   0  'None
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H80000008&
         Height          =   384
         Left            =   180
         ScaleHeight     =   390
         ScaleWidth      =   390
         TabIndex        =   6
         Top             =   60
         Width           =   384
      End
   End
   Begin VB.PictureBox pic_up 
      AutoSize        =   -1  'True
      Height          =   408
      Left            =   2280
      ScaleHeight     =   345
      ScaleWidth      =   345
      TabIndex        =   2
      Top             =   2760
      Width           =   408
   End
   Begin VB.PictureBox pic_down 
      AutoSize        =   -1  'True
      Height          =   408
      Left            =   2280
      ScaleHeight     =   345
      ScaleWidth      =   345
      TabIndex        =   1
      Top             =   3360
      Width           =   408
   End
   Begin VB.ListBox lst_date 
      BackColor       =   &H00C0C0C0&
      Height          =   3570
      Left            =   60
      TabIndex        =   0
      Top             =   1380
      Width           =   1572
   End
   Begin VB.Label lbl_Info 
      Caption         =   "Doubleclick the date you want"
      Height          =   252
      Left            =   60
      TabIndex        =   11
      Top             =   5100
      Width           =   3312
   End
   Begin VB.Label Label1 
      Caption         =   "/"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   315
      Left            =   1140
      TabIndex        =   3
      Top             =   1740
      Visible         =   0   'False
      Width           =   75
   End
   Begin VB.Label Label2 
      Caption         =   "/"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   312
      Left            =   2280
      TabIndex        =   4
      Top             =   1740
      Visible         =   0   'False
      Width           =   72
   End
End
Attribute VB_Name = "Dates"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Form_Load()

On Error GoTo suite

MouseOff

'If gl_CodePage <> 1252 And gl_CodePage <> 0 Then ChangeCharset Me

pic_Save.Picture = LoadResPicture(RES_OK, 1)
pic_quit.Picture = LoadResPicture(RES_QUIT, 1)
pic_down.Picture = LoadResPicture(RES_DOWN, 1)
pic_up.Picture = LoadResPicture(RES_UP, 1)
'Height = 1752
opt_List.Value = OK
MouseOn
Exit Sub

suite:
'StdError
End Sub

Private Sub lst_date_DblClick()
pic_Save_Click
End Sub

Private Sub Opt_Direct_Click()

Dim i As Integer

MouseOff
lst_date.Visible = KO
lbl_Info.Visible = KO
pic_up.Visible = KO
pic_down.Visible = KO
Height = 4760
lst_Day.Visible = OK
Label1.Visible = OK
lst_Month.Visible = OK
Label2.Visible = OK
lst_Year.Visible = OK
For i = 1 To 31
    lst_Day.AddItem Format(i, "00")
Next i
For i = 1 To 12
    lst_Month.AddItem Format(i, "00")
Next i
For i = 1970 To 2020
    lst_Year.AddItem i
Next i
If gs_Date = "" Then
    lst_Day.ListIndex = Day(Date) - 1
    lst_Month.ListIndex = Month(Date) - 1
    lst_Year.ListIndex = Year(Date) - 1970
Else
    If right(gs_Date, 4) > 1969 And right(gs_Date, 4) < 2021 Then
        lst_Day.ListIndex = Left(gs_Date, 2) - 1
        lst_Month.ListIndex = Mid(gs_Date, 4, 2) - 1
        lst_Year.ListIndex = right(gs_Date, 4) - 1970
    End If
End If
MouseOn

End Sub
Private Sub opt_List_Click()

Dim i As Integer
Dim ls_DateBase As String
Dim ld_Current As Date

MouseOff
lst_Day.Visible = KO
Label1.Visible = KO
lst_Month.Visible = KO
Label2.Visible = KO
lst_Year.Visible = KO
Height = 5880
lst_date.Visible = OK
lbl_Info.Visible = OK
pic_up.Visible = OK
pic_down.Visible = OK
If gs_Date = "" Then
    ls_DateBase = DateToString(Date)
    ld_Current = DateSerial(CStr(Year(Date)), CStr(Month(Date)), "01")
Else
    ls_DateBase = gs_Date
    ld_Current = DateSerial(Mid(gs_Date, 7, 4), Mid(gs_Date, 4, 2), "01")
End If
lst_date.Clear
For i = 1 To 60
    lst_date.AddItem FormatD2(ld_Current)
    ld_Current = DateAdd("d", 1, ld_Current)
Next i
lst_date.ListIndex = ListFindItem(lst_date, ls_DateBase)
MouseOn

End Sub
Private Sub opt_Reset_Click()

MouseOff
Height = 1752
MouseOn

End Sub
Private Sub pic_down_Click()

Dim ls_DateMin As String
Dim ld_Current As Date
Dim i As Integer

On Error GoTo suite

MouseOff
ls_DateMin = lst_date.List(lst_date.ListCount - 1)
ld_Current = DateSerial(Mid(ls_DateMin, 7, 4), Mid(ls_DateMin, 4, 2), Mid(ls_DateMin, 1, 2))
For i = 1 To 60
    ld_Current = DateAdd("d", 1, ld_Current)
    lst_date.AddItem FormatD2(ld_Current)
Next i
lst_date.TopIndex = lst_date.ListCount - 1
lst_date.ListIndex = lst_date.ListCount - 1
MouseOn

Exit Sub

suite:
MouseOn
'StdError
End Sub
Private Sub pic_quit_Click()
MouseOff
Unload Me
MouseOn
End Sub

Private Sub pic_Save_Click()

MouseOff
gb_Return = OK
gs_Date = ""
If opt_List Then
    gs_Date = lst_date
    Unload Me
Else
    If opt_Direct Then
        
        If Not Control_Date Then
            gs_Date = ""
            SendMessage 60, "This is not a valid date. Please give another value.", "E"
            MouseOn
            Exit Sub
        End If
        
        gs_Date = lst_Day & "/" & lst_Month & "/" & lst_Year
        If IsDate(StringToDate(gs_Date)) Then
            Unload Me
        Else
            gs_Date = ""
            SendMessage 60, "This is not a valid date. Please give another value.", "E"
        End If
    Else
        Unload Me
    End If
End If
MouseOn

End Sub
Private Sub pic_up_Click()

Dim ls_DateMin As String
Dim ld_Current As Date
Dim i As Integer

On Error GoTo suite

MouseOff
ls_DateMin = lst_date.List(0)
ld_Current = DateSerial(Mid(ls_DateMin, 7, 4), Mid(ls_DateMin, 4, 2), Mid(ls_DateMin, 1, 2))
For i = 1 To 60
    ld_Current = DateAdd("d", -1, ld_Current)
    lst_date.AddItem FormatD2(ld_Current), 0
Next i
lst_date.TopIndex = 0
lst_date.ListIndex = 0
MouseOn

Exit Sub

suite:
MouseOn
'StdError
End Sub

Private Function Control_Date() As Boolean

Control_Date = False
On Error GoTo Err_Control_date

If CInt(lst_Day) < 29 Then
    Control_Date = True
    Exit Function
End If

If CLng(lst_Day) > DayMax(CLng(lst_Month), CLng(lst_Year)) Then Exit Function

Control_Date = True

Err_Control_date:
End Function

Private Function DayMax(ByVal aMonth As Long, ByVal aYear As Long) As Long

DayMax = 0

If aMonth = 4 Or aMonth = 6 Or aMonth = 9 Or aMonth = 11 Then
    DayMax = 30
End If
If aMonth = 1 Or aMonth = 3 Or aMonth = 5 Or aMonth = 7 Or aMonth = 8 Or aMonth = 10 Or aMonth = 12 Then
    DayMax = 31
End If

'Bissextile & February ?
If aMonth = 2 Then
    If (aYear Mod 4) = 0 Then
        DayMax = 29
    Else
        DayMax = 28
    End If
End If

End Function

