frmmain.bas

一个clock的 vb 源码

                    Call ShellExecute(0, "Open", "mailto:[e-mail]?Subject=诚邀加盟", 0, 0, 0)
                Case Is = 19
                     Call ShellExecute(0, "Open", "http://h.7i24.com/vbcc", 0, 0, 0)
            End Select
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        Case WM_TIMER
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=-=
        '    定时器每秒刷新指定的区域（InvalidateRect 会倒置一WM_PAINT 事件）
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
            Dim ReRect As RECT
            ReRect.Left = DrawTime.ReLeft
            ReRect.Right = DrawTime.ReLeft + 110
            ReRect.Top = DrawTime.ReTop
            ReRect.Bottom = DrawTime.ReTop + 25
            InvalidateRect hwnd, ReRect, 0
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
             HourPlaySound
             UserRingItem
        Case WM_CLOSE
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        '   退出前释放占用的资源
            Dim lpRect As RECT
            Call DelTrayIcon
            Set Menu = Nothing
            Set DrawTime = Nothing
            Set Thread = Nothing
             
            
            If IsIconic(hwnd) = False Then        '如果没有最小化变保存位置
                Call GetWindowRect(hWndMain, lpRect)
                Call CreateRegKey(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "ClockLeft", REG_SZ, lpRect.Left)
                Call CreateRegKey(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "ClockTop", REG_SZ, lpRect.Top)
            End If
            Call KillTimer(hwnd, 8)
            Call DestroyWindow(hWndMain)
        '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=
        Case WM_DESTROY
            Call PostQuitMessage(0)
    End Select
    MainWinProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End Function


Public Sub SetWindowhRgn(hwnd As Long)
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    '   Window 2000 新函数如果你要刷新窗口就不要用它来设置窗口的形状否则
    '   看看你的CPU占用
    Call SetWindowPos(hWndMain, HWND_TOPMOST, 0, 0, BmpObject.bmWidth, BmpObject.bmHeight, SWP_NOMOVE Or SWP_NOZORDER)
    If GetWindowsInfo Then      ' 设置窗体形状
        Dim bAlpha As String
        bAlpha = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "Alpha")
        
        If bAlpha <> vbNullString And IsNumeric(bAlpha) Then
            Call SetLayeredWindowAttributes(hwnd, 0, CLng(bAlpha), LWA_ALPHA)
        Else
            Call SetLayeredWindowAttributes(hwnd, 0, 188, LWA_ALPHA)
        End If
        SetfrmRgn hwnd, hDcMem, BmpObject.bmWidth, BmpObject.bmHeight
    Else
        SetfrmRgn hwnd, hDcMem, BmpObject.bmWidth, BmpObject.bmHeight
    End If
    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    ' 取贴图位置
    DrawTime.PaintTimePos hDcMem, BmpObject.bmWidth, BmpObject.bmHeight
    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
End Sub
Public Function Clock_Load(hwnd As Long, strRegKey As String)
    ' 根据 选项中 设置的值来运行程序
    Dim BackNumber As Long, TimeNumber As Long
    Dim strValue As String, ImgBack As String, ImgTime As String
    strValue = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Option", strRegKey)
    If strValue <> vbNullString And IsNumeric(strValue) Then
        If CLng(strValue) > 0 Then
            Select Case strRegKey
                Case Is = "Windowpos"           ' 将窗口置于最顶层
                    Call SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
                Case Is = "RndBackBmp"          ' 随机更换背景图片
                    AddRegFile
                    Randomize
                    BackNumber = (Int(I * Rnd) + 1)
                    ImgBack = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Clock Skin\BlackFile", CStr(BackNumber))
                    Call CreateRegKey(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "BmpBack", REG_SZ, ImgBack)
                    Call CreateRegKey(HKEY_CURRENT_USER, "Software\Alarm Clock\Option", "SelBackBmp", REG_DWORD, BackNumber)
                Case Is = "RndTimeBmp"          ' 随机更换时间图片
                    AddRegFile
                    Randomize
                    TimeNumber = (Int(N * Rnd) + 1)
                    ImgTime = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Clock Skin\TimeFile", CStr(TimeNumber))
                    Call CreateRegKey(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "BmpTime", REG_SZ, ImgTime)
                    Call CreateRegKey(HKEY_CURRENT_USER, "Software\Alarm Clock\Option", "SelTimeBmp", REG_DWORD, TimeNumber)
            End Select
        End If
    End If
End Function

Private Function ClockRunMode(hWindow As Long)
    ' 判定程序的运行方式
    Dim strValue As String
    strValue = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Option", "IconRun")
    On Error GoTo RunModeErr
        If CLng(strValue) > 0 Then
            Call ShowWindow(hWindow, SW_MINIMIZE)
        Else
            Call ShowWindow(hWindow, SW_SHOWNORMAL)
        End If
    Exit Function
RunModeErr:
    Call ShowWindow(hWindow, SW_SHOWNORMAL)
    Exit Function
End Function

Private Function AddRegFile()
    ' 查找符合条件的图片文件并将文件名添加进 Combobox
    ' 并写入注册表
    Dim MyFile As String

    Dim BmpType As BITMAP, hBmp As Long
    '--------------------------------------------------------------------------------
    Dim StrPath As String
    StrPath = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Option", "SkinPath")
    
    MyFile = Dir(StrPath & "\*.bmp", vbHidden Or vbNormal Or vbSystem)
        Do While MyFile <> ""
            hBmp = LoadImage(0, StrPath & "\" & MyFile, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
            Call GetObjects(hBmp, Len(BmpType), BmpType)
                If BmpType.bmWidth < 201 And BmpType.bmWidth > 109 And BmpType.bmHeight < 201 And BmpType.bmHeight > 25 Then
                    I = I + 1
                    Call CreateRegKey(HKEY_CURRENT_USER, "Software\Alarm Clock\Clock Skin\BlackFile", CStr(I), REG_SZ, MyFile)
                End If
                If BmpType.bmWidth = 180 And BmpType.bmHeight = 25 Then
                    N = N + 1
                    Call CreateRegKey(HKEY_CURRENT_USER, "Software\Alarm Clock\Clock Skin\TimeFile", CStr(N), REG_SZ, MyFile)
                End If
            Call DeleteObject(hBmp)
            MyFile = Dir   ' 第二次调用查找下一个文件。
        Loop
    '--------------------------------------------------------------------------------
End Function

Private Function HourPlaySound() As Long
    ' 正点报时（由于MCI播放MID窗体会停止刷新故启动另一线程）
    If HourRing <> 0 And Right$(Time, 5) = "00:00" Then
        If waveOutGetNumDevs > 0 And midiOutGetNumDevs > 0 Then
            Call Thread.CreateNewThread(AddressOf PlayRingSound)
        Else
            Call Thread.CreateNewThread(AddressOf BugleSound)
        End If
  End If
End Function

Private Function PlayRingSound() As Long
    ' 正点报时
    Dim SoundMem() As Byte
    If HourSoundFile <> vbNullString Then
        If Right$(HourSoundFile, 3) <> "wav" Then
            Call mciExecute("play " & HourSoundFile)
        Else
            Call PlaySound(HourSoundFile, 0, SND_FILENAME Or SND_ASYNC)
        End If
    Else
        SoundMem = LoadResData(10, "RING_SOUND")
        Call PlayMemSound(SoundMem(0), 0, SND_MEMORY Or SND_ASYNC)
        ReDim SoundMem(0)
    End If
End Function

Public Function UserRing_Load() As Long
    Dim I As Long, lpByte() As Byte             ' (二进制表示法 XX XX XX 分别为)
    Dim nText() As String, rText() As String
    Dim wText() As String, pText() As String
    On Error GoTo Errors
    
    If Not UserRing Is Nothing Then
        Set UserRing = Nothing
    End If
    
    Set UserRing = New clsSaveRingData
    
    cRingData = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Data", "DataCount")

    ReDim nText(cRingData): ReDim wText(cRingData)
    ReDim rText(cRingData): ReDim pText(cRingData)
    For I = 1 To cRingData
        lpByte = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Data", CStr("Data" & I))
        nText(I) = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Data", CStr("Text" & I))
        rText(I) = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Data", CStr("RunExe" & I))
        wText(I) = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Data", CStr("WavFile" & I))
        pText(I) = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Data", CStr("Parameters" & I))
        '----------------------------------------------------------------------------------

            ' 从注册表读入集合
            Call UserRing.lngSaveItemState(CLng(lpByte(0)))
            Call UserRing.lngSaveRingMode(CLng(lpByte(1)), CLng(lpByte(2)), CLng(lpByte(10)))
            Call UserRing.lngSaveRingTime(CLng(lpByte(3)), CLng(lpByte(4)), CLng(lpByte(5)))
         
            Call UserRing.lngSaveRingDate(CLng(lpByte(6)), CLng(lpByte(7)), CLng(lpByte(8)), CLng(lpByte(9)))
            Call UserRing.strSaveRingData(nText(I), rText(I), wText(I), pText(I))
    Next

        Exit Function
Errors:
        cRingData = 0
        Exit Function
End Function



Private Function UserRingItem() As Long
    'On Error Resume Next
    Dim X As Long
    Dim uRingDate As Date
    Dim uRingTime As Date
    
    If cRingData > 0 Then
        For X = 1 To cRingData
            If UserRing.GetItemState(X) > 0 Then   ' 判断ListView项目的状态(闹玲是否启动)
                uRingTime = TimeSerial(CInt(UserRing.GetwHour(X)), CInt(UserRing.GetwMinute(X)), 0)
                uRingDate = DateSerial(CInt(UserRing.GetwYear(X)), CInt(UserRing.GetwMonth(X)), CInt(UserRing.GetwDay(X)))
                    If uRingTime = Time Then
                        Select Case UserRing.GetTimeMode(X)
                            Case Is = 1     ' 仅此一次
                                If uRingDate = Date And uRingTime = Time Then
                                    Call UserRingMode(X)   '闹铃方式（模式）
                                End If
                            Case Is = 2     ' 每天同一时间
                                Call UserRingMode(X)       '闹铃方式（模式）
                            Case Is = 3     ' 每周同一时间
                                If UserRing.GetwDayWeek(X) = (Weekday(Date) - 1) Then
                                    Call UserRingMode(X)   '闹铃方式（模式）
                                End If
                            Case Is = 4     ' 每月同一时间
                                If UserRing.GetwDay(X) = Day(Date) Then
                                    Call UserRingMode(X)   '闹铃方式（模式）
                                End If
                            Case Is = 5     ' 每年同一时间
                                If UserRing.GetwMonth(X) = Month(Date) And UserRing.GetwDay(X) = Day(Date) Then
                                    Call UserRingMode(X)   '闹铃方式（模式）
                                End If
                        End Select
                    End If
            End If
        Next
    End If
End Function
            
Private Function UserRingMode(Index As Long) As Long
    Dim strRingWav As String
    Dim SoundMem() As Byte
    Dim strExeName As String
    Select Case UserRing.GetNotifyMode(Index)
        Case Is = 0     ' 声音提示(0)
            strRingWav = UserRing.GetWavFile(Index)
            If strRingWav <> vbNullString Then
                Call PlaySound(strRingWav, 0, SND_FILENAME Or SND_ASYNC)
            Else
                SoundMem = LoadResData(10, "RING_SOUND")
                Call PlayMemSound(SoundMem(0), 0, SND_MEMORY Or SND_ASYNC)
                ReDim SoundMem(0)
            End If
        Case Is = 1     ' 文字提示
                strRemindText = UserRing.GetNotifyText(Index)
                Call CreateDlgRemindText(hWndMain)
        Case Is = 2     ' 运行指定程序(2)
            strExeName = UserRing.GetRunExe(Index)
            If strExeName <> vbNullString Then
                ShellExecute 0, "Open", GetFileName(strExeName), UserRing.GetParameters(Index), GetFilePath(strExeName), SW_SHOW
            End If
        Case Is = 3     ' 重新启动计算机(3)
            startAfresh = True
            If UserRing.GetNotifyText(Index) <> vbNullString Then
                strExitNotifyText = UserRing.GetNotifyText(Index)
            End If
            Call CreateDlgWinExit(hWndMain)
        Case Is = 4     ' 关闭计算机(4)
            startAfresh = False
            If UserRing.GetNotifyText(Index) <> vbNullString Then
                strExitNotifyText = UserRing.GetNotifyText(Index)
            End If
            Call CreateDlgWinExit(hWndMain)
    End Select
End Function
  
Public Sub Main()
     'VB 可以用 App.PrevInstance 我们使用 API FindWindow 也可以使用互斥
     '我用试过添加原子的方法来防止程序的多个实例被运行
     '如过用户非正常关闭会出错。因为退出时必须删除原子。
    Dim hWndClock As Long
    hWndClock = FindWindow("frmMain", "Alarm Clock")
        If hWndClock <> 0 Then
            Call ShowWindow(hWndClock, SW_SHOWNORMAL)
            Exit Sub
        Else
            If GetWindowsInfo Then
                ' Windows 2000 和 Windows XP 创建具有透明效果的窗体。
                CreateWindow "frmMain", WS_EX_LAYERED
            Else
                CreateWindow "frmMain"
            End If
        End If
End Sub

Public Sub SendMsgRestore()
    Call SendMessage(hWndMain, WM_COMMAND, 0, 0)
End Sub
'If UserRing.GetNotifyText(Index) <> vbNullString Then:
'If HourSoundFile <> vbNullString Then   本函数工作正常
  '     Dim lpMCIOpen As MCI_OPEN_PARMS
    '   Dim lpMCIPlay As MCI_PLAY_PARMS
    '  If Right$(HourSoundFile, 3) <> "Wav" Then
        'lpMCIOpen.wDeviceID = MCI_DEVTYPE_SEQUENCER
        'lpMCIOpen.lpstrElementName = "MciFileName"
     '   Call mciSendCommand(0, MCI_OPEN, MCI_OPEN_TYPE Or MCI_OPEN_ELEMENT, lpMCIOpen)
      '  Call mciSendCommand(1, MCI_PLAY, 0, lpMCIPlay)
       'Else
         '   PlaySound MciFileName, 0, SND_FILENAME
    'End If