致新手：用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

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