form1.frm

很多的vb经典源代码

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "图片特技显示"
   ClientHeight    =   5445
   ClientLeft      =   45
   ClientTop       =   420
   ClientWidth     =   7770
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5445
   ScaleWidth      =   7770
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command18 
      Caption         =   "Exit"
      Height          =   400
      Left            =   6840
      TabIndex        =   18
      Top             =   4920
      Width           =   800
   End
   Begin VB.CommandButton Command17 
      Caption         =   "十字折开"
      Height          =   400
      Left            =   6840
      TabIndex        =   17
      Top             =   4440
      Width           =   800
   End
   Begin VB.CommandButton Command16 
      Caption         =   "十字合并"
      Height          =   400
      Left            =   6000
      TabIndex        =   16
      Top             =   4920
      Width           =   800
   End
   Begin VB.CommandButton Command15 
      Caption         =   "关门"
      Height          =   400
      Left            =   6000
      TabIndex        =   15
      Top             =   4440
      Width           =   800
   End
   Begin VB.CommandButton Command14 
      Caption         =   "渐隐"
      Height          =   400
      Left            =   5160
      TabIndex        =   14
      Top             =   4920
      Width           =   800
   End
   Begin VB.CommandButton Command13 
      Caption         =   "渐远"
      Height          =   400
      Left            =   5160
      TabIndex        =   13
      Top             =   4440
      Width           =   800
   End
   Begin VB.CommandButton Command12 
      Caption         =   "渐显"
      Height          =   400
      Left            =   2640
      TabIndex        =   12
      Top             =   4920
      Width           =   800
   End
   Begin VB.CommandButton Command11 
      Caption         =   "左下拉"
      Height          =   400
      Left            =   4320
      TabIndex        =   11
      Top             =   4440
      Width           =   800
   End
   Begin VB.CommandButton Command10 
      Caption         =   "右上拉"
      Height          =   400
      Left            =   3480
      TabIndex        =   10
      Top             =   4920
      Width           =   800
   End
   Begin VB.CommandButton Command9 
      Caption         =   "右下拉"
      Height          =   400
      Left            =   3480
      TabIndex        =   9
      Top             =   4440
      Width           =   800
   End
   Begin VB.CommandButton Command8 
      Caption         =   "左上拉"
      Height          =   400
      Left            =   4320
      TabIndex        =   8
      Top             =   4920
      Width           =   800
   End
   Begin VB.CommandButton Command7 
      Caption         =   "渐近"
      Height          =   400
      Left            =   2640
      TabIndex        =   7
      Top             =   4440
      Width           =   800
   End
   Begin VB.CommandButton Command6 
      Caption         =   "水平窗格"
      Height          =   400
      Left            =   1800
      TabIndex        =   6
      Top             =   4920
      Width           =   800
   End
   Begin VB.CommandButton Command5 
      Caption         =   "竖窗格"
      Height          =   400
      Left            =   1800
      TabIndex        =   5
      Top             =   4440
      Width           =   800
   End
   Begin VB.CommandButton Command4 
      Caption         =   "下拉"
      Height          =   350
      Left            =   600
      TabIndex        =   4
      Top             =   5040
      Width           =   560
   End
   Begin VB.CommandButton Command3 
      Caption         =   "右拉"
      Height          =   350
      Left            =   1080
      TabIndex        =   3
      Top             =   4680
      Width           =   560
   End
   Begin VB.CommandButton Command2 
      Caption         =   "左拉"
      Height          =   350
      Left            =   120
      TabIndex        =   2
      Top             =   4680
      Width           =   560
   End
   Begin VB.CommandButton Command1 
      Caption         =   "上拉"
      Height          =   350
      Left            =   600
      TabIndex        =   1
      Top             =   4320
      Width           =   560
   End
   Begin VB.PictureBox Picture1 
      AutoSize        =   -1  'True
      BackColor       =   &H80000007&
      Height          =   4185
      Left            =   180
      ScaleHeight     =   275
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   495
      TabIndex        =   0
      Top             =   90
      Width           =   7485
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim pic As Picture, sX As Single, sY As Single, _
    Leij As Single, Hmemdc As Long, bm As BITMAP, _
        i As Single, OldDc As Long


Private Sub Command1_Click()
'初始化变量
Call Instal
MoveForm bm.bmHeight, 0, "-1", "y"
End Sub

Sub delay(ByVal n As Single)
   Dim tm1 As Long, tm2 As Long
   tm1 = timeGetTime
   Do
      tm2 = timeGetTime
      If (tm2 - tm1) / 1000 > n Then Exit Do
      DoEvents
   Loop
End Sub

Sub MoveForm(Begin As Long, XEnd As Long, Fuhao As String, Zhou As String)
Dim i As Single, LS As Single
Picture1.Cls
    If Zhou = "y" Then
        For i = Begin To XEnd Step Fuhao
        BitBlt Picture1.hdc, 0, i, Picture1.Width, _
            Picture1.Height, Hmemdc, 0, 0, vbSrcCopy
        delay 0.005    '延时
        Next i
    End If
    If Zhou = "x" Then
        For i = Begin To XEnd Step Fuhao
            BitBlt Picture1.hdc, i, 0, Picture1.Width, _
            Picture1.Height, Hmemdc, 0, 0, vbSrcCopy
            delay 0.005
        Next i
    End If

DeleteObject Hmemdc
DeleteObject OldDc
End Sub

Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "单轴计算的图形载入方式"
End Sub

Private Sub Command10_Click()
Call Instal
xiex 0 - Picture1.ScaleWidth, 0, Picture1.ScaleHeight, 0, _
    "+1", Picture1.ScaleHeight / Picture1.ScaleWidth, 0, 0
End Sub

Private Sub Command10_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "斜向载入图形"

End Sub

Private Sub Command11_Click()
Call Instal
xiex Picture1.ScaleWidth, 0, 0 - Picture1.ScaleHeight, 0, _
    "-1", 0 - Picture1.ScaleHeight / Picture1.ScaleWidth, 0, 0
End Sub

Private Sub Command11_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "斜向载入图形"

End Sub

Private Sub Command12_Click()
Dim Patten As Picture, hPatten As Long, i As Integer, _
    Oldpatten As Long
Picture1.Cls
Call Instal
delay 1
For i = 11 To 18
Set Patten = LoadResPicture(i, vbResBitmap)
hPatten = CreatePatternBrush(Patten)
Oldpatten = SelectObject(Picture1.hdc, hPatten)
BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    Hmemdc, 0, 0, &HAC0744
SelectObject Picture1.hdc, Oldpatten
DeleteObject Patten.Handle
DeleteObject Oldpatten
DeleteObject hPatten
delay 0.3
Next i
DeleteObject Hmemdc
DeleteObject OldDc
End Sub

Private Sub Command12_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "运用花色进行光栅运算的淡入"
End Sub

Private Sub Command13_Click()
Dim difX As Single, difY As Single, W As Single, H As Single, _
    fen As Integer, LsmemDc As Long, Lsbmp As Long
Call Instal
LsmemDc = CreateCompatibleDC(Picture1.hdc)
Lsbmp = CreateCompatibleBitmap(Picture1.hdc, Picture1.ScaleWidth, Picture1.ScaleHeight)
SelectObject LsmemDc, Lsbmp
    fen = 40
    
    difX = Picture1.ScaleWidth / fen
    difY = Picture1.ScaleHeight / fen
    
For i = fen To 0 Step -1
sX = (Picture1.ScaleWidth - difX * i) / 2
sY = (Picture1.ScaleHeight - difY * i) / 2
BitBlt LsmemDc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    OldDc, 0, 0, vbBlackness
StretchBlt LsmemDc, sX, sY, difX * i, difY * i, _
    Hmemdc, 0, 0, bm.bmWidth, bm.bmHeight, vbSrcCopy
BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    LsmemDc, 0, 0, vbSrcCopy
delay 0.01
Next i
DeleteObject Lsbmp
DeleteObject LsmemDc
DeleteObject Hmemdc
DeleteObject OldDc
End Sub

Private Sub Command13_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "由大到小的图形卸载方式"

End Sub

Private Sub Command14_Click()
Dim Patten As Picture, hPatten As Long, i As Integer, _
    Oldpatten As Long, LsmemDc As Long, Lsbmp As Long
Call Instal
BitBlt Hmemdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    OldDc, 0, 0, vbBlackness
For i = 11 To 18
'Load patten对象
Set Patten = LoadResPicture(i, vbResBitmap)
'创建Pattenbrush对象
hPatten = CreatePatternBrush(Patten)
'把patten选入Picturebox
Oldpatten = SelectObject(Picture1.hdc, hPatten)
'进行光栅运算，并把结果显示在picturebox 上
BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    Hmemdc, 0, 0, &HAC0744
'把Patten保存入 picturebox
SelectObject Picture1.hdc, Oldpatten
'删除临时DC
DeleteObject Patten.Handle