clsdrawtime.cls

一个clock的 vb 源码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDrawTime"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit

Private Left As Long, Top As Long

Public Sub DrawTime(hDestDc As Long, hSreDc As Long, StrTime As String)
    If Len(StrTime) > 7 Then    ' 时间贴图函数
        BitBlt hDestDc, Left, Top, 16, 25, hSreDc, 15 * Mid(StrTime, 1, 1), 0, SRCCOPY
        BitBlt hDestDc, Left + 16, Top, 16, 25, hSreDc, 15 * Mid(StrTime, 2, 1), 0, SRCCOPY
        BitBlt hDestDc, Left + 40, Top, 16, 25, hSreDc, 15 * Mid(StrTime, 4, 1), 0, SRCCOPY
        BitBlt hDestDc, Left + 56, Top, 16, 25, hSreDc, 15 * Mid(StrTime, 5, 1), 0, SRCCOPY
        BitBlt hDestDc, Left + 80, Top, 15, 25, hSreDc, 15 * Mid(StrTime, 7, 1), 0, SRCCOPY
        BitBlt hDestDc, Left + 95, Top, 16, 25, hSreDc, 15 * Mid(StrTime, 8, 1), 0, SRCCOPY
        BitBlt hDestDc, Left + 32, Top, 8, 25, hSreDc, 151, 0, SRCCOPY
        BitBlt hDestDc, Left + 72, Top, 8, 25, hSreDc, 151, 0, SRCCOPY
    Else
        BitBlt hDestDc, Left + 16, Top, 16, 25, hSreDc, 15 * Mid(StrTime, 1, 1), 0, SRCCOPY
        BitBlt hDestDc, Left + 40, Top, 16, 25, hSreDc, 15 * Mid(StrTime, 3, 1), 0, SRCCOPY
        BitBlt hDestDc, Left + 56, Top, 16, 25, hSreDc, 15 * Mid(StrTime, 4, 1), 0, SRCCOPY
        BitBlt hDestDc, Left + 80, Top, 15, 25, hSreDc, 15 * Mid(StrTime, 6, 1), 0, SRCCOPY
        BitBlt hDestDc, Left + 95, Top, 16, 25, hSreDc, 15 * Mid(StrTime, 7, 1), 0, SRCCOPY
        BitBlt hDestDc, Left, Top, 16, 25, hSreDc, 158, 0, SRCCOPY
        BitBlt hDestDc, Left + 32, Top, 8, 25, hSreDc, 151, 0, SRCCOPY
        BitBlt hDestDc, Left + 72, Top, 8, 25, hSreDc, 151, 0, SRCCOPY
    End If

End Sub

Public Sub PaintTimePos(hDcMem As Long, BmpWidth As Long, BmpHeight As Long)
    '设置显示为(时间)中间
    Dim Color As Long, dx As Single, dy As Single
        For dx = 0 To BmpWidth
        For dy = 0 To BmpHeight
            Color = GetPixel(hDcMem, dx, dy)
                If Color = 0 Then
                    Left = (dx - 109)
                    Top = dy
                Exit For
                End If
        Next
        Next
End Sub

Public Property Get ReLeft() As Long
    ReLeft = Left
End Property

Public Property Get ReTop() As Long
    ReTop = Top
End Property