dlgcalendar.bas

一个clock的 vb 源码

Attribute VB_Name = "DlgCalendar"
Option Explicit
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 这里是万年历对话框
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

'---------------------------------------------------------------------------------
' Up-Down Control
' Up-Down Control Notification Messages


Private Const UDN_FIRST = (0 - 721)        ' UpDown Control Notification Messages
Private Const UDN_DELTAPOS = (UDN_FIRST - 1) ' The UDN_DELTAPOS message is sent in
                                             ' the form of a WM_NOTIFY message.
                                             ' 这条消息以 WM_NOTIFY 形式发送
'---------------------------------------------------------------------------------

' DateTimePicker Control
' DateTimePicker Control Notification Messages
Private Const DTN_FIRST = (0 - 760)
Public Const DTN_DATETIMECHANGE = (DTN_FIRST + 1) ' 这条消息以 WM_NOTIFY 形式发送

' Date Time Picker  Message
Private Const DTM_FIRST = &H1000
Private Const DTM_SETSYSTEMTIME = (DTM_FIRST + 2) ' Set DT Select Date
'---------------------------------------------------------------------------------

' MonthCalendar Control
' MonthCalendar Control Notification Messages
Private Const MCN_FIRST = (0 - 750)
Private Const MCN_SELCHANGE = (MCN_FIRST + 1)

'Month Calendar Message
Private Const MCM_FIRST = &H1000              ' 月日历消息
Private Const MCM_SETCURSEL = (MCM_FIRST + 2) ' Set MC Select Date

'---------------------------------------------------------------------------------

' Edit Control
' Edit Control Notification Messages
Private Const EN_CHANGE = &H300  ' WM_COMMAND HIWord Notification Code

'---------------------------------------------------------------------------------

' Up Downd
Private Type NM_UPDOWN
    hdr As NMHDR
    iPos As Long
    iDelta As Long
End Type

' Date Time Picker
Private Type NMDATETIMECHANGE
    hdr As NMHDR
    dwFlags As Long
    St As SYSTEMTIME
End Type

' Month Calendar
Private Type NMSELCHANGE
    hdr As NMHDR
    stSelStart As SYSTEMTIME
    stSelEnd As SYSTEMTIME
End Type

Private Edit As clsEdit
Private Label As clsLabel
Private Button As clsButton
Private UpDown As clsUpDown
Private DTPicker As New clsDTPicker
Private DlgCalendar As New clsDialog
Private MonthCalendar As New clsMonthCalendar


Public Function CreateDlgCalendar(hWndParent As Long)
    Call DlgCalendar.CreateDialog(hWndParent, AddressOf DlgProc)
    Set DlgCalendar = Nothing
End Function

Private Function DlgProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   Static hFont As Long  ' GDI For Delete :)
   Select Case uMsg
        '------------------------------------
        ' Create All Control
        '------------------------------------
         Case WM_INITDIALOG
            Dim lpRect As RECT, hDesktop As Long
            hDesktop = GetDesktopWindow
            Call GetWindowRect(hDesktop, lpRect)
            Call MoveWindow(hWnd, (lpRect.Right - 316) / 2, (lpRect.Bottom - 335) / 2, 316, 335, 1)
            Call SendMessage(hWnd, WM_SETTEXT, 0, ByVal "万年历")
            
            hFont = CreateFont(12, 0, 0, 0, 400, 0, 0, 0, DEFAULT_CHARSET, _
            OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, _
            DEFAULT_PITCH Or FF_DONTCARE, "宋体")
            
            DTPicker.CreateDTPicker hWnd, 1, 21, 25, 115, 20, DTS_LONGDATEFORMAT Or DTS_UPDOWN
            Call SetFocus(DTPicker.hWnd(1))
            
            Set Edit = New clsEdit
            Edit.CreateEdit hWnd, 2, 205, 25, 64, 20, hFont, , 6
            Call Edit.SetEditText(hWnd, 2, "0")   ' 对话框句柄,控制ID,要设置的文字
       
            Set UpDown = New clsUpDown
            UpDown.CreateUpDown hWnd, 3
            UpDown.SetBuddy hWnd, 3, Edit.hWnd(0)
            
            Set Button = New clsButton
            Button.CreateButton hWnd, "确定(&O)", 4, 225, 276, 72, 21, hFont, BS_DEFPUSHBUTTON
            
            MonthCalendar.CreateMonthCalendar hWnd, 5
            
            Set Label = New clsLabel
            Label.CreateLabel hWnd, "当前日期", 22, 8, hFont
            Label.CreateLabel hWnd, "与今天相距", 140, 30, hFont
            Label.CreateLabel hWnd, "天", 274, 30, hFont
        Case WM_NOTIFY
            '------------------------------------------------------------------
            ' UpDown Notification Messages
            ' 当UpDown被按下(值改变)时设置 DateTimePicker 的日期
            
            Dim nmUpDown As NM_UPDOWN
            CopyMemory nmUpDown, ByVal lParam, Len(nmUpDown)
                If nmUpDown.hdr.code = UDN_DELTAPOS Then
                    If nmUpDown.iDelta = -1 Then
                        nmUpDown.iPos = (nmUpDown.iPos - 1)
                    Else
                        nmUpDown.iPos = (nmUpDown.iPos + 1)
                    End If
                    DTPicker.DateTime_SetSystemtime hWnd, 1, nmUpDown.iPos
                    MonthCalendar.MonthCal_SetCurSel hWnd, 5, nmUpDown.iPos
                End If
            '------------------------------------------------------------------------
            ' DateTime Picker Notification Messages
            ' 当 DateTimePicker 按下(值改变)时设置
            ' Month Calendar 的日期与 DateTimePicker 相同
            
            Dim nmDateChange As NMDATETIMECHANGE
            CopyMemory nmDateChange, ByVal lParam, Len(nmDateChange)
                If nmDateChange.hdr.code = DTN_DATETIMECHANGE Then
                    SendDlgItemMessageAny hWnd, 5, MCM_SETCURSEL, 0, nmDateChange.St
                    Call Edit.SetEditText(hWnd, 2, CStr(DateDiff("d", Date, DateSerial(nmDateChange.St.wYear, nmDateChange.St.wMonth, nmDateChange.St.wDay))))
                End If
            '------------------------------------------------------------------------
            ' MonthCalendar Control Notification Messages
            ' 当 Month Calendar 选者的日期改变时设置
            ' DateTimePicker 的日期与 Month Calendar 相同
             
             Dim nmSelChangeMC As NMSELCHANGE
             CopyMemory nmSelChangeMC, ByVal lParam, Len(nmSelChangeMC)
                If nmSelChangeMC.hdr.code = MCN_SELCHANGE Then
                    SendDlgItemMessageAny hWnd, 1, DTM_SETSYSTEMTIME, 1, nmSelChangeMC.stSelStart
                    Call Edit.SetEditText(hWnd, 2, CStr(DateDiff("d", Date, DateSerial(nmSelChangeMC.stSelStart.wYear, nmSelChangeMC.stSelStart.wMonth, nmSelChangeMC.stSelStart.wDay))))
                End If
            '------------------------------------------------------------------------
        Case WM_COMMAND
            '------------------------------------------------------------------------
            ' Edit 中的文本改变时设置 Date Time Picker 和 Month Calendar
            If HIWord(wParam) = EN_CHANGE And LoWord(wParam) = 2 Then
                If IsNumeric(Edit.Text(hWnd, 2)) Then
                    DTPicker.DateTime_SetSystemtime hWnd, 1, CLng(Edit.Text(hWnd, 2))
                    MonthCalendar.MonthCal_SetCurSel hWnd, 5, CLng(Edit.Text(hWnd, 2))
                End If
            End If
            '------------------------------------------------------------------------
            If wParam = 4 Then ' 关闭按钮
               Call SendMessage(hWnd, WM_CLOSE, 0, 0)
            End If
            
        Case WM_PAINT
            Dim lpPaint As PAINTSTRUCT, hDc As Long
            hDc = BeginPaint(hWnd, lpPaint)
                DrawFrame hDc, 10, 300, 12, 215
                DrawButton hDc, 224, 298, 275, 298
            Call EndPaint(hWnd, lpPaint)
            
        Case WM_CLOSE
            Set Edit = Nothing
            Set Label = Nothing
            Set Button = Nothing
            Set UpDown = Nothing
            Set DTPicker = Nothing
            Set MonthCalendar = Nothing
            Call DeleteObject(hFont)
            Call EndDialog(hWnd, 0)
    End Select
End Function