frmmain.frm

VB6程序设计参考手册 -独立源码 VB6程序设计参考手册 -独立源码

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   0  'None
   ClientHeight    =   3765
   ClientLeft      =   -30
   ClientTop       =   -315
   ClientWidth     =   4875
   ControlBox      =   0   'False
   LinkTopic       =   "Form2"
   ScaleHeight     =   3765
   ScaleWidth      =   4875
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.Timer timUnit 
      Interval        =   10
      Left            =   4320
      Top             =   2640
   End
   Begin VB.Image imgBalloon 
      Height          =   3555
      Left            =   120
      Top             =   120
      Width           =   4020
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'处理窗体的区域问题
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Const RGN_AND = 1
Private Const RGN_COPY = 5
Private Const RGN_DIFF = 4
Private Const RGN_OR = 2
Private Const RGN_XOR = 3

'处理窗体的图像
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Const SRCAND = &H8800C6
Private Const SRCCOPY = &HCC0020
Private Const MERGEPAINT = &HBB0226

'令窗体一直处于最前面
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_SHOWWINDOW = &H40

'用于移动无模式的窗体
Private Declare Sub ReleaseCapture Lib "user32" ()
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

'定义所要加载的图片的背景色
Private Const BGColor = 65280

'表示当前的窗体是否处于上升阶段
Private mbIsRising As Boolean

Private Sub Form_KeyPress(KeyAscii As Integer)
   '如果用户按下了ESC键，则退出整个系统
   If KeyAscii = vbKeyEscape Then
      Unload Me
   End If
End Sub

Private Sub Form_Load()
   mbIsRising = True   '窗体在初始阶段处于上升
   timUnit.Interval = 10
   
   Dim strFile As String
   strFile = App.Path & "\balloon.bmp"
   '设置窗体的属性
   imgBalloon.Picture = LoadPicture(strFile)
   Width = imgBalloon.Width
   Height = imgBalloon.Height
   imgBalloon.Visible = False
   Picture = LoadPicture(strFile)
   ScaleMode = 3
   
   Dim lFace As Long
   '调用自定义的CreateRegionFromFile方法来创建图片中的区域
   lFace = CreateRegionFromFile(strFile)
   '设定frmMain窗体的区域
   SetWindowRgn Me.hwnd, lFace, True
   '使窗体一直处在屏幕的最前面
   SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE + SWP_SHOWWINDOW
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    
   timUnit.Enabled = False
   If Button = 1 Then
      '如果用户单击了鼠标左键
      ReleaseCapture
      SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&
   ElseIf Button = 2 Then
      '如果用户单击了鼠标右键，则改变窗体的运动方向
      mbIsRising = Not mbIsRising
   End If
   timUnit.Enabled = True
End Sub

Private Sub timUnit_Timer()
   If mbIsRising Then
      '如果当前的窗体正在上升阶段
        If Me.Top > (-1 * Me.Height) Then
            Me.Top = Me.Top - 50
        Else '如果窗体移出了屏幕，则卸载整个窗体
            Unload Me
        End If
    Else
      ''若当前的窗体正处于下降阶段
        If Me.Top < Screen.Height Then
            Me.Top = Me.Top + 50
        Else '如果窗体移出了屏幕，则卸载整个窗体
            Unload Me
        End If
    End If
End Sub

Private Function CreateRegionFromFile(strFile As String) As Long
   '取得窗体的宽和高
   Dim lWidth As Long
   Dim lHeight As Long
   lWidth = frmMain.ScaleWidth
   lHeight = frmMain.ScaleHeight
   
   Dim hdc As Long
   Dim rgnInv As Long
   Dim rgnTotal As Long
   
   '创建设备上下文HDC和图
   hdc = CreateCompatibleDC(frmMain.hdc)
   Call SelectObject(hdc, LoadPicture(strFile))
   
   rgnTotal = CreateRectRgn(0, 0, lWidth, lHeight)
   rgnInv = CreateRectRgn(0, 0, lWidth, lHeight)
   
   '调用CombineRgn函数来将两个区域进行组合
   CombineRgn rgnTotal, rgnTotal, rgnTotal, RGN_XOR
   
   Dim i As Integer
   Dim j As Integer
   Dim rgn As Long  '区域
   Dim clrRef As Long '颜色
   For i = 0 To lWidth
      For j = 0 To lHeight
         clrRef = GetPixel(hdc, i, j)
         If clrRef = BGColor Then
           '处理背景色
            rgn = CreateRectRgn(i, j, i + 1, j + 1)
            CombineRgn rgnTotal, rgnTotal, rgn, RGN_OR
            DeleteObject rgn
         End If
      Next j
   Next i
   
   CombineRgn rgnTotal, rgnTotal, rgnInv, RGN_XOR
   '返回图片中所要创建的区域
   CreateRegionFromFile = rgnTotal
End Function