form1.frm

来自「本文件包含200个visual baisc实例」· FRM 代码 · 共 119 行

VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H00000000&
   Caption         =   "雨滴图片"
   ClientHeight    =   5610
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7455
   LinkTopic       =   "Form1"
   Picture         =   "Form1.frx":0000
   ScaleHeight     =   374
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   497
   StartUpPosition =   1  '所有者中心
   Begin VB.CommandButton Command3 
      Caption         =   "退出"
      Height          =   375
      Left            =   1920
      TabIndex        =   2
      Top             =   0
      Width           =   960
   End
   Begin VB.CommandButton Command2 
      Caption         =   "雨丝"
      Height          =   375
      Left            =   960
      TabIndex        =   1
      Top             =   0
      Width           =   960
   End
   Begin VB.CommandButton Command1 
      Caption         =   "雨滴"
      Height          =   375
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   960
   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 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 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Const SRCCOPY = &HCC0020
Private Picture1 As New StdPicture

Private Sub Form_Load()
  Set Picture1 = LoadPicture(App.Path & "\001.jpg")
End Sub

Private Sub Command1_Click()
  Dim i As Long
  Dim j As Long
  Dim height5 As Long, width5 As Long
  Dim hMemDc As Long
  height5 = ScaleY(Picture1.Height, vbHimetric, vbPixels)
  If height5 > Me.ScaleHeight Then
     height5 = Me.ScaleHeight
  End If
  width5 = ScaleX(Picture1.Width, vbHimetric, vbPixels)
  If width5 > Me.ScaleWidth Then
     width5 = Me.ScaleWidth
  End If
  hMemDc = CreateCompatibleDC(Me.hdc)
'将Picture1的BitMap图指定给hMemDc
  Call SelectObject(hMemDc, Picture1.Handle)
       For i = 1 To height5 Step 1
           Call BitBlt(Me.hdc, 0, i, width5, 1, hMemDc, 0, i, SRCCOPY)
           For j = 1 To i Step 1
               Call BitBlt(Me.hdc, 0, j, width5, 1, hMemDc, 0, i, SRCCOPY)
           Next j
       Next
  Call DeleteDC(hMemDc)
  Me.Cls
End Sub

Private Sub Command2_Click()
  Dim i As Long
  Dim j As Long
  Dim height5 As Long, width5 As Long
  Dim hMemDc As Long
  height5 = ScaleY(Picture1.Height, vbHimetric, vbPixels)
  If height5 > Me.ScaleHeight Then
     height5 = Me.ScaleHeight
  End If
  width5 = ScaleX(Picture1.Width, vbHimetric, vbPixels)
  If width5 > Me.ScaleWidth Then
     width5 = Me.ScaleWidth
  End If
  hMemDc = CreateCompatibleDC(Me.hdc)
'将Picture1的BitMap图指定给hMemDc
  Call SelectObject(hMemDc, Picture1.Handle)
       For i = 1 To height5 Step 1
           Call BitBlt(Me.hdc, 0, i, width5, 1, hMemDc, 0, i, SRCCOPY)
           For j = 1 To i Step 2
               Call BitBlt(Me.hdc, 0, j, width5, 1, hMemDc, 0, i, SRCCOPY)
           Next j
       Next
  Call DeleteDC(hMemDc)
  Me.Cls

End Sub

Private Sub Command3_Click()
  End
End Sub