源码如下： '//////////////////////////////// ' '闹钟程序，作者：griefforyou ' '//////////////////////////////// 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 mRGN = CreateEllipticRgn(1, 1, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY) SetWindowRgn Me.hwnd, mRGN, True DeleteObject mRGN Label1.Move 0, 0, Me.Width, Me.Height lblTime = Time

BaseX = 885 BaseY = 885 R = 685 r1 = 160 r2 = 80 drawclock 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 mnuExit_Click() Unload Me End Sub

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

NowTime = Time

lblTime.Caption = NowTime Label1.ToolTipText = "当前时间:" & Format(Date, "yyyy年mm月dd日") & " " & Time NowTime = Now

Call drawclock 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 Out = False 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 SubMouseDown(Button As Integer, x As Single, y As Single) If Button = 1 Then MouseDown = True OldX = x OldY = y Else PopupMenu mnuPopup End If End Sub

Private Sub SubMouseUp() MouseDown = False End Sub 打包下载工程窗体源文件：

XLAoUje3.rar (42.71 KB) HELP！谁会做时钟？

[此贴子已经被作者于2005-3-11 9:49:15编辑过]