home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / My_ucContr2093141282007.psc / Cal.ctl < prev    next >
Text File  |  2007-11-04  |  27KB  |  889 lines

  1. VERSION 5.00
  2. Begin VB.UserControl Cal 
  3.    AutoRedraw      =   -1  'True
  4.    ClientHeight    =   3360
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   3945
  8.    ScaleHeight     =   3360
  9.    ScaleWidth      =   3945
  10.    ToolboxBitmap   =   "Cal.ctx":0000
  11.    Begin VB.PictureBox Picture1 
  12.       Appearance      =   0  'Flat
  13.       BackColor       =   &H80000005&
  14.       ForeColor       =   &H80000008&
  15.       Height          =   2925
  16.       Left            =   30
  17.       ScaleHeight     =   2895
  18.       ScaleWidth      =   3855
  19.       TabIndex        =   0
  20.       Top             =   315
  21.       Width           =   3885
  22.       Begin VB.CommandButton cmdCurrentDate 
  23.          Caption         =   "Today"
  24.          Height          =   300
  25.          Left            =   2775
  26.          TabIndex        =   3
  27.          Top             =   60
  28.          Width           =   900
  29.       End
  30.       Begin VB.ComboBox cboYear 
  31.          Height          =   315
  32.          Left            =   1440
  33.          TabIndex        =   2
  34.          Text            =   "cboYear"
  35.          Top             =   60
  36.          Width           =   1215
  37.       End
  38.       Begin VB.ComboBox cboMonth 
  39.          Height          =   315
  40.          Left            =   60
  41.          TabIndex        =   1
  42.          Text            =   "cboMonth"
  43.          Top             =   60
  44.          Width           =   1260
  45.       End
  46.       Begin VB.Line Line11 
  47.          X1              =   3150
  48.          X2              =   3150
  49.          Y1              =   735
  50.          Y2              =   2910
  51.       End
  52.       Begin VB.Line Line10 
  53.          X1              =   2655
  54.          X2              =   2655
  55.          Y1              =   735
  56.          Y2              =   2910
  57.       End
  58.       Begin VB.Line Line9 
  59.          X1              =   2145
  60.          X2              =   2145
  61.          Y1              =   735
  62.          Y2              =   2910
  63.       End
  64.       Begin VB.Line Line8 
  65.          X1              =   1635
  66.          X2              =   1635
  67.          Y1              =   735
  68.          Y2              =   2910
  69.       End
  70.       Begin VB.Line Line7 
  71.          X1              =   1125
  72.          X2              =   1125
  73.          Y1              =   735
  74.          Y2              =   2910
  75.       End
  76.       Begin VB.Line Line6 
  77.          X1              =   615
  78.          X2              =   615
  79.          Y1              =   735
  80.          Y2              =   2910
  81.       End
  82.       Begin VB.Line Line5 
  83.          X1              =   0
  84.          X2              =   3855
  85.          Y1              =   2535
  86.          Y2              =   2535
  87.       End
  88.       Begin VB.Line Line4 
  89.          X1              =   0
  90.          X2              =   3855
  91.          Y1              =   2190
  92.          Y2              =   2190
  93.       End
  94.       Begin VB.Line Line3 
  95.          X1              =   0
  96.          X2              =   3840
  97.          Y1              =   1845
  98.          Y2              =   1845
  99.       End
  100.       Begin VB.Line Line2 
  101.          X1              =   0
  102.          X2              =   3855
  103.          Y1              =   1485
  104.          Y2              =   1485
  105.       End
  106.       Begin VB.Line Line1 
  107.          X1              =   0
  108.          X2              =   3810
  109.          Y1              =   1140
  110.          Y2              =   1140
  111.       End
  112.       Begin VB.Label lblDatesT 
  113.          Alignment       =   2  'Center
  114.          Caption         =   "1"
  115.          BeginProperty Font 
  116.             Name            =   "MS Sans Serif"
  117.             Size            =   9.75
  118.             Charset         =   0
  119.             Weight          =   700
  120.             Underline       =   0   'False
  121.             Italic          =   0   'False
  122.             Strikethrough   =   0   'False
  123.          EndProperty
  124.          Height          =   240
  125.          Left            =   420
  126.          TabIndex        =   13
  127.          Top             =   3135
  128.          Width           =   360
  129.       End
  130.       Begin VB.Label lblDates 
  131.          Alignment       =   2  'Center
  132.          Appearance      =   0  'Flat
  133.          BackColor       =   &H0080FFFF&
  134.          Caption         =   "0"
  135.          BeginProperty Font 
  136.             Name            =   "MS Sans Serif"
  137.             Size            =   9.75
  138.             Charset         =   0
  139.             Weight          =   700
  140.             Underline       =   0   'False
  141.             Italic          =   0   'False
  142.             Strikethrough   =   0   'False
  143.          EndProperty
  144.          ForeColor       =   &H80000008&
  145.          Height          =   300
  146.          Index           =   0
  147.          Left            =   180
  148.          TabIndex        =   12
  149.          Top             =   840
  150.          Width           =   405
  151.       End
  152.       Begin VB.Label lblDayNames 
  153.          BackStyle       =   0  'Transparent
  154.          Caption         =   "Sat"
  155.          BeginProperty Font 
  156.             Name            =   "MS Sans Serif"
  157.             Size            =   9.75
  158.             Charset         =   0
  159.             Weight          =   700
  160.             Underline       =   0   'False
  161.             Italic          =   0   'False
  162.             Strikethrough   =   0   'False
  163.          EndProperty
  164.          Height          =   255
  165.          Index           =   6
  166.          Left            =   3225
  167.          TabIndex        =   11
  168.          Top             =   465
  169.          Width           =   555
  170.       End
  171.       Begin VB.Label lblDayNames 
  172.          BackStyle       =   0  'Transparent
  173.          Caption         =   "Fri"
  174.          BeginProperty Font 
  175.             Name            =   "MS Sans Serif"
  176.             Size            =   9.75
  177.             Charset         =   0
  178.             Weight          =   700
  179.             Underline       =   0   'False
  180.             Italic          =   0   'False
  181.             Strikethrough   =   0   'False
  182.          EndProperty
  183.          Height          =   240
  184.          Index           =   5
  185.          Left            =   2775
  186.          TabIndex        =   10
  187.          Top             =   465
  188.          Width           =   360
  189.       End
  190.       Begin VB.Label lblDayNames 
  191.          BackStyle       =   0  'Transparent
  192.          Caption         =   "Thur"
  193.          BeginProperty Font 
  194.             Name            =   "MS Sans Serif"
  195.             Size            =   9.75
  196.             Charset         =   0
  197.             Weight          =   700
  198.             Underline       =   0   'False
  199.             Italic          =   0   'False
  200.             Strikethrough   =   0   'False
  201.          EndProperty
  202.          Height          =   300
  203.          Index           =   4
  204.          Left            =   2190
  205.          TabIndex        =   9
  206.          Top             =   465
  207.          Width           =   540
  208.       End
  209.       Begin VB.Label lblDayNames 
  210.          BackStyle       =   0  'Transparent
  211.          Caption         =   "Wed"
  212.          BeginProperty Font 
  213.             Name            =   "MS Sans Serif"
  214.             Size            =   9.75
  215.             Charset         =   0
  216.             Weight          =   700
  217.             Underline       =   0   'False
  218.             Italic          =   0   'False
  219.             Strikethrough   =   0   'False
  220.          EndProperty
  221.          Height          =   240
  222.          Index           =   3
  223.          Left            =   1635
  224.          TabIndex        =   8
  225.          Top             =   465
  226.          Width           =   525
  227.       End
  228.       Begin VB.Label lblDayNames 
  229.          BackStyle       =   0  'Transparent
  230.          Caption         =   "Tue"
  231.          BeginProperty Font 
  232.             Name            =   "MS Sans Serif"
  233.             Size            =   9.75
  234.             Charset         =   0
  235.             Weight          =   700
  236.             Underline       =   0   'False
  237.             Italic          =   0   'False
  238.             Strikethrough   =   0   'False
  239.          EndProperty
  240.          Height          =   240
  241.          Index           =   2
  242.          Left            =   1140
  243.          TabIndex        =   7
  244.          Top             =   465
  245.          Width           =   465
  246.       End
  247.       Begin VB.Label lblDayNames 
  248.          BackStyle       =   0  'Transparent
  249.          Caption         =   "Mon"
  250.          BeginProperty Font 
  251.             Name            =   "MS Sans Serif"
  252.             Size            =   9.75
  253.             Charset         =   0
  254.             Weight          =   700
  255.             Underline       =   0   'False
  256.             Italic          =   0   'False
  257.             Strikethrough   =   0   'False
  258.          EndProperty
  259.          Height          =   225
  260.          Index           =   1
  261.          Left            =   630
  262.          TabIndex        =   6
  263.          Top             =   465
  264.          Width           =   480
  265.       End
  266.       Begin VB.Label lblDayNames 
  267.          BackStyle       =   0  'Transparent
  268.          Caption         =   "Sun"
  269.          BeginProperty Font 
  270.             Name            =   "MS Sans Serif"
  271.             Size            =   9.75
  272.             Charset         =   0
  273.             Weight          =   700
  274.             Underline       =   0   'False
  275.             Italic          =   0   'False
  276.             Strikethrough   =   0   'False
  277.          EndProperty
  278.          Height          =   255
  279.          Index           =   0
  280.          Left            =   105
  281.          TabIndex        =   5
  282.          Top             =   465
  283.          Width           =   405
  284.       End
  285.       Begin VB.Label Label1 
  286.          Appearance      =   0  'Flat
  287.          BackColor       =   &H00FFC0C0&
  288.          BorderStyle     =   1  'Fixed Single
  289.          ForeColor       =   &H80000008&
  290.          Height          =   315
  291.          Left            =   45
  292.          TabIndex        =   4
  293.          Top             =   435
  294.          Width           =   3660
  295.       End
  296.    End
  297.    Begin VB.Label lblDateBar 
  298.       Alignment       =   2  'Center
  299.       Appearance      =   0  'Flat
  300.       BackColor       =   &H80000005&
  301.       BorderStyle     =   1  'Fixed Single
  302.       ForeColor       =   &H80000008&
  303.       Height          =   255
  304.       Left            =   30
  305.       TabIndex        =   15
  306.       Top             =   30
  307.       Width           =   3015
  308.    End
  309.    Begin VB.Label Label2 
  310.       Alignment       =   2  'Center
  311.       Appearance      =   0  'Flat
  312.       BackColor       =   &H00FFFFFF&
  313.       BorderStyle     =   1  'Fixed Single
  314.       Caption         =   "Show"
  315.       ForeColor       =   &H80000008&
  316.       Height          =   255
  317.       Left            =   3060
  318.       TabIndex        =   14
  319.       Top             =   30
  320.       Width           =   735
  321.    End
  322. End
  323. Attribute VB_Name = "Cal"
  324. Attribute VB_GlobalNameSpace = False
  325. Attribute VB_Creatable = True
  326. Attribute VB_PredeclaredId = False
  327. Attribute VB_Exposed = False
  328.  
  329. '*********************************************
  330.    '*  KF Dropdown Calendar                               *
  331.    '*  By Ken Foster                            *
  332.    '*    2005                                   *
  333.    '*  Freeware--use or change any way you want *
  334.    '*********************************************
  335.    'Form animation code by Jim Jose
  336.    '*********************************************
  337.    'Click on Date label to open/close calendar
  338.    'Clicking on empty space in calendar box will close also
  339.    '*********************************************
  340.    Option Explicit
  341.    
  342.    '[APIs]
  343.    Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
  344.    Private Declare Function SendMessageByNum& Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
  345.    Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
  346.    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  347.    Private Declare Function CreateRectRgn Lib "GDI32.dll" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  348.    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  349.    Private Declare Function CombineRgn Lib "GDI32.dll" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
  350.    Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
  351.    Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hrgn As Long, ByVal bRedraw As Boolean) As Long
  352.      
  353.    '[Constants]
  354.    Private Const RGN_AND As Long = 1
  355.    Private Const RGN_OR As Long = 2
  356.    Private Const RGN_XOR As Long = 3
  357.    Private Const RGN_COPY As Long = 5
  358.    Private Const RGN_DIFF As Long = 4
  359.    Private Const CB_SETDROPPEDCONTROLRECT = &H160
  360.    Private Const CB_GETITEMHEIGHT = &H154
  361.  
  362. '[Event Enum]
  363. Private Enum AnimeEventEnum
  364.    aUnload = 0
  365.    aload = 1
  366.  End Enum
  367.  
  368. '[Effect Enum]
  369. Private Enum AnimeEffectEnum
  370.    eAppearFromTop = 2
  371.    eAppearFromBottom = 3
  372. End Enum
  373.  
  374. Private Type RECT
  375.    Left As Long
  376.    top As Long
  377.    Right As Long
  378.    bottom As Long
  379. End Type
  380.  
  381. Private Type POINTAPI
  382.    X   As Long
  383.    Y   As Long
  384. End Type
  385.  
  386. Private Enum eExpandBy
  387.    Percent50 = 0
  388.    Percent75 = 1
  389.    DoubleWidth = 2
  390.    TripleWidth = 3
  391.    QuadWidth = 4
  392.    NoExpand = 5
  393. End Enum
  394.  
  395. Private Enum eExpandType
  396.    WidthOnly = 0
  397.    HeightOnly = 1
  398.    HeightAndWidth = 2
  399. End Enum
  400.  
  401. Const m_def_BackColor = vbWhite
  402. Const m_def_DateDisplay = True
  403. Const m_def_SHButton = True
  404.  
  405. Dim TheCaption As String
  406. Dim CurMonth As Single
  407. Dim CurDay As Single
  408. Dim CurYear As Single
  409. Dim LastDay As Single
  410. Dim LastIndex As Single
  411. Dim m_BackColor As OLE_COLOR
  412. Dim m_Value As String
  413. Dim CC As Boolean  ' used to keep track if calendar is visible or not
  414. Dim m_DateDisplay As Boolean
  415. Dim m_SHButton As Boolean
  416. Dim StoreDate As String
  417. Event Click()
  418.  
  419. Private Sub lblDateBar_Click()
  420.   Dim ZX As Long
  421.   Dim c As Control
  422.   On Error Resume Next
  423.   
  424.      For ZX = 1 To UserControl.ParentControls.Count
  425.        Set c = UserControl.ParentControls.Item(ZX)
  426.        c.ZOrder 1
  427.      Next
  428.    If Label2.Caption = "Show" Then
  429.       AnimateForm Picture1, aload, eAppearFromTop, 11, 33
  430.       Label2.Caption = "Hide"
  431.       CC = False
  432.    Else
  433.       AnimateForm Picture1, aUnload, eAppearFromBottom, 11, 33
  434.       Label2.Caption = "Show"
  435.       CC = True
  436.    End If
  437.    If UserControl.Height >= 3280 Then UserControl.Height = 3270
  438.  
  439. End Sub
  440.  
  441. Private Sub UserControl_Initialize()
  442.   
  443.    cboMonth.top = -300
  444.    cboYear.top = -300
  445.    cmdCurrentDate.top = 50
  446.    FindYear CStr(CurYear)
  447.    FillMonths
  448.    Call ExpandCombo(cboMonth, HeightOnly, NoExpand)
  449.    FillYears
  450.    Call ExpandCombo(cboYear, HeightOnly, NoExpand)
  451.    InitDates
  452.    DisplayDates
  453.    HighLightDate
  454.    CC = True
  455.    BackColor = m_def_BackColor
  456.    DateDisplay = m_def_DateDisplay
  457.    SHButton = m_def_SHButton
  458.    
  459. End Sub
  460.  
  461. Private Sub UserControl_Show()
  462.   
  463.    UserControl.BackColor = Ambient.BackColor
  464.    UserControl.Height = lblDateBar.Height + 50
  465.    BackColor = m_BackColor
  466.    cmdCurrentDate_Click
  467.    StoreDate = Value
  468.    AnimateForm Picture1, aUnload, eAppearFromBottom, 11, 33
  469.    Label2.Caption = "Show"
  470.  
  471. End Sub
  472.  
  473. Private Sub UserControl_Resize()
  474.    UserControl.Width = 3800
  475.    
  476.    Picture1.Width = UserControl.Width - 25
  477. End Sub
  478.  
  479. Private Sub Usercontrol_ReadProperties(Propbag As PropertyBag)
  480.    m_Value = Propbag.ReadProperty("Value", StoreDate)
  481.    m_BackColor = Propbag.ReadProperty("BackColor", m_def_BackColor)
  482.    m_DateDisplay = Propbag.ReadProperty("DateDisplay", m_def_DateDisplay)
  483.    m_SHButton = Propbag.ReadProperty("SHButton", m_def_SHButton)
  484.    SHButton = m_SHButton
  485. End Sub
  486.  
  487. Private Sub Usercontrol_WriteProperties(Propbag As PropertyBag)
  488.    Call Propbag.WriteProperty("Value", m_Value, StoreDate)
  489.    Call Propbag.WriteProperty("BackColor", m_BackColor, m_def_BackColor)
  490.    Call Propbag.WriteProperty("DateDisplay", m_DateDisplay, m_def_DateDisplay)
  491.    Call Propbag.WriteProperty("SHButton", m_SHButton, m_def_SHButton)
  492. End Sub
  493.  
  494. Private Sub cmdCurrentDate_Click()
  495.     InitDates
  496.     
  497.     If DateDisplay = True Then
  498.         lblDateBar.Caption = Value
  499.     Else
  500.         lblDateBar.Caption = "Calendar"
  501.     End If
  502.     
  503.     InitDates
  504.     StoreDate = Value
  505.     RaiseEvent Click
  506. End Sub
  507.  
  508. Private Sub Label2_Click()
  509.   Dim ZX As Long
  510.   Dim c As Control
  511.   On Error Resume Next
  512.   
  513.      For ZX = 1 To UserControl.ParentControls.Count
  514.        Set c = UserControl.ParentControls.Item(ZX)
  515.        c.ZOrder 1
  516.      Next
  517.    If CC = True Then
  518.       AnimateForm Picture1, aload, eAppearFromTop, 11, 33
  519.       Label2.Caption = "Hide"
  520.       CC = False
  521.    Else
  522.       AnimateForm Picture1, aUnload, eAppearFromBottom, 11, 33
  523.       Label2.Caption = "Show"
  524.       CC = True
  525.    End If
  526. End Sub
  527.  
  528. Private Sub Picture1_Click()
  529.    AnimateForm Picture1, aUnload, eAppearFromBottom, 11, 33
  530.    Label2.Caption = "Show"
  531.    CC = True
  532. End Sub
  533.  
  534. Private Sub cboMonth_Click()
  535.    DisplayDates
  536.    If lblDates(LastIndex).Visible = False Then
  537.       If lblDates(LastIndex).Index > 7 Then
  538.          CurDay = lblDates(LastDay).Caption
  539.       End If
  540.    End If
  541.    HighLightDate
  542.    RaiseEvent Click
  543. End Sub
  544.  
  545. Private Sub cboYear_Click()
  546.    DisplayDates
  547.    If lblDates(LastIndex).Visible = False Then
  548.       If lblDates(LastIndex).Index > 7 Then
  549.          CurDay = lblDates(LastDay).Caption
  550.       End If
  551.    End If
  552.    HighLightDate
  553.    RaiseEvent Click
  554. End Sub
  555.  
  556. Private Sub DisplayDates()
  557.    Dim iRow As Single
  558.    Dim iColumn As Single
  559.    Dim iDates As Single
  560.    Dim CellTop As Single
  561.    Dim CellLeft As Single
  562.    
  563.    CellTop = lblDates(0).top
  564.    CellLeft = lblDates(0).Left
  565.    
  566.    For iRow = 1 To 6
  567.       For iColumn = 1 To 7
  568.          If iDates = 38 Then
  569.             ShowDates
  570.             Exit Sub
  571.          End If
  572.          On Error Resume Next
  573.          iDates = iDates + 1
  574.          Load lblDates(iDates)
  575.          lblDates(iDates).Move CellLeft, CellTop
  576.          CellLeft = CellLeft + lblDates(0).Width + 100
  577.          lblDates(iDates).Visible = True
  578.          
  579.          Next
  580.          CellTop = CellTop + lblDates(0).Height + 50
  581.          CellLeft = lblDates(0).Left
  582.          Next
  583.       End Sub
  584.  
  585. Private Sub ExpandCombo(ByRef Combo As ComboBox, ByVal ExpandType As eExpandType, ByVal ExpandBy As eExpandBy, Optional ByVal hFrame As Long)
  586.    
  587.    Dim lRet As Long
  588.    Dim pt As POINTAPI
  589.    Dim rc As RECT
  590.    Dim lComboWidth As Long
  591.    Dim lNewHeight As Long
  592.    Dim lItemHeight As Long
  593.    
  594.    If ExpandType <> HeightOnly Then
  595.       lComboWidth = (Combo.Width / Screen.TwipsPerPixelX)
  596.       Select Case ExpandBy
  597.          Case 0
  598.             lComboWidth = lComboWidth + (lComboWidth * 0.5)
  599.          Case 1
  600.             lComboWidth = lComboWidth + (lComboWidth * 0.75)
  601.          Case 2
  602.             lComboWidth = lComboWidth * 2
  603.          Case 3
  604.             lComboWidth = lComboWidth * 3
  605.          Case 4
  606.             lComboWidth = lComboWidth * 4
  607.       End Select
  608.       lRet = SendMessageByNum(Combo.hWnd, CB_SETDROPPEDCONTROLRECT, lComboWidth, 0)
  609.       
  610.    End If
  611.    
  612.    If ExpandType <> WidthOnly Then
  613.       lComboWidth = Combo.Width / Screen.TwipsPerPixelX
  614.       lItemHeight = SendMessageByNum(Combo.hWnd, CB_GETITEMHEIGHT, 0, 0)
  615.       lNewHeight = lItemHeight * 30
  616.       Call GetWindowRect(Combo.hWnd, rc)
  617.       pt.X = rc.Left
  618.       pt.Y = rc.top
  619.       Call ScreenToClient(hFrame, pt)
  620.       Call MoveWindow(Combo.hWnd, pt.X, pt.Y, lComboWidth, lNewHeight, True)
  621.    End If
  622.    
  623. End Sub
  624.  
  625. Private Sub FillMonths()
  626.    With cboMonth
  627.       .AddItem "January"
  628.       .AddItem "February"
  629.       .AddItem "March"
  630.       .AddItem "April"
  631.       .AddItem "May"
  632.       .AddItem "June"
  633.       .AddItem "July"
  634.       .AddItem "August"
  635.       .AddItem "September"
  636.       .AddItem "October"
  637.       .AddItem "November"
  638.       .AddItem "December"
  639.    End With
  640. End Sub
  641.  
  642. Private Sub FillYears()
  643.    Dim iYear As Long
  644.    
  645.    For iYear = Year(Now) - 10 To Year(Now) + 10
  646.       cboYear.AddItem iYear
  647.       Next
  648.       
  649.    End Sub
  650.  
  651. Private Sub FindYear(Years As String)
  652.    Dim ctr As Integer
  653.    
  654.    With cboYear
  655.       For ctr = 0 To .ListCount - 1
  656.          If .List(ctr) = Years Then
  657.             .ListIndex = ctr
  658.             Exit For
  659.          End If
  660.          Next
  661.       End With
  662.    End Sub
  663.  
  664. Private Sub HighLightDate()
  665.    Dim X As Single
  666.    
  667.    For X = 1 To 38
  668.       If CurDay = lblDates(X).Caption Then
  669.          lblDates(X).BackStyle = 1
  670.          lblDates(X).BorderStyle = 1
  671.          LastIndex = lblDates(X).Index
  672.       Else
  673.          lblDates(X).BorderStyle = 0
  674.          lblDates(X).BackStyle = 0
  675.          lblDates(X).FontItalic = False
  676.       End If
  677.       
  678.       Next
  679.          'this is where you can format the date ,in label, to your needs.
  680.          StoreDate = Format(cboMonth.Text & "/" & CurDay & "/" & cboYear.Text, "dddd - mmmm dd, yyyy")
  681.          Value = StoreDate
  682.          If DateDisplay = True Then
  683.             lblDateBar.Caption = Value
  684.          Else
  685.             lblDateBar.Caption = "Calendar"
  686.         End If
  687.         
  688.    End Sub
  689.  
  690. Private Sub InitDates()
  691.    CurMonth = Month(Now)
  692.    CurYear = Year(Now)
  693.    CurDay = Day(Now)
  694.    
  695.    cboMonth.ListIndex = CurMonth - 1
  696.    FindYear CStr(CurYear)
  697.    HighLightDate
  698.    Value = StoreDate
  699.     If DateDisplay = True Then
  700.        lblDateBar.Caption = Value
  701.     Else
  702.        lblDateBar.Caption = "Calendar"
  703.     End If
  704. End Sub
  705.  
  706. Private Sub lblDates_Click(Index As Integer)
  707.    Dim tmpIndex As Integer
  708.    
  709.    CurDay = lblDates(Index).Caption
  710.    HighLightDate
  711.    
  712.     If DateDisplay = True Then
  713.        lblDateBar.Caption = Value
  714.     Else
  715.        lblDateBar.Caption = "Calendar"
  716.     End If
  717.     
  718.    'close calendar when date is clicked,uncomment to activate
  719.   ' AnimateForm Picture1, aUnload, eAppearFromBottom, 11, 33
  720.    'Label2.Caption = "Show"
  721.    'CC = True
  722.    
  723.    RaiseEvent Click
  724. End Sub
  725.  
  726. Private Sub ShowDates()
  727.    Dim StartDay As Single
  728.    Dim ctr As Single
  729.    Dim CheckDates As String
  730.    Dim DateCaption As Single
  731.    
  732.    On Error Resume Next
  733.    StartDay = Weekday(cboMonth.Text & "/1/" & cboYear.Text)
  734.    
  735.    For ctr = 0 To StartDay - 1
  736.       lblDates(ctr).Visible = False
  737.       Next
  738.       
  739.       For ctr = StartDay To 38
  740.          DateCaption = DateCaption + 1
  741.          CheckDates = Format(cboMonth & "/" & DateCaption & "/" & cboYear.Text, "Short Date")
  742.          If Not IsDate(CheckDates) Then
  743.             LastDay = lblDates(ctr - 1).Index
  744.             Exit For
  745.          End If
  746.          
  747.          If Weekday(CheckDates) = 1 Then
  748.             lblDates(ctr).ForeColor = &HFF&
  749.          End If
  750.          
  751.          If Weekday(CheckDates) = 7 Then
  752.             lblDates(ctr).ForeColor = &HC00000
  753.          End If
  754.          lblDates(ctr).Caption = DateCaption
  755.          
  756.          Next
  757.          
  758.          For ctr = DateCaption + StartDay - 1 To 38
  759.             lblDates(ctr).Visible = False
  760.             Next
  761.             
  762.          End Sub
  763.  
  764. Public Property Get Value() As String
  765.    Value = m_Value
  766. End Property
  767.  
  768. Public Property Let Value(ByVal New_Value As String)
  769.    m_Value = New_Value
  770.    PropertyChanged "Value"
  771. End Property
  772.  
  773. Public Property Get BackColor() As OLE_COLOR
  774.    BackColor = m_BackColor
  775. End Property
  776.  
  777. Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  778.    m_BackColor = New_BackColor
  779.    lblDateBar.BackColor = m_BackColor
  780.    Label2.BackColor = m_BackColor
  781.    Label1.BackColor = m_BackColor
  782.    PropertyChanged "BackColor"
  783. End Property
  784.  
  785. Public Property Get DateDisplay() As Boolean
  786.   DateDisplay = m_DateDisplay
  787. End Property
  788.  
  789. Public Property Let DateDisplay(ByVal New_DateDisplay As Boolean)
  790.    m_DateDisplay = New_DateDisplay
  791.     If DateDisplay = True Then
  792.         lblDateBar.Caption = Value
  793.     Else
  794.         lblDateBar.Caption = "Calendar"
  795.     End If
  796.    PropertyChanged "DateDisplay"
  797. End Property
  798.  
  799. Public Property Get SHButton() As Boolean
  800.    SHButton = m_SHButton
  801. End Property
  802.  
  803. Public Property Let SHButton(ByVal New_SHButton As Boolean)
  804.    m_SHButton = New_SHButton
  805.    If SHButton = True Then
  806.       Label2.Visible = True
  807.       lblDateBar.Width = 3015
  808.    Else
  809.       Label2.Visible = False
  810.       lblDateBar.Width = 3765
  811.    End If
  812.    PropertyChanged "SHButton"
  813. End Property
  814.  
  815. 'This Function code was written by Jim Jose
  816.  
  817. Private Function AnimateForm(hwndObject As Object, ByVal aEvent As AnimeEventEnum, _
  818.    Optional ByVal aEffect As AnimeEffectEnum = 11, _
  819.    Optional ByVal FrameTime As Long = 1, _
  820.    Optional ByVal FrameCount As Long = 33) As Boolean
  821.    On Error GoTo Handle
  822.    Dim X1 As Long, Y1 As Long
  823.    Dim hrgn As Long, tmpRgn As Long
  824.    Dim XValue As Long, YValue As Long
  825.    Dim XIncr As Double, YIncr As Double
  826.    Dim wHeight As Long, wWidth As Long
  827.    
  828.    wWidth = hwndObject.Width / Screen.TwipsPerPixelX
  829.    wHeight = hwndObject.Height / Screen.TwipsPerPixelY
  830.    hwndObject.Visible = True
  831.    
  832.    Select Case aEffect
  833.          
  834.       Case eAppearFromTop
  835.          
  836.          YIncr = (wHeight / FrameCount)
  837.          For Y1 = 0 To FrameCount
  838.             
  839.             ' Define the size of current frame/Create it
  840.             YValue = Y1 * YIncr
  841.             hrgn = CreateRectRgn(0, 0, wWidth, YValue)
  842.             UserControl.Height = 3300  'UserControl.Height + YValue
  843.             
  844.             ' If unload then take the reverse(anti) region
  845.             If aEvent = aUnload Then
  846.                tmpRgn = CreateRectRgn(0, 0, wWidth, wHeight)
  847.                CombineRgn hrgn, hrgn, tmpRgn, RGN_XOR
  848.                DeleteObject tmpRgn
  849.             End If
  850.             
  851.             ' Set the new region for the window
  852.             SetWindowRgn hwndObject.hWnd, hrgn, True:   DoEvents
  853.             Sleep FrameTime
  854.           
  855.          Next Y1
  856.          
  857.       Case eAppearFromBottom
  858.          
  859.          YIncr = wHeight / FrameCount
  860.          For Y1 = 0 To FrameCount
  861.             
  862.             ' Define the size of current frame/Create it
  863.             YValue = wHeight - Y1 * YIncr
  864.             hrgn = CreateRectRgn(0, YValue, wWidth, wHeight)
  865.             If UserControl.Height <= 330 Then GoTo Here
  866.             UserControl.Height = UserControl.Height - YValue
  867. Here:
  868.             ' If unload then take the reverse(anti) region
  869.             If aEvent = aUnload Then
  870.                tmpRgn = CreateRectRgn(0, 0, wWidth, wHeight)
  871.                CombineRgn hrgn, hrgn, tmpRgn, RGN_XOR
  872.                DeleteObject tmpRgn
  873.             End If
  874.             
  875.             ' Set the new region for the window
  876.             SetWindowRgn hwndObject.hWnd, hrgn, True: DoEvents
  877.             Sleep FrameTime
  878.            
  879.          Next Y1
  880.          
  881.    End Select
  882.    
  883.    AnimateForm = True
  884.    
  885.    Exit Function
  886. Handle:
  887.    AnimateForm = False
  888. End Function
  889.