form1.frm

VB精彩编程200例,可以快速的让你掌握VB的编程

VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H00C0C0C0&
   Caption         =   "智能窗体放大器"
   ClientHeight    =   2400
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   2910
   LinkTopic       =   "Form1"
   ScaleHeight     =   160
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   194
   StartUpPosition =   3  '窗口缺省
   Begin VB.Timer Timer1 
      Interval        =   50
      Left            =   435
      Top             =   630
   End
   Begin VB.Menu file 
      Caption         =   "文件"
   End
   Begin VB.Menu fdbs 
      Caption         =   "放大"
      Begin VB.Menu one 
         Caption         =   "1倍"
      End
      Begin VB.Menu two 
         Caption         =   "2倍"
      End
      Begin VB.Menu three 
         Caption         =   "3倍"
      End
      Begin VB.Menu four 
         Caption         =   "4倍"
      End
   End
   Begin VB.Menu cksz 
      Caption         =   "窗口大小"
      Begin VB.Menu onewin 
         Caption         =   "100*100"
      End
      Begin VB.Menu twowin 
         Caption         =   "200*200"
      End
      Begin VB.Menu threewin 
         Caption         =   "300*300"
      End
   End
   Begin VB.Menu exit 
      Caption         =   "退出"
   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 Type POINTAPI
  x As Long
  y As Long
End Type

Const Srccopy = &HCC0020
Const Swp_nomove = &H2
Const Swp_nosize = &H1
Const Flags = Swp_nomove Or Swp_nosize
Const hwnd_topmost = -1

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

Private Declare Function GetDC Lib "user32" (ByVal hWnd 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 CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, _
    ByVal X2 As Long, ByVal Y2 As Long) As Long
    
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, _
    ByVal bRedraw As Long) As Long

Dim pos As POINTAPI
Dim i As Long
Dim sx As Long
Dim sy As Long
Private Sub Form_Load()
  setwindow
  i = 2
  sx = 100
  sy = 100
End Sub
Private Sub Form_Click()  '鼠标单击窗体
  Timer1.Interval = 0
  Me.Height = 3000
  Me.Width = 3000
  sx = 100
  sy = 100
  setwindow
  Timer1.Interval = 50
End Sub
Private Sub setwindow()
  SetWindowPos hWnd, hwnd_topmost, 0, 0, 0, 0, Flags
  Dim hr&, dl&
  Dim usew&, useh&
  usew& = Me.Width / Screen.TwipsPerPixelX
  useh& = Me.Height / Screen.TwipsPerPixelY
  hr& = CreateEllipticRgn(0, 0, usew, useh)
  dl& = SetWindowRgn(Me.hWnd, hr, True)
End Sub

Private Sub Timer1_Timer()  '窗体放大效果
  Dim wx As Integer
  Dim wy As Integer
  GetCursorPos pos
  wx = IIf(pos.x < 50 Or pos.x > 800, IIf(pos.x < 50, 0, 800), pos.x - 50)
  wy = IIf(pos.y < 20 Or pos.y > 800, IIf(pos.y < 20, 0, 800), pos.y - 20)
  Caption = "    坐标" & wx & "," & wy & "放大倍数=" & i
  StretchBlt hdc, 0, 0, sx * i, sy * i, GetDC(0), wx, wy, sx, sy, Srccopy
End Sub

Private Sub one_Click()  '放大1倍
  Timer1.Interval = 0
  i = 1
  Timer1.Interval = 50
End Sub

Private Sub onewin_Click()  '窗口大小
  Timer1.Interval = 0
  Me.Height = 3000
  Me.Width = 3000
  sx = 100
  sy = 100
  setwindow
  Timer1.Interval = 50
End Sub

Private Sub threewin_Click()  '窗口大小
  Timer1.Interval = 0
  Me.Height = 3000 * 3
  Me.Width = 3000 * 3
  sx = 300
  sy = 300
  setwindow
  Timer1.Interval = 50
End Sub

Private Sub two_Click()  '放大2倍
  Timer1.Interval = 0
  i = 2
  Timer1.Interval = 50
End Sub

Private Sub twowin_Click()  '窗口大小
  Timer1.Interval = 0
  Me.Height = 3000 * 2
  Me.Width = 3000 * 2
  sx = 200
  sy = 200
  SetWindowPos hWnd, hwnd_topmost, 0, 0, 0, 0, Flags
  Dim hr&, dl&
  Dim usew&, useh&
  usew& = Me.Width / Screen.TwipsPerPixelX
  useh& = Me.Height / Screen.TwipsPerPixelY
  hr& = CreateEllipticRgn(0, 0, usew, useh)
  dl& = SetWindowRgn(Me.hWnd, hr, True)
  Timer1.Interval = 50
End Sub

Private Sub three_Click()  '放大3倍
  Timer1.Interval = 0
  i = 3
  Timer1.Interval = 50
End Sub

Private Sub four_Click()  '放大4倍
  Timer1.Interval = 0
  i = 4
  Timer1.Interval = 50
End Sub

Private Sub exit_Click()
  End
End Sub