bkgrd.frm

一款漂亮的闹钟制作界面,希望能给你们带来帮助.

VERSION 5.00
Begin VB.Form frmMain 
   AutoRedraw      =   -1  'True
   BorderStyle     =   0  'None
   ClientHeight    =   1440
   ClientLeft      =   2.45745e5
   ClientTop       =   2.45745e5
   ClientWidth     =   1440
   Icon            =   "bkgrd.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   Picture         =   "bkgrd.frx":000C
   ScaleHeight     =   96
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   96
   ShowInTaskbar   =   0   'False
   Visible         =   0   'False
   Begin VB.Timer Timer1 
      Interval        =   500
      Left            =   720
      Top             =   840
   End
   Begin VB.Shape Shape1 
      BorderColor     =   &H00FFFFFF&
      Height          =   1440
      Left            =   0
      Top             =   0
      Width           =   1440
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "载入背景图像错误!"
      ForeColor       =   &H00FFFFFF&
      Height          =   360
      Left            =   165
      TabIndex        =   0
      Top             =   240
      Visible         =   0   'False
      Width           =   1080
   End
   Begin VB.Line Line1 
      BorderColor     =   &H00000000&
      Index           =   0
      X1              =   40
      X2              =   96
      Y1              =   32
      Y2              =   56
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Const PI = 3.141592653
Sub TM(how As Integer)
On Error Resume Next
If how = 0 Then Exit Sub
Dim R As Long
R = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
R = R Or WS_EX_LAYERED
SetWindowLong Me.hwnd, GWL_EXSTYLE, R
SetLayeredWindowAttributes Me.hwnd, 0, how, LWA_ALPHA
Me.Refresh
End Sub ' wssccc's qq  151884336

Private Sub exit_Click()
Unload Me
End Sub ' wssccc's qq  151884336

Sub RefreshA()
i = 0
Unload frmMenu
Form_Load
End Sub ' wssccc's qq  151884336

Private Sub Form_Click()
Knew = True
End Sub ' wssccc's qq  151884336

Private Sub Form_DblClick()
frmAlarmSet.Show
frmAlarmSet.WindowState = 0
End Sub ' wssccc's qq  151884336

Private Sub Form_Load()
If App.PrevInstance = True Then MsgBox "程序已经在运行了", vbInformation, "提示": End
Label1.Visible = False
LoadSettings

frmMenu.Show
frmMenu.Move 111111, 111111
On Error Resume Next
Me.Top = frmTop
Me.Left = frmleft
TM 1
frmMenu.Timer1.Enabled = True
Dim i, Ang
For i = 0 To 14
If i > 0 Then Load Line1(i)
Line1(i).Visible = True
Next i
For i = 0 To 14
Scale (-1, 1)-(1, -1)
Ang = i * 2 * PI / 12
Line1(i).X1 = 0.9 * Cos(Ang)
Line1(i).Y1 = 0.9 * Sin(Ang)
Line1(i).X2 = Cos(Ang)
Line1(i).Y2 = Sin(Ang)
Next i
For i = 0 To 14
Line1(i).BorderWidth = 2
Line1(i).BorderColor = Ks
Next i

Line1(0).BorderWidth = 3
Line1(13).BorderWidth = 2
Line1(14).BorderWidth = 1

Line1(0).BorderColor = Hline
Line1(13).BorderColor = Mline
Line1(14).BorderColor = Sline

Timer1_Timer
If BkPic <> "" Then
On Error GoTo E
Me.Picture = LoadPicture(BkPic)
End If

E:
If InStr(Error, "文件未找到") <> 0 Then Label1.Visible = True
End Sub ' wssccc's qq  151884336

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If CanMove = True Then
ReleaseCapture
SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MOVE + HTCAPTION, 0
End If
End Sub ' wssccc's qq  151884336

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
PopupMenu frmMenu.m_pop
End If
End Sub ' wssccc's qq  151884336


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = 1
SaveSettings
TrayIcon.DelIcon
frmMenu.Timer2.Enabled = True
End Sub ' wssccc's qq  151884336

Private Sub Form_Resize()
If Me.WindowState = 1 Then Me.WindowState = 2: Me.WindowState = 0
End Sub ' wssccc's qq  151884336

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If CanMove = True Then
ReleaseCapture
SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MOVE + HTCAPTION, 0
End If
End Sub ' wssccc's qq  151884336

Private Sub Timer1_Timer()
On Error Resume Next
CheckAlm
Dim Ang
If Hour(Now) < 12 Then                                                   '时针刷新
Ang = PI / 2 + Hour(Now) * PI / 6 + Minute(Now) * PI / (6 * 60)
Else
Ang = PI / 2 + (Hour(Now) - 12) * PI / 6 + Minute(Now) * PI / (6 * 60)
End If
Line1(0).X1 = 0
Line1(0).Y1 = 0
Line1(0).X2 = -0.4 * Cos(Ang)
Line1(0).Y2 = 0.4 * Sin(Ang)
Ang = PI / 2 + Minute(Now) * PI / 30 + Second(Now) * PI / (30 * 60)      '分针刷新
Line1(13).X1 = 0
Line1(13).Y1 = 0
Line1(13).X2 = -0.7 * Cos(Ang)
Line1(13).Y2 = 0.7 * Sin(Ang)
Ang = PI / 2 + Second(Now) * PI / 30                                      '秒针刷新
Line1(14).X1 = 0
Line1(14).Y1 = 0
Line1(14).X2 = -0.8 * Cos(Ang)
Line1(14).Y2 = 0.8 * Sin(Ang)
Me.Refresh
End Sub ' wssccc's qq  151884336