goldsealcalendar.ctl

一个日程管理和通讯录管理的软件

      Y1              =   330
      Y2              =   330
   End
   Begin VB.Line RowLine 
      Index           =   2
      X1              =   12
      X2              =   447
      Y1              =   258
      Y2              =   258
   End
   Begin VB.Line RowLine 
      Index           =   1
      X1              =   15
      X2              =   447
      Y1              =   183
      Y2              =   183
   End
   Begin VB.Line RowLine 
      Index           =   0
      X1              =   9
      X2              =   447
      Y1              =   108
      Y2              =   108
   End
   Begin VB.Line RightLine 
      BorderColor     =   &H00E0E0E0&
      X1              =   447
      X2              =   450
      Y1              =   417
      Y2              =   30
   End
   Begin VB.Line BottomLine 
      BorderColor     =   &H00FFFFFF&
      X1              =   15
      X2              =   459
      Y1              =   408
      Y2              =   405
   End
   Begin VB.Line LeftLine 
      BorderColor     =   &H00404040&
      X1              =   12
      X2              =   12
      Y1              =   30
      Y2              =   399
   End
   Begin VB.Line TopLine 
      X1              =   12
      X2              =   465
      Y1              =   9
      Y2              =   12
   End
End
Attribute VB_Name = "GScalendar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'缺省属性值:
Const m_def_CellWidth = 0
Const m_def_CellHeight = 0

Const m_def_Style = 0
'属性变量:
Dim m_CellWidth As Single
Dim m_CellHeight As Single
Public m_DayUnit As DayCell
Public Enum StyleType
    large
    small
End Enum

Dim m_Style As StyleType
Dim m_Now As Date
Dim m_Month As Integer
Dim m_Year As Integer
Dim m_Day As Integer
Dim strWeekday(6) As String
Dim pixelWidth As Single
Dim pixelHeight As Single
Dim lblIndex As Integer
'事件声明: 'MappingInfo=UserControl,UserControl,-1,Click
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
Attribute DblClick.VB_Description = "当用户在一个对象上按下并释放鼠标按钮后再次按下并释放鼠标按钮时发生。"
Event MonthChange()
Event DayChange()
Event YearChange()
Event RightClick()

Private Sub lblDay_Click(Index As Integer)
        lblDay(Index).BackColor = &HFF0000
        lblDay(Index).ForeColor = &HFFFFFF
        Day = Index + 1
End Sub

Private Sub lblDay_DblClick(Index As Integer)
    
    RaiseEvent DblClick
    
End Sub

Private Sub lblDay_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    lblDay_Click (Index)
    If Button = vbRightButton Then
        RaiseEvent RightClick
    End If
End Sub

Private Sub UserControl_Click()
    If Style = large Then
        lblDay_Click (lblIndex)
    End If
End Sub

Private Sub UserControl_DblClick()
    If Style = large Then
        lblDay_DblClick (lblIndex)
    End If
End Sub

Private Sub UserControl_Initialize()
    Set m_DayUnit = New DayCell
    m_Style = m_def_Style
    m_Now = VBA.Now()
    m_Month = VBA.Month(m_Now)
    m_Year = VBA.Year(m_Now)
    m_Day = VBA.Day(m_Now)
    strWeekday(0) = "星期日"
    strWeekday(1) = "星期一"
    strWeekday(2) = "星期二"
    strWeekday(3) = "星期三"
    strWeekday(4) = "星期四"
    strWeekday(5) = "星期五"
    strWeekday(6) = "星期六"
    
    pixelWidth = UserControl.ScaleX(1, 3, 1)
    pixelHeight = UserControl.ScaleY(1, 3, 1)
    UserControl.ScaleMode = 3
End Sub


Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Style = large Then
        For i = 1 To DayUnit.Count
            If X * pixelWidth >= DayUnit(i).Dleft And X * pixelWidth < DayUnit(i).Dleft + CellWidth And Y * pixelHeight >= DayUnit(i).Dtop And Y * pixelHeight < DayUnit(i).Dtop + CellHeight Then
                lblIndex = i - 1
            End If
        Next i
    End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Style = large Then
        lblDay_Click (lblIndex)
        If Button = vbRightButton Then
            RaiseEvent RightClick
        End If
    End If
End Sub

Private Sub UserControl_Resize()
    If Style = small Then
        For i = 0 To 5
            ColLine(i).Visible = False
        Next i
        For i = 0 To 4
            RowLine(i).Visible = False
        Next i
    End If
    Select Case m_Style
    Case large
        For i = 0 To 6
            NFButton1(i).Caption = strWeekday(i)
        Next i
    Case small
        For i = 0 To 6
            NFButton1(i).Caption = Right(strWeekday(i), 1)
        Next i
    End Select
    TopLine.X1 = 0
    TopLine.X2 = UserControl.ScaleWidth - TopLine.BorderWidth
    TopLine.Y1 = 0
    TopLine.Y2 = 0
    BottomLine.X1 = TopLine.BorderWidth
    BottomLine.X2 = UserControl.ScaleWidth
    BottomLine.Y1 = UserControl.ScaleHeight - TopLine.BorderWidth / 2
    BottomLine.Y2 = UserControl.ScaleHeight - TopLine.BorderWidth / 2
    LeftLine.X1 = 0
    LeftLine.X2 = 0
    LeftLine.Y1 = 0
    LeftLine.Y2 = UserControl.ScaleHeight
    RightLine.X1 = UserControl.ScaleWidth - TopLine.BorderWidth / 2
    RightLine.X2 = UserControl.ScaleWidth - TopLine.BorderWidth / 2
    RightLine.Y1 = 0
    RightLine.Y2 = UserControl.ScaleHeight
    For i = 0 To 6
        NFButton1(i).Width = (UserControl.ScaleWidth - TopLine.BorderWidth * 2) / 7
        NFButton1(i).Move TopLine.BorderWidth + i * NFButton1(i).Width, TopLine.BorderWidth
    Next i
    For i = 0 To 5
        ColLine(i).X1 = NFButton1(i + 1).Left - NFButton1(0).BorderWidth / 2
        ColLine(i).X2 = ColLine(i).X1
        ColLine(i).Y1 = TopLine.BorderWidth + NFButton1(0).Height
        ColLine(i).Y2 = UserControl.ScaleHeight - TopLine.BorderWidth
    Next i
    For i = 0 To 4
        RowLine(i).X1 = NFButton1(0).BorderWidth
        RowLine(i).X2 = UserControl.ScaleWidth - NFButton1(0).BorderWidth
        RowLine(i).Y1 = NFButton1(0).Height + TopLine.BorderWidth + (UserControl.ScaleHeight - NFButton1(0).Height - TopLine.BorderWidth * 2) / 6 * (i + 1)
        RowLine(i).Y2 = NFButton1(0).Height + TopLine.BorderWidth + (UserControl.ScaleHeight - NFButton1(0).Height - TopLine.BorderWidth * 2) / 6 * (i + 1)
    Next i
    m_CellWidth = (UserControl.ScaleWidth - RightLine.BorderWidth * 2 - ColLine(0).BorderWidth * 6) / 7
    m_CellHeight = (UserControl.ScaleHeight - NFButton1(0).Height - RightLine.BorderWidth * 2 - RowLine(0).BorderWidth * 5) / 6
    ChangeMonth Month
End Sub
'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "返回/设置对象中文本和图形的背景色。"
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    Dim i As Integer
    
    UserControl.BackColor() = New_BackColor
    For i = 0 To 30
        lblDay(i).BackColor() = New_BackColor
    Next i
    PropertyChanged "BackColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=14,0,0,0
Public Property Get Style() As StyleType
    Style = m_Style
End Property

Public Property Let Style(ByVal New_Style As StyleType)
    m_Style = New_Style
    PropertyChanged "Style"
    
    
        
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=3,0,0,0
Public Property Get Now() As Date
    Now = DateValue(m_Now)
End Property

Public Property Let Now(ByVal New_Now As Date)
    m_Now = New_Now
    PropertyChanged "Now"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get Month() As Integer
    Month = m_Month
End Property

Public Property Let Month(ByVal New_Month As Integer)
    m_Month = New_Month
    ChangeMonth New_Month
    PropertyChanged "Month"
    RaiseEvent MonthChange
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get Year() As Integer
    Year = m_Year
End Property

Public Property Let Year(ByVal New_Year As Integer)
    m_Year = New_Year
    PropertyChanged "Year"
    ChangeMonth Month
    RaiseEvent YearChange
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get Day() As Integer
    Day = m_Day
End Property

Public Property Let Day(ByVal New_Day As Integer)
    If Day <> New_Day Then
        lblDay(m_Day - 1).BackColor = BackColor
        lblDay(m_Day - 1).ForeColor = &H80000012
        m_Day = New_Day
        PropertyChanged "Day"
        RaiseEvent DayChange
    End If
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=14

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_CellWidth = m_def_CellWidth
    m_CellHeight = m_def_CellHeight
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    UserControl.BackColor = PropBag.ReadProperty("BackColor", &HFFFFFF)
    m_Style = PropBag.ReadProperty("Style", m_def_Style)
    m_Now = PropBag.ReadProperty("Now", m_Now)
    m_Month = PropBag.ReadProperty("Month", m_Month)
    m_Year = PropBag.ReadProperty("Year", m_Year)
    m_Day = PropBag.ReadProperty("Day", m_Day)
    m_CellWidth = PropBag.ReadProperty("CellWidth", m_CellWidth * pixelWidth)
    m_CellHeight = PropBag.ReadProperty("CellHeight", m_CellHeight * pixelHeight)
End Sub

Private Sub UserControl_Show()
    Dim i As Integer
    ChangeMonth Month
    For i = 0 To 30
        lblDay(i).BackColor() = BackColor
    Next i
    lblDay(Day - 1).ForeColor = &HFFFFFF
    lblDay(Day - 1).BackColor = &HFF0000
    Select Case m_Style
    Case large
        For i = 0 To 6
            NFButton1(i).Caption = strWeekday(i)
        Next i
    Case small
        For i = 0 To 6
            NFButton1(i).Caption = Right(strWeekday(i), 1)
        Next i
    End Select
    If Style = small Then
        For i = 0 To 5
            ColLine(i).Visible = False
        Next i
        For i = 0 To 4
            RowLine(i).Visible = False
        Next i
    End If
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &HFFFFFF)
    Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
    'Call PropBag.WriteProperty("Now", m_Now)
    'Call PropBag.WriteProperty("Month", m_Month)
    'Call PropBag.WriteProperty("Year", m_Year)
    'Call PropBag.WriteProperty("Day", m_Day)
    Call PropBag.WriteProperty("CellWidth", m_CellWidth)
    Call PropBag.WriteProperty("CellHeight", m_CellHeight)
End Sub



Private Sub ChangeMonth(Vmonth As Integer)
    Dim tmpDate As Date
    Dim intWeekDay As Integer
    Dim tmpDay As Integer
    Dim i As Integer
    Dim tmpLeft As Single
    Dim tmpTop As Single
    Dim tmpCount As Integer
   
    tmpDate = DateSerial(Year, Vmonth, 1)
    intWeekDay = Weekday(tmpDate)
    shpToday.Visible = False
    tmpCount = m_DayUnit.Count
    If tmpCount <> 0 Then
        For i = 1 To tmpCount
            m_DayUnit.Remove Trim(Str(i))
        Next i
        i = 0
    End If
    While tmpDate < DateSerial(Year, Vmonth + 1, 1)
        
        tmpDay = VBA.Day(tmpDate)
        If intWeekDay = 1 Then
            tmpLeft = LeftLine.BorderWidth
        Else
            tmpLeft = ColLine(intWeekDay - 2).X1 + 1
        End If
        If i = 0 Then
            tmpTop = TopLine.BorderWidth + NFButton1(0).Height
        Else
            tmpTop = RowLine(i - 1).Y1 + 1
        End If
        If Style = small Then tmpTop = tmpTop + (m_CellHeight - lblDay(0).Height) / 2
        Select Case Style
        Case large
            lblDay(tmpDay - 1).Move tmpLeft, tmpTop, m_CellWidth
        Case small
            lblDay(tmpDay - 1).Move tmpLeft, tmpTop, m_CellWidth
        End Select
        lblDay(tmpDay - 1).Caption = Trim(Str(tmpDay))
        m_DayUnit.Add tmpLeft * pixelWidth, (tmpTop + lblDay(0).Height) * pixelHeight, Trim(Str(tmpDay))
        lblDay(tmpDay - 1).Visible = True
        If tmpDate = DateValue(m_Now) Then
            If Style = large Then
                shpToday.Move m_DayUnit(tmpDay).Dleft / pixelWidth - 1, m_DayUnit(tmpDay).Dtop / pixelHeight - 1 - lblDay(0).Height, m_CellWidth + 2, m_CellHeight + 2
            Else
                shpToday.Move m_DayUnit(tmpDay).Dleft / pixelWidth - 1, m_DayUnit(tmpDay).Dtop / pixelHeight - 1 - lblDay(0).Height - (m_CellHeight - lblDay(0).Height) / 2, m_CellWidth + 2, m_CellHeight + 2
            End If
            shpToday.Visible = True
        End If
        tmpDate = tmpDate + 1
        intWeekDay = Weekday(tmpDate)
            
        If intWeekDay = 1 Then
            i = i + 1
        End If
    Wend
    For i = tmpDay To 30
        lblDay(i).Visible = False
    Next i
End Sub
'注意！不要删除或修改下列被注释的行！
'MemberInfo=14,1,2,0
Public Property Get DayUnit() As DayCell
    Set DayUnit = m_DayUnit
End Property

Public Property Let DayUnit(ByVal New_DayUnit As DayCell)
    If Ambient.UserMode = False Then Err.Raise 387
    If Ambient.UserMode Then Err.Raise 382
    Set m_DayUnit = New_DayUnit
    PropertyChanged "DayUnit"
End Property



'注意！不要删除或修改下列被注释的行！
'MemberInfo=12,1,1,0
Public Property Get CellWidth() As Single
    CellWidth = m_CellWidth * pixelWidth
End Property

Public Property Let CellWidth(ByVal New_CellWidth As Single)
    If Ambient.UserMode = False Then Err.Raise 387
    If Ambient.UserMode Then Err.Raise 382
    m_CellWidth = New_CellWidth
    PropertyChanged "CellWidth"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=12,1,1,0
Public Property Get CellHeight() As Single
    CellHeight = m_CellHeight * pixelHeight
End Property

Public Property Let CellHeight(ByVal New_CellHeight As Single)
    If Ambient.UserMode = False Then Err.Raise 387
    If Ambient.UserMode Then Err.Raise 382
    m_CellHeight = New_CellHeight
    PropertyChanged "CellHeight"
End Property