coolmenu.bas

一个clock的 vb 源码

Attribute VB_Name = "DlgSetSysTime"
Option Explicit

'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 这里是系统时间设置对话框
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

' Date Time Picker Message
Private Const DTM_SETSYSTEMTIME = (&H1000 + 2) ' Set DT Select Date
Public Const DTM_GETSYSTEMTIME = (&H1000 + 1) ' Get DateTimePicker Date Time

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

Private hFont As Long
Private Label As clsLabel
Private Button As clsButton
Private DTPicker As clsDTPicker
Private SetSysTime As New clsDialog

Public Function CreateDlgSetSysTime(hWndParent As Long)
    Call SetSysTime.CreateDialog(hWndParent, AddressOf DlgProc)
    Set SetSysTime = Nothing
    hFont = 0
End Function

Private Function DlgProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   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 - 265) / 2, (lpRect.Bottom - 120) / 2, 265, 120, 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, "宋体")
            
            Set Button = New clsButton
            Button.CreateButton hWnd, "确定(&O)", 1, 15, 67, 70, 20, hFont, WS_GROUP Or BS_DEFPUSHBUTTON
            Button.CreateButton hWnd, "应用(&A)", 2, 95, 67, 70, 20, hFont, WS_DISABLED
            Button.CreateButton hWnd, "取消(&C)", 3, 175, 67, 70, 20, hFont
            
            Set DTPicker = New clsDTPicker
            DTPicker.CreateDTPicker hWnd, 4, 22, 25, 118, 20, DTS_LONGDATEFORMAT Or WS_GROUP
            Call SetFocus(DTPicker.hWnd(4))
            DTPicker.CreateDTPicker hWnd, 5, 153, 25, 85, 20, DTS_TIMEFORMAT
            
            Set Label = New clsLabel
            Label.CreateLabel hWnd, "日期与时间", 21, 6, hFont
            
            ' 开始定时器
            Call SetTimer(hWnd, 6, 800, 0&)
        Case WM_NOTIFY
            '------------------------------------------------------------------------
            ' DateTime Picker Notification Messages
            ' 当 DateTimePicker 按下(值改变)时设置
            ' 使按钮不接受用户输入。
            ' 清除定时器
            
            Dim nmDateChange As NMDATETIMECHANGE
            CopyMemory nmDateChange, ByVal lParam, Len(nmDateChange)
                If nmDateChange.hdr.code = DTN_DATETIMECHANGE Then
                    EnableWindow Button.hWnd(1), True
                    KillTimer hWnd, 6
                End If
            '------------------------------------------------------------------------
        Case WM_COMMAND
            Select Case wParam  ' 因为没有菜单不用区分ID
                Case 1  ' 确定按钮
                    Call SendLongMessage(hWnd, WM_COMMAND, 2, 0)
                    Call SendLongMessage(hWnd, WM_COMMAND, 3, 0)
                Case 2  ' 应用按钮
                    Dim lpDate As SYSTEMTIME
                    Dim lpTime As SYSTEMTIME
                    
                    SendDlgItemMessageAny hWnd, 4, DTM_GETSYSTEMTIME, 0, lpDate
                    SendDlgItemMessageAny hWnd, 5, DTM_GETSYSTEMTIME, 0, lpTime
                    
                    lpTime.wYear = lpDate.wYear
                    lpTime.wMonth = lpDate.wMonth
                    lpTime.wDay = lpDate.wDay
                    SetLocalTime lpTime

                    Call EnableWindow(Button.hWnd(1), False)
                    Call SetTimer(hWnd, 6, 600, 0&)
                Case 3 ' 取消按钮
                    Call SendLongMessage(hWnd, WM_CLOSE, 0, 0)
            End Select
        Case WM_TIMER
            '----------------------------------------------------------------------
            ' 取当前系统时间
            ' 更新 Date Time Picker 日期和时间
            
            Dim lpSystemTime As SYSTEMTIME
                Call GetLocalTime(lpSystemTime)
                SendDlgItemMessageAny hWnd, 4, DTM_SETSYSTEMTIME, 0, lpSystemTime
                SendDlgItemMessageAny hWnd, 5, DTM_SETSYSTEMTIME, 0, lpSystemTime
            '----------------------------------------------------------------------
        Case WM_PAINT
            Dim lpPaint As PAINTSTRUCT, hdc As Long
            hdc = BeginPaint(hWnd, lpPaint)
                DrawFrame hdc, 10, 250, 10, 58
                DrawButton hdc, 14, 86, 66, 88
                DrawButton hdc, 94, 166, 66, 88
                DrawButton hdc, 174, 246, 66, 88
            Call EndPaint(hWnd, lpPaint)
        Case WM_CLOSE
            Set Label = Nothing
            Set Button = Nothing
            Set DTPicker = Nothing
            Call KillTimer(hWnd, 6)
            Call DeleteObject(hFont)
            Call EndDialog(hWnd, 0)
    End Select
End Function