致新手：用VB6解决一些有趣的问题（六）

画好你自己的三角形了吗?

估计有人想给定点标上字母 什么的了,哎,人的欲望是无限的

三角也给人无限的遐想,这世界总是那么多圆圆角角!

下面我们来个更高级一点的,我们要设计一个时钟,可不是数字哦

有时针分针秒针,这个资源也可以在我的下载那里下载到的

为了新手,为了更有经济实力的人进入程序开发的世界,分是不要的

我们的时钟挂在桌面,要不影响其他程序,不能让他们失去焦点

时钟的来历还很特别,前段时间想起了5年前高二的时候研究相对论,很喜欢

洛伦茨变换,想想能做什么呢?对了时针的旋转不也是变换了坐标吗?

可以后来的时间告诉我,洛伦茨用代码设计麻烦很多

至于怎么实现这个过程,文字很有限了,打字也痛苦

如果你能理解前面五篇<致新手> 那么下面的代码就不用我解释了:

用到一个背景图片

起初把蓝色部分设为透明,然而VB转为位图后跟背景的融合度实在恶心

后来就这样,其实无论怎么样都可以的,我们要的是时钟的界面

窗体frmMain

背景 图片,图标

BorderStyle 为0

一个Timer:tmrTime InterVal = 1000

一个Label:lblTime BackStyle = 0,ForeColor=RGB(255,0,255)

三条Line :lnHour,lnMinute,lnSecond 颜色自定

Option Explicit Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Type POINT X As Integer Y As Integer End Type Const LWA_COLORKEY = &H1 Const LWA_ALPHA = &H2 Const GWL_EXSTYLE = (-20) Const WS_EX_LAYERED = &H80000 Const WS_EX_TRANSPARENT As Long = &H20& Const PI = 3.14159265358979 Private pSecond As POINT Private pMinute As POINT Private pHour As POINT Private Sub Form_Load() If App.PrevInstance Then End 'msgbox "重复运行!" Dim i As Integer, j As Integer App.TaskVisible = False Me.Left = Screen.Width - Me.Width - Screen.TwipsPerPixelX * 10 Me.Top = Screen.TwipsPerPixelY * 10 Me.Refresh '用在最前 'SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3 'If Dir(App.Path & "/Init.ini") = "" Then Dim Ret As Long Ret = GetWindowLong(Me.hwnd, GWL_EXSTYLE) Ret = Ret Or WS_EX_LAYERED Or WS_EX_TRANSPARENT '透明(度)和不接受焦点 SetWindowLong Me.hwnd, GWL_EXSTYLE, Ret 'SetLayeredWindowAttributes Me.hwnd, 0, 255, LWA_ALPHA SetLayeredWindowAttributes Me.hwnd, vbBlue, 210, LWA_COLORKEY Or LWA_ALPHA 'Shape1.BorderColor = RGB(25, 67, 65) lblTime.Caption = CStr(Time) Ticket Time End Sub Private Sub tmrTime_Timer() Static t As Variant t = Time lblTime.Caption = CStr(t) '(68,68):(0,0) '秒针 (68,72) -> (68,16):(0,-4) -> (0,52) '分针 (68,72) -> (68,32):(0,-4) -> (0,36) '秒针 (68,72) -> (68,48):(0,-4) -> (0,20) Ticket t End Sub Private Sub Ticket(ByVal t As Variant) Static h As Long, m As Long, s As Long Static d(1 To 3) As Double s = Second(t) m = Minute(t) * 60 + s h = (Hour(t) Mod 12) * 3600 + m 'd(1) = (43200 - h) * PI / 21600 'd(2) = (3600 - m) * PI / 1800 'd(3) = (60 - s) * PI / 30 d(1) = (21600 - h) * PI / 21600 d(2) = (1800 - m) * PI / 1800 d(3) = (30 - s) * PI / 30 '洛伦茨变换,转过某一角度后的坐标 '... '圆周旋转变换:X=X0+Rsina;Y=Rcosa pHour.X = CInt(20 * Sin(d(1))) pHour.Y = CInt(20 * Cos(d(1))) With lnHour .X1 = 68 .X2 = 68 + pHour.X .Y1 = 68 .Y2 = 68 + pHour.Y End With pMinute.X = CInt(36 * Sin(d(2))) pMinute.Y = CInt(36 * Cos(d(2))) With lnMinute .X1 = 68 .X2 = 68 + pMinute.X .Y1 = 68 .Y2 = 68 + pMinute.Y End With pSecond.X = CInt(52 * Sin(d(3))) pSecond.Y = CInt(52 * Cos(d(3))) With lnSecond .X1 = 68 .X2 = 68 + pSecond.X .Y1 = 68 .Y2 = 68 + pSecond.Y End With End Sub

为了不给边沿出现齿状的东西,我们把时钟外围全部涂成蓝色再删去

'Form_Load中放在Me.Refresh之前 For i = 0 To 139 For j = 0 To 139 If (i - 70) ^ 2 + (j - 70) ^ 2 >= 67 ^ 2 Then Me.PSet (j, i), vbBlue End If Next j Next i

为了不跟其他程序的按键冲突

我们设定 同时按 Ctrl+Alt+Shift+Esc 退出程序

'放在tmrTime的Timer事件中 Ticket t之后 'If GetAsyncKeyState(vbKeyEscape) Then End If GetAsyncKeyState(vbKeyControl) And &H8000 Then If GetAsyncKeyState(vbKeyMenu) And &H8000 Then If GetAsyncKeyState(vbKeyShift) And &H8000 Then If GetAsyncKeyState(vbKeyEscape) And &H8000 Then End End If End If End If

看看我们的半透明和不规则边框效果,是不是很出色