winrgn.frm

大量优秀的vb编程

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "会动的窗体"
   ClientHeight    =   2655
   ClientLeft      =   1260
   ClientTop       =   1560
   ClientWidth     =   6135
   ClipControls    =   0   'False
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   177
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   409
   Begin VB.CommandButton Command1 
      Caption         =   "窗体开始运动"
      BeginProperty Font 
         Name            =   "Comic Sans MS"
         Size            =   14.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   492
      Left            =   840
      TabIndex        =   2
      Top             =   720
      Width           =   2172
   End
   Begin VB.OptionButton Option1 
      Caption         =   "Winding"
      Height          =   255
      Index           =   1
      Left            =   1320
      TabIndex        =   1
      Top             =   120
      Value           =   -1  'True
      Visible         =   0   'False
      Width           =   1095
   End
   Begin VB.OptionButton Option1 
      Caption         =   "Alternate"
      Height          =   255
      Index           =   0
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Visible         =   0   'False
      Width           =   1095
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   50
      Left            =   120
      Top             =   720
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function Polyline Lib "gdi32" (ByVal hDC As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long

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 Declare Function ReleaseCapture Lib "user32" () As Long

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

Private Type POINTAPI
   X As Long
   Y As Long
End Type

Private scnPts() As POINTAPI
Private rgnPts() As POINTAPI

Private Const SM_CYCAPTION = 4
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33

' PolyFill() Modes
Private Const ALTERNATE = 1
Private Const WINDING = 2

' Used to support captionless drag
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

Private m_FillMode As Long
Private Const nPts& = 36

Private Sub Command1_Click()
   Dim hRgn As Long
   Static UsingPoly As Boolean
   '
   ' Flag variable tracks current state.
   '
   UsingPoly = Not UsingPoly
   If UsingPoly Then
      '
      ' Create a region, then turn on
      ' clipping to that region.
      '
      hRgn = CreatePolygonRgn(rgnPts(0), nPts, m_FillMode)
      Call SetWindowRgn(Me.hWnd, hRgn, True)
   Else
      '
      ' Turn off clipping.
      '
      Call SetWindowRgn(Me.hWnd, 0&, True)
   End If

   Timer1.Enabled = UsingPoly
End Sub

Private Sub Form_Load()
   m_FillMode = ALTERNATE
   With Me
      .ScaleMode = vbPixels
      .Width = Screen.Width \ 2
      .Height = .Width
      .Move (Screen.Width - .Width) \ 2, (Screen.Height - .Height) \ 2
      .Icon = Nothing
   End With
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   '
   ' Allow captionless drag if form is clipped to region
   '
   If Timer1.Enabled Then
      Call ReleaseCapture
      Call SendMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
   End If
End Sub

Private Sub Form_Paint()
   Dim hBrush As Long
   Dim hRgn As Long
   '
   ' Create region and a brush to fill it with.
   '
   hBrush = CreateSolidBrush(vbBlack)
   hRgn = CreatePolygonRgn(scnPts(0), nPts, m_FillMode)
   Call FillRgn(Me.hDC, hRgn, hBrush)
   '
   ' Clean up GDI objects.
   '
   Call DeleteObject(hRgn)
   Call DeleteObject(hBrush)
   '
   ' Draw outline around polygon.
   '
   Call Polyline(Me.hDC, scnPts(0), nPts + 1)
End Sub

Private Sub Form_Resize()
   With Me
      Command1.Move (.ScaleWidth - Command1.Width) \ 2, _
                    (.ScaleHeight - Command1.Height) \ 2
      If .Visible Then
         CalcRgnPoints
         .Refresh
      End If
   End With
End Sub

Private Static Sub CalcRgnPoints()
   ReDim scnPts(0 To nPts) As POINTAPI
   ReDim rgnPts(0 To nPts) As POINTAPI
   Dim offset As Long
   Dim angle As Long
   Dim theta As Double
   Dim radius1 As Long
   Dim radius2 As Long
   Dim x1 As Long
   Dim y1 As Long
   Dim xOff As Long
   Dim yOff As Long
   Dim n As Long
   '
   ' Some useful constants.
   '
   Const Pi# = 3.14159265358979
   Const DegToRad# = Pi / 180
   '
   ' Calc radius based on form size.
   '
   x1 = Me.ScaleWidth \ 2
   y1 = Me.ScaleHeight \ 2
   If x1 > y1 Then
      radius1 = y1 * 0.85
   Else
      radius1 = x1 * 0.85
   End If
   radius2 = radius1 * 0.5
   '
   ' Offsets to move origin to upper
   ' left of window.
   '
   xOff = GetSystemMetrics(SM_CXFRAME)
   yOff = GetSystemMetrics(SM_CYFRAME) + GetSystemMetrics(SM_CYCAPTION)
   '
   ' Step through a circle, 10 degrees each
   ' loop, finding points for polygon.
   '
   n = 0
   For angle = 0 To 360 Step 10
      theta = (angle - offset) * DegToRad
      '
      ' First region is for drawing.
      ' One long, one short, one long...
      '
      If n Mod 2 Then
         scnPts(n).X = x1 + (radius1 * (Sin(theta)))
         scnPts(n).Y = y1 + (radius1 * (Cos(theta)))
      Else
         scnPts(n).X = x1 + (radius2 * (Sin(theta)))
         scnPts(n).Y = y1 + (radius2 * (Cos(theta)))
      End If
      '
      ' Second region is for clipping.
      ' Add offsets.
      '
      rgnPts(n).X = scnPts(n).X + xOff
      rgnPts(n).Y = scnPts(n).Y + yOff
      n = n + 1
   Next angle

   offset = (offset + 2) Mod 360
End Sub

Private Sub Option1_Click(Index As Integer)
   m_FillMode = Index + 1
End Sub

Private Static Sub Timer1_Timer()
   Dim nRet As Long
   Dim hRgn As Long

   CalcRgnPoints
   hRgn = CreatePolygonRgn(rgnPts(0), nPts, m_FillMode)
   nRet = SetWindowRgn(Me.hWnd, hRgn, True)
End Sub