screensaver.frm

金算盘软件代码

VERSION 5.00
Begin VB.Form frmSaver 
   BorderStyle     =   0  'None
   Caption         =   "屏幕保护"
   ClientHeight    =   3195
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4680
   DrawStyle       =   5  'Transparent
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   WindowState     =   2  'Maximized
   Begin VB.Timer Timer1 
      Interval        =   50
      Left            =   3990
      Top             =   2640
   End
End
Attribute VB_Name = "frmSaver"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type MovieItem  ''屏幕移动单元对象
   xCurr As Long  ''x当前位置
   yCurr As Long  ''y当前位置
   xPrev As Long  ''x前一位置
   yPrev As Long  ''y前一位置
   xStep As Long     ''x方向移动的步长,初始值根据speed生成随机值
   yStep As Long     ''y方向移动的步长,初始值根据speed和x计算
   moveSpeed   As Long     ''单元移动的速度 随机值
   rotatoSpeed As Long     ''单元旋转的速度 需要其他计时器支持，暂未使用
   currFrames  As Integer  ''当前帧,随机整数
   itemWidth    As Long
   itemHeight    As Long
End Type

Private Type RECT
   Left As Long
   top As Long
   Right As Long
   Bottom As Long
End Type

Private Type BITMAP
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type

Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal ncount As Long, lpObject As Any) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private lngDestDC As Long              ''桌面的兼容DC
Private m_intItemCount As Integer      ''移动对象的总数(0表示1个)
Private m_udtMovieItem() As MovieItem  ''屏幕移动对象
Private m_lngFramesCount As Long     ''帧总数
Private m_hBitmap    As Object       ''图片
Private m_udtRect    As RECT         ''桌面的RECT
Private m_blnCanDraw As Boolean      ''
Private m_lngSpeed   As Long         ''初始速度常数
Private X0 As Integer, Y0 As Integer ''保存鼠标的当前位置


Private Sub Form_Load()
''将背景内容显示在屏幕上
SaveDesktopBackGround
m_intItemCount = 0
m_lngSpeed = 6
m_blnCanDraw = True
ReDim m_udtMovieItem(m_intItemCount)
Set m_hBitmap = LoadResPicture(1295, vbResBitmap)
m_lngFramesCount = 46
InitItem
End Sub

Private Sub Form_Click()
    If frmLogin.LogIn Then
        frmMain.UpdateStatus
        Unload Me
    End If
End Sub

Private Sub Form_DblClick()
    If frmLogin.LogIn Then
        frmMain.UpdateStatus
        Unload Me
    End If
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If frmLogin.LogIn Then
        frmMain.UpdateStatus
        Unload Me
    End If
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If frmLogin.LogIn Then
        frmMain.UpdateStatus
        Unload Me
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If ((X0 = 0) And (Y0 = 0)) Or _
           ((Abs(X0 - x) < 20) And (Abs(Y0 - y) < 20)) Then
            X0 = x
            Y0 = y
            Exit Sub
    End If
    X0 = 0
    Y0 = 0
    If frmLogin.LogIn Then
        frmMain.UpdateStatus
        Unload Me
    End If

End Sub

Private Sub Form_Paint()
Dim udtRect As RECT
Dim lngHDC  As Long
lngHDC = GetWindowDC(hwnd)
GetWindowRect hwnd, udtRect
StretchBlt lngHDC, 0, 0, udtRect.Right - udtRect.Left, udtRect.Bottom - udtRect.top, _
   lngDestDC, 0, 0, udtRect.Right - udtRect.Left, udtRect.Bottom - udtRect.top, vbSrcCopy
ReleaseDC hwnd, lngHDC
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set m_hBitmap = Nothing
DeleteDC lngDestDC
End Sub

Private Sub Timer1_Timer()
 Dim intCount As Integer
 If m_blnCanDraw Then
    m_blnCanDraw = False
    For intCount = 0 To m_intItemCount
      If m_udtMovieItem(intCount).xStep = 0 Or m_udtMovieItem(intCount).yStep = 0 Then
         m_udtMovieItem(intCount).moveSpeed = m_lngSpeed
         m_udtMovieItem(intCount).xStep = (Rnd * m_udtMovieItem(intCount).moveSpeed) * IIf(Rnd < 0.5, 1, -1)
         m_udtMovieItem(intCount).yStep = (Sqr(m_udtMovieItem(intCount).moveSpeed * m_udtMovieItem(intCount).moveSpeed _
          - m_udtMovieItem(intCount).yStep * m_udtMovieItem(intCount).yStep)) * IIf(Rnd < 0.5, 1, -1)
      End If
      DrawItem hdc, intCount
    Next intCount
    m_blnCanDraw = True
 End If
End Sub

''将桌面背景保存
Private Function SaveDesktopBackGround() As Boolean
Dim lngHDC As Long
Dim lngWindowHwnd As Long
Dim hBitmap As Long
lngWindowHwnd = GetDesktopWindow()
lngHDC = GetWindowDC(lngWindowHwnd)
lngDestDC = CreateCompatibleDC(lngHDC)
GetWindowRect lngWindowHwnd, m_udtRect
hBitmap = CreateCompatibleBitmap(lngHDC, m_udtRect.Right - m_udtRect.Left + 1, _
   m_udtRect.Bottom - m_udtRect.top + 1)
SelectObject lngDestDC, hBitmap
StretchBlt lngDestDC, 0, 0, m_udtRect.Right - m_udtRect.Left, m_udtRect.Bottom - m_udtRect.top, _
   lngHDC, 0, 0, m_udtRect.Right - m_udtRect.Left, m_udtRect.Bottom - m_udtRect.top, vbSrcCopy
DeleteObject hBitmap
ReleaseDC lngWindowHwnd, lngHDC
End Function

''初始化屏幕移动单元