圆形轮廓，Win2000下半透明，能定时闹铃，整点报时，不过功能不十分完善，没继续写了

[attach]58[/attach]

Option Explicit

Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Private Type POINTAPI x As Long y As Long End Type

Private Const SWP_NOSIZE = &H1 Private Const SWP_NOMOVE = &H2 Private Const HWND_TOPMOST = -1 Private Const HWND_NOTOPMOST = -2

Private OldX As Integer Private OldY As Integer Private MouseDown As Boolean

Const PI = 3.1415926 Dim BaseX As Integer, BaseY As Integer, R As Integer Dim r1 As Integer, r2 As Integer

Dim Out As Boolean

Private Sub Form_Load() Dim mRGN As Long Dim rtn As Long SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE BaoTime = True AppPath = IIf(Len(App.Path) = 3, App.Path, App.Path & "\") IniFile = AppPath & "config.ini" SoundFile = AppPath & "Ontime.wav" Call ReadIniSet TMNum = BaseTmNum If WinVer >= 5 Then rtn = GetWindowLong(hwnd, GWL_EXSTYLE) rtn = rtn Or WS_EX_LAYERED SetWindowLong hwnd, GWL_EXSTYLE, rtn SetLayeredWindowAttributes Me.hwnd, &H0, BaseTmNum, LWA_COLORKEY Or LWA_ALPHA '将扣去窗口中的蓝色 Else mRGN = CreateEllipticRgn(1, 1, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY) SetWindowRgn Me.hwnd, mRGN, True DeleteObject mRGN End If Label1.Move 0, 0, Me.Width, Me.Height lblTime = Time

BaseX = 885 BaseY = 885 R = 685 r1 = 160 r2 = 80 drawclock Timer2.Enabled = True End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) If OptionFormLoaded Then Unload frmSetup End If End Sub

Private Sub label1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) SubMouseUp End Sub

Private Sub label1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) SubMouseDown Button, x, y End Sub

Private Sub label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) SubMouseMove Button, x, y If Timer2.Enabled = False And TMNum = BaseTmNum Then Timer2.Enabled = True End If Out = False End Sub

Private Sub mnuExit_Click() Unload Me End Sub

Private Sub mnuHide_Click() If mnuHide.Caption = "显示(&H)" Then Me.Visible = True mnuHide.Caption = "隐藏(&H)" sysTrayOcx1.RemoveFromTray Else mnuHide.Caption = "显示(&H)" sysTrayOcx1.AddToTray Me Me.Visible = False End If End Sub

Private Sub mnuSetup_Click() frmSetup.Show End Sub

Private Sub sysTrayOcx1_DblClick(Button As Integer) Call mnuHide_Click End Sub

Private Sub sysTrayOcx1_MouseDown(Button As Integer) If Button = 2 Then PopupMenu mnuSystem End If End Sub

Private Sub Timer1_Timer() On Error Resume Next Dim NowTime As Date

NowTime = Time 'If OptionFormLoaded = True Then ' frmSetup.Text3.Text = Date & " " & NowTime 'End If Dim Pos1 As POINTAPI '检测鼠标移出窗体 If Out = False Then GetCursorPos Pos1 If Pos1.x < Me.Left / 15 Or Pos1.y < Me.Top / 15 Or Pos1.x > (Me.Left + Me.Width) / 15 Or Pos1.y > (Me.Top + Me.Height) / 15 Then Out = True Timer2.Enabled = True End If End If

Static Flag As Boolean '每隔Interval分钟提示 If Interval <> 0 Then If DateDiff("s", BeginTime, NowTime) >= Interval * 60 Then PlaySound SoundFile BeginTime = DateAdd("s", -DateDiff("s", BeginTime, NowTime) Mod (Interval * 60), NowTime) End If End If '整点报时 If BaoTime Then If DatePart("n", Time) = 0 And DatePart("s", Time) = 0 Then PlaySound AppPath & "Bigben.wav" End If End If

lblTime.Caption = NowTime Label1.ToolTipText = "当前时间:" & Format(Date, "yyyy年mm月dd日") & " " & Time If Me.Visible = False Then sysTrayOcx1.SetTrayTip Label1.ToolTipText End If

NowTime = Now Dim i As Integer '定点提示列表 For i = 0 To UBound(ActionArr) If Trim(ActionArr(i)) <> "" Then Debug.Print CDate(ActionArr(i)) & "=" & NowTime If CDate(ActionArr(i)) = NowTime Then PlaySound SoundFile ActionArr(i) = "" Call WriteAction ElseIf CDate(ActionArr(i)) < NowTime Then Debug.Print "时间己过！" ActionArr(i) = "" Call WriteAction End If End If Next Call drawclock End Sub

Private Sub WriteAction() Dim i As Integer Dim temp As String If OptionFormLoaded Then frmSetup.List1.Clear End If For i = 0 To UBound(ActionArr) If Trim(ActionArr(i)) <> "" Then temp = temp & ActionArr(i) & "|" If OptionFormLoaded Then frmSetup.List1.AddItem ActionArr(i) End If End If Next If Right(temp, 1) = "|" Then temp = Left(temp, Len(temp) - 1) End If ActionArr = Split(temp, "|") SetINIValue IniFile, "Option", "Action", temp End Sub

Private Sub SubMouseDown(Button As Integer, x As Single, y As Single) If Button = 1 Then MouseDown = True OldX = x OldY = y Else PopupMenu mnuSystem End If End Sub

Private Sub SubMouseMove(Button As Integer, x As Single, y As Single) If Not MouseDown Or Button <> 1 Then Exit Sub Me.Move Me.Left + (x - OldX), Me.Top + (y - OldY) End Sub

Private Sub drawclock() Dim Second As Integer Dim Minute As Integer Dim Hours As Integer

Second = DatePart("s", Time) Minute = DatePart("n", Time) Hours = DatePart("h", Time) If Hours > 12 Then Hours = Hours - 12 End If DrawLine BaseX - r1 * Sin(Second * PI / 30), BaseY + r1 * Cos(Second * PI / 30), BaseX + R * Sin(Second * PI / 30), BaseY - R * Cos(Second * PI / 30), 0 DrawLine BaseX - r2 * Sin(Minute * PI / 30), BaseY + r2 * Cos(Minute * PI / 30), BaseX + (R - 200) * Sin(Minute * PI / 30), BaseY - (R - 200) * Cos(Minute * PI / 30), 1 DrawLine BaseX - r2 * Sin((Hours + Minute / 60) * PI / 6), BaseY + r2 * Cos((Hours + Minute / 60) * PI / 6), BaseX + (R - 300) * Sin((Hours + Minute / 60) * PI / 6), BaseY - (R - 300) * Cos((Hours + Minute / 60) * PI / 6), 2 End Sub

Private Sub DrawLine(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, Flag As Integer) Select Case Flag Case 0 Line1.x1 = x1 Line1.x2 = x2 Line1.y1 = y1 Line1.y2 = y2 Case 1 Line2.x1 = x1 Line2.x2 = x2 Line2.y1 = y1 Line2.y2 = y2 Case 2 Line3.x1 = x1 Line3.x2 = x2 Line3.y1 = y1 Line3.y2 = y2 End Select End Sub

Private Sub SubMouseUp() MouseDown = False End Sub

Private Sub Timer2_Timer() If WinVer >= 5 Then Select Case Out Case False If TMNum < 255 Then TMNum = TMNum + 5 If TMNum > 255 Then TMNum = 255 SetLayeredWindowAttributes Me.hwnd, &H0, TMNum, LWA_COLORKEY Or LWA_ALPHA If TMNum = 255 Or TMNum + 5 > 255 Then Timer2.Enabled = False End If End If Case True If TMNum > BaseTmNum Then TMNum = TMNum - 5 If TMNum < 0 Then TMNum = 0 SetLayeredWindowAttributes Me.hwnd, &H0, TMNum, LWA_COLORKEY Or LWA_ALPHA If TMNum = BaseTmNum Or TMNum - 5 < BaseTmNum Then Timer2.Enabled = False End If End If End Select End If End Sub

Private Sub ReadIniSet() Dim temp As Variant temp = GetINISet(IniFile, "Option", "BaseTMNum")

If Trim(BaseTmNum) <> "" Then If IsNumeric(temp) Then If Val(temp) > 0 And Val(temp) <= 255 Then temp = Int(temp) End If End If End If If temp = "" Then BaseTmNum = 60 Else BaseTmNum = temp End If If CStr(GetINISet(IniFile, "Option", "Baotime")) = "0" Then BaoTime = False End If temp = GetINISet(IniFile, "Option", "Action") If temp <> "" Then ActionArr = Split(temp, "|") Else ReDim ActionArr(0) As String End If End Sub

[此贴子已经被作者于2004-06-01 16:51:57编辑过]

我的音乐播放模块(主窗体里的PlaySound函数就是在这里定义的）

模块中包含声卡检测/WAV/MP3/MID音乐播放

'Model process sound play Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long Public Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Declare Function mciSendCommand Lib "winmm.dll" Alias "mciSendCommandA" (ByVal wDeviceID As Long, ByVal uMessage As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Any) As Long Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Private Declare Function MessageBeep Lib "user32" (ByVal wType As Long) As Long

Const SND_ASYNC = &H1 Const SND_NODEFAULT = &H2

Public PlayError As Boolean

'测试是否安装了声卡 Public Function TestSound() As Boolean Dim Ret As Long Ret& = waveOutGetNumDevs If Ret > 0 Then TestSound = True Else TestSound = False End If 'TestSound = False End Function

'播放wav声音文件 Public Sub PlaySound(FileName As String, Optional Flag As Long = (SND_ASYNC Or SND_NODEFAULT)) Dim Ret As Long Ret = sndPlaySound(FileName, Flag) If Ret = 0 And Flag = (SND_ASYNC Or SND_NODEFAULT) Then 'MessageBeep 0 Beep End If End Sub

'播放音乐mp3,wav,mid等 Public Sub PlayMusic(FileName As String) Dim Buffer As String * 128 Dim Ret As Long Dim PlayStatus As String * 20 Dim ShortFileName As String mciExecute "close all" If Dir(FileName) = "" Then PlayError = True: Exit Sub ShortFileName = ShortName(FileName) mciSendString "open " & ShortFileName & " alias mp3", Buffer, Ret, 0 mciSendString "play mp3", Buffer, Ret, 0 PlayError = False End Sub

Public Sub StopMusic() Dim Buffer As String * 128 Dim Ret As Long mciSendString "stop mp3", Buffer, Ret, 0 End Sub

Public Function GetPlayMode() As String Dim Buffer As String * 128 Dim pos As Integer mciSendString "status mp3 mode", Buffer, 128, 0& pos = InStr(Buffer, Chr(0)) GetPlayMode = Left(Buffer, pos - 1) End Function

'从带路径文件名中提取文件名 Public Function GetFileNameNoPath(sFullPathFileName As String) As String Dim pos As Integer Dim DifFilename As String If sFullPathFileName = "" Then Exit Function DifFilename = StrReverse(sFullPathFileName) pos = InStr(1, DifFilename, "\") If pos <> -1 Then GetFileNameNoPath = Right(sFullPathFileName, pos - 1) Else GetFileNameNoPath = sFullPathFileName End If End Function

'得到文件短文件名 Function ShortName(LongPath As String) As String Dim ShortPath As String Dim pos As String Dim Ret As Long Const MAX_PATH = 260 If LongPath = "" Then Exit Function ShortPath = Space$(MAX_PATH) Ret& = GetShortPathName(LongPath, ShortPath, MAX_PATH) If Ret& Then pos = InStr(1, ShortPath, " ") ShortName = Left$(ShortPath, pos - 2) End If End Function

[此贴子已经被作者于2004-06-01 16:57:03编辑过]