frmmain.bas

一个clock的 vb 源码

Attribute VB_Name = "frmMain"
Option Explicit

'========================================================================================
'Alarm Clock 1.05
'版权所有(C) 2001-2002  江建及其两位女友
'=======================================================================================
'软件全 Win32API 编写决不含VB中的控件(这个程序写其来真的好烦)尤其是调试的时候 VB的 IDE
'环境很容易就崩溃了。有时真的不想写下去了，可我又不甘心。
'========================================================================================
'                                     ╭○╮●╭○╮
'　　　　　                        ☆  /█∨█∨█\  ☆
'                                       ∏  ∏  ∏
'※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※
'§                                                                                     §
'§                                                                                     §
'§                                                                                     §
'§                                     \\\ | | ///                                     §
'§                                     ( ^  8  ^ )                                     §
'§       ☆☆☆      ☆☆☆     ____________-____________     ☆☆☆      ☆☆☆       §
'§      ☆     ☆  ☆     ☆    |                       |    ☆     ☆  ☆     ☆      §
'§     ☆        ★        ☆   |      I Miss Yuan      |   ☆        ★        ☆     §
'§     ☆                  ☆   |    Yuan And Zou Nan   |   ☆                  ☆     §
'§      ☆                ☆    |_______________________|    ☆                ☆      §
'§        ☆            ☆         ○0o  |     |  o0○         ☆            ☆        §
'§         ☆          ☆            |   |     |   |            ☆          ☆         §
'§           ☆      ☆              |   |     |   |              ☆      ☆           §
'§             ☆  ☆                |___|     |___|                ☆  ☆             §
'§               ★                   |_|       |_|                   ★               §
'§                                   ○0Oo     ○0Oo                                   §
'§                                                                                     §
'§                                                                                     §
'§                                                                                     §
'※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※


'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 这里是主窗体
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

' Message
Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long

Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long)

Public Declare Function GlobalFindAtom Lib "kernel32" Alias "GlobalFindAtomA" (ByVal lpString As String) As Integer
Public Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
Public Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer


' Class Reg And Del
Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long

' Window Style
Private Const WS_EX_TOOLWINDOW = &H80


' WNDCLASSEX
Private Const CS_HREDRAW = &H2
Private Const CS_VREDRAW = &H1
Private Const CS_DBLCLKS = &H8

'=============================================
' Menu Type
Private Const MF_BITMAP = &H4&
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_OWNERDRAW = &H100&
Private Const MF_SEPARATOR = &H800&
Private Const MF_STRING = &H0&

Private Const MF_CHECKED = &H8&
Private Const MF_DISABLED = &H2&
Private Const MF_ENABLED = &H0&
Private Const MF_GRAYED = &H1&
Private Const MF_UNCHECKED = &H0&
'==============================================

' Window Color
Private Const COLOR_WINDOW = 5

' DefSystem Cursor
Private Const IDC_ARROW = 32512&

' Reg Window
Private Type WNDCLASSEX
    cbSize As Long
    Style As Long
    lpfnWndProc As Long
    cbClsExtra As Long
    cbWndExtra As Long
    hInstance As Long
    hIcon As Long
    hCursor As Long
    hbrBackground As Long
    lpszMenuName As String
    lpszClassName As String
    hIconSm As Long
End Type

Private Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    Times As Long
    pt As POINTAPI
End Type

Public Const SIZE_MAXSHOW = 3


Public hWndMain As Long
Public HourRing As Integer           ' 是否启用了正点报时
Public HourSoundFile As String       ' 正点报时声音文件

Private cRingData As Long            ' 闹玲项目记数器(DataCount)
Private UserRing As clsSaveRingData  ' 存储用户设置的闹玲以便在循环中判断是否到达了指定的时刻

Private Menu As New clsMenu  ' 创建菜单
Private I As Long, N As Long
Private Thread As New clsThread
Private DrawTime As New clsDrawTime
Private Tooltip As clsTooltip
Private strMenuText As String
    
'=-=-=-=-=-=-=-=-=-=-
Private Function RegClass(lpClassName As String) As Boolean
    ' 注册窗口类
    Dim WinClass As WNDCLASSEX
    With WinClass
        .Style = CS_HREDRAW Or CS_VREDRAW Or CS_DBLCLKS
        .lpszClassName = lpClassName
        .hInstance = App.hInstance
        .cbClsExtra = 0
        .cbWndExtra = 0
        .hIcon = LoadResImage(App.hInstance, 0, IMAGE_ICON, 0, 0, 0)
        .hCursor = LoadCursor(0, IDC_ARROW)
        .cbSize = Len(WinClass)
        .lpfnWndProc = FnPtrToLong(AddressOf MainWinProc)
        .lpszMenuName = 0
        .hbrBackground = COLOR_WINDOW
    End With
    RegClass = RegisterClassEx(WinClass)
End Function

Private Sub CreateWindow(lpClassName As String, Optional StyleEx As Long, Optional strTitle As String)
    Dim Reg As Long                   ' 创建程序主窗体
    Reg = RegClass(lpClassName)
    If Reg <> 0 Then
        hWndMain = CreateWindowEx(StyleEx Or WS_EX_TOOLWINDOW, lpClassName, strTitle, WS_POPUP Or WS_SYSMENU, 0, 0, 100, 100, 0, 0, App.hInstance, ByVal 0&)
       
            If hWndMain <> 0 Then
                Call UpdateWindow(hWndMain)
                Call SetTimer(hWndMain, 8, 1000, 0&)
                Call Clock_Load(hWndMain, "Windowpos")
                Call ClockRunMode(hWndMain)
                
                Dim lpMsg As MSG
                Do While GetMessage(lpMsg, 0, 0, 0)
                    TranslateMessage lpMsg
                    DispatchMessage lpMsg
                Loop
             End If
        UnregisterClass lpClassName, App.hInstance
    End If
End Sub

Private Function MainWinProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    ' 我还是喜欢这种编程方式
    Select Case uMsg
        Case WM_CREATE
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
            Clock_Load hwnd, "RndBackBmp"
            Clock_Load hwnd, "RndTimeBmp"
            
            AppInitialize hwnd
            SltBmphDc hwnd
            SetPosition hwnd
            SetWindowhRgn hwnd
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
            Dim hSubMenu1 As Long
            Dim hSubmenu2 As Long
            Menu.CreatePopMenu
            hSubMenu1 = Menu.CreatePopSubMenu
            hSubmenu2 = Menu.CreatePopSubMenu
            
            Menu.AddMenuItem 1, "闹钟最小化(&M)", MF_STRING
            Menu.AddMenuItem 2, vbNullString, MF_SEPARATOR
            Menu.AddMenuItem 3, "闹钟选项(&O)...", MF_STRING
            Menu.AddMenuItem 4, vbNullString, MF_SEPARATOR
            Menu.AddMenuItem 5, "外挂程序", MF_STRING, , True, hSubMenu1
            Menu.AddSubMenu "  无    ", 6, MF_STRING, , hSubMenu1
            Menu.AddMenuItem 7, "万年历(&W)...", MF_STRING
            Menu.AddMenuItem 8, vbNullString, MF_SEPARATOR
            Menu.AddMenuItem 9, "闹铃设置(&R)...", MF_STRING
            Menu.AddMenuItem 10, vbNullString, MF_SEPARATOR
            Menu.AddMenuItem 11, "时间设置(&S)...", MF_STRING
            Menu.AddMenuItem 12, vbNullString, MF_SEPARATOR
            Menu.AddMenuItem 13, "帮助(&H)", MF_STRING, , True, hSubmenu2
            Menu.AddSubMenu "帮助内容(&C)", 17, MF_STRING, , hSubmenu2
            Menu.AddSubMenu "写信给我(&E)", 18, MF_STRING, , hSubmenu2
            Menu.AddSubMenu "访问网站(&H)", 19, MF_STRING, , hSubmenu2
            Menu.AddMenuItem 14, "关于本程序(&A)...", MF_STRING Or MF_MENUBARBREAK
            Menu.AddMenuItem 15, vbNullString, MF_SEPARATOR
            Menu.AddMenuItem 16, "退出(&X)", MF_STRING Or MF_MENUBARBREAK
            Menu.OnCreate
            
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        '   整点报时
            Dim strHourRing As String
            strHourRing = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "HourRing")
            If strHourRing <> vbNullString And IsNumeric(strHourRing) Then
                HourRing = CInt(strHourRing)
            End If
            HourSoundFile = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "WavFile")
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
            UserRing_Load
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        '   为窗口添加 Tooltip 提示
            Set Tooltip = New clsTooltip
            Tooltip.CreateTooltip
            Tooltip.Tooltip_SetDelayTime
            Tooltip.Tooltip_SetMaxWidth
            Tooltip.AddTooltip "本软件出卖源代码每份拷贝 38 元" & vbCrLf & _
                               "当前日期：" & CStr(Date) & vbCrLf & "我正在上海寻找一份工作" & vbCrLf & "                                            --江建", hwnd
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
            SendStringMessage hwnd, WM_SETTEXT, 0, "Alarm Clock"
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        Case WM_DRAWITEM
            Menu.OnDrawItem lParam              ' 画菜单
        
        Case WM_MEASUREITEM
            Menu.OnMeasureItem hwnd, lParam     ' 设置菜单高度与宽度
        Case WM_RBUTTONUP: Menu.PopMenu hwnd    ' 弹出菜单
        
        Case WM_PAINT
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
            Dim hDcMain As Long
            Dim lpPaint As PAINTSTRUCT
            
            hDcMain = BeginPaint(hwnd, lpPaint)
                Call BitBlt(hDcMain, 0, 0, BmpObject.bmWidth, BmpObject.bmHeight, hDcMem, 0, 0, SRCCOPY)
                Call DrawTime.DrawTime(hDcMain, hDcMemt, Time)
            Call EndPaint(hwnd, lpPaint)
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        Case WM_LBUTTONDOWN
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        '   Move Window And UpdateWindow(移动并刷新窗体)
            Call UpdateWindow(hwnd)
            Call ReleaseCapture
            Call SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        Case WM_LBUTTONDBLCLK
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        '   最小化程序发送 SW_SHOWMINIMIZED (最小化)消息 引发（WM_SIZE 事件）
            Call ShowWindow(hwnd, SW_HIDE)
            Call ShowWindow(hwnd, SW_SHOWMINIMIZED)
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        Case WM_RBUTTONDBLCLK
           
        
        Case WM_MYNOTIFY
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        '   自定义消息（接受托盘事件）右键单击弹出菜单 左键双击恢复窗口
            Select Case lParam
                Case Is = WM_RBUTTONUP
                    Menu.PopMenu hwnd
                Case Is = WM_LBUTTONDBLCLK
                    SendMessage hwnd, WM_COMMAND, 0, ByVal 0
            End Select
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        Case WM_SIZE
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        '   每发送一个 消息
            Select Case wParam
                Case Is = SIZE_MINIMIZED
                    Call ShowWindow(hwnd, SW_HIDE)
                    Call AddTrayIcon(hwnd)
                    Call SendMessage(hwnd, WM_COMMAND, 1, 0)
                Case Else
                    Call DelTrayIcon
            End Select
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        Case WM_COMMAND
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        '   处理菜单消息 （wParam）没有按钮不用区分ID
            Select Case wParam
                Case Is = 0   '恢复窗口并设置菜单文字
                    Call Menu.SetMenuText(0, "闹钟最小化(&M)", 1)
                    Call ShowWindow(hwnd, SW_SHOWNORMAL)
                Case Is = 1   '最小画窗口并设置菜单文字
                    Call Menu.SetMenuText(0, "恢复闹钟(&M)", 0)
                    Call ShowWindow(hwnd, SW_HIDE)
                    Call ShowWindow(hwnd, SW_MINIMIZE)
                    Call ShowWindow(hwnd, SW_HIDE)
                Case Is = 3
                    Call CreateDlgOption(hwnd)
                Case Is = 7
                    Call CreateDlgCalendar(hwnd)
                Case Is = 9
                    Call CreateDlgSetRing(hwnd)
                Case Is = 11
                    Call CreateDlgSetSysTime(hwnd)
                Case Is = 14
                    Call CreateDlgAbout(hwnd)
                Case Is = 16
                    Call SendLongMessage(hwnd, WM_CLOSE, 0, 0)
                Case Is = 17
                    Call htmlhelp(hwnd, App.Path & "\Clock.CHM", 0, 0)
                Case Is = 18