form1.frm

很多的vb经典源代码

DeleteObject Oldpatten
DeleteObject hPatten
'延时
delay 0.1
Next i
DeleteObject Hmemdc
DeleteObject OldDc
End Sub

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

Private Sub Command15_Click()
Call Instal
Dim i As Long, iY As Long
Picture1.Cls
iY = bm.bmWidth
i = 0 - bm.bmWidth / 2

For i = 0 - bm.bmWidth / 2 - 1 To 0
    iY = iY - 1
BitBlt Picture1.hdc, iY, 0, Picture1.ScaleWidth / 2 + 1, Picture1.ScaleHeight, _
    Hmemdc, bm.bmWidth / 2, 0, vbSrcCopy
BitBlt Picture1.hdc, i, 0, Picture1.ScaleWidth / 2, Picture1.ScaleHeight, _
    Hmemdc, 0, 0, vbSrcCopy
    delay 0.005
 Next i
BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    Hmemdc, 0, 0, vbSrcCopy
    
DeleteObject Hmemdc
DeleteObject OldDc
End Sub

Private Sub Command15_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "分成两块X轴的载入方式"
End Sub

Private Sub Command16_Click()
Call Instal
Dim ILUx As Single, ILUy As Single, IRUx As Single, _
    IRUy As Single, ILDx As Single, ILDy As Single, _
        IRDx As Single, IRDy As Single, Lsbmp As Long, _
            Leij As Single
Picture1.Cls
Leij = Picture1.ScaleHeight / Picture1.ScaleWidth
'制作时的参照
ILUx = 0 - bm.bmWidth / 2
ILUy = 0 - bm.bmHeight / 2

IRUx = bm.bmWidth
IRUy = 0 - bm.bmHeight / 2

ILDx = 0
ILDy = bm.bmHeight

IRDx = bm.bmWidth / 2
IRDy = bm.bmHeight / 2

'分别计算四个图块X，Y 轴的运动轨迹
For ILUx = 0 - bm.bmWidth / 2 To 0
    ILUy = ILUy + Leij
    IRUx = IRUx - 1
    IRUy = IRUy + Leij
    ILDy = ILDy - Leij

'直接显示在picturebox上
BitBlt Picture1.hdc, ILUx, ILUy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _
    Hmemdc, 0, 0, vbSrcCopy
BitBlt Picture1.hdc, IRUx, IRUy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _
    Hmemdc, bm.bmWidth / 2, 0, vbSrcCopy
BitBlt Picture1.hdc, ILUx, ILDy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _
    Hmemdc, 0, bm.bmHeight / 2, vbSrcCopy
BitBlt Picture1.hdc, IRUx, ILDy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _
    Hmemdc, bm.bmWidth / 2, bm.bmHeight / 2, vbSrcCopy

'延时
delay 0.01
Next ILUx
'去除接缝
BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    Hmemdc, 0, 0, vbSrcCopy
'删除无用的DC
DeleteObject Hmemdc
DeleteObject OldDc
End Sub

Private Sub Command16_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "分成四块的图形载入方式"
End Sub

Private Sub Command17_Click()
Call Instal
Dim ILUx As Single, ILUy As Single, IRUx As Single, _
    IRUy As Single, ILDx As Single, ILDy As Single, _
        IRDx As Single, IRDy As Single, Lsbmp As Long, _
            Leij As Single, LsmemDc As Long
'建立与 Picture1相兼容的虚拟DC
LsmemDc = CreateCompatibleDC(Picture1.hdc)
'建立与Picture1相兼容的 Bmp
Lsbmp = CreateCompatibleBitmap(Picture1.hdc, Picture1.ScaleWidth, Picture1.ScaleHeight)
'把虚拟 Bmp 选进虚拟 DC
SelectObject LsmemDc, Lsbmp
'计算Y轴单位累加数
Leij = Picture1.ScaleHeight / Picture1.ScaleWidth
ILUx = 0
ILUy = 0

IRUx = bm.bmWidth / 2
IRUy = 0

ILDx = bm.bmWidth / 2
ILDy = bm.bmHeight / 2

IRDx = bm.bmWidth / 2
IRDy = bm.bmHeight / 2
For ILUx = 0 To 0 - bm.bmWidth / 2 Step -1
    ILUy = ILUy - Leij
    IRUx = IRUx + 1
    IRUy = IRUy - Leij
    ILDy = ILDy + Leij
'把要操作的图象转移进虚拟DC
BitBlt LsmemDc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    OldDc, 0, 0, vbBlackness
BitBlt LsmemDc, ILUx, ILUy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _
    Hmemdc, 0, 0, vbSrcCopy
BitBlt LsmemDc, IRUx, IRUy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _
    Hmemdc, bm.bmWidth / 2, 0, vbSrcCopy
BitBlt LsmemDc, ILUx, ILDy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _
    Hmemdc, 0, bm.bmHeight / 2, vbSrcCopy
BitBlt LsmemDc, IRUx, ILDy, Picture1.ScaleWidth / 2, Picture1.ScaleHeight / 2, _
    Hmemdc, bm.bmWidth / 2, bm.bmHeight / 2, vbSrcCopy
'把虚拟 DC 显示到 Picturebox
BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    LsmemDc, 0, 0, vbSrcCopy

delay 0.01
Next ILUx
'去除接缝
BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
    Hmemdc, 0, 0, vbBlackness
'删除不用的虚拟 DC
DeleteObject Hmemdc
DeleteObject Lsbmp
DeleteObject LsmemDc
DeleteObject OldDc
End Sub

Private Sub Command17_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "分成四块的图形卸载方式"

End Sub

Private Sub Command18_Click()
Unload Me
End Sub

Private Sub Command18_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "请按此键退出,下次再见。"
End Sub

Private Sub Command2_Click()
Call Instal
MoveForm bm.bmWidth, 0, "-1", "x"

End Sub

Sub Instal()
'把图形 Load 入 Pic
Set pic = LoadResPicture(101, vbResBitmap)
'获得 Pic 的数据
GetObject pic.Handle, Len(bm), bm
'建立和 picturebox 相兼容的虚拟 DC
Hmemdc = CreateCompatibleDC(Picture1.hdc)
'建立以后恢复用的 DC
OldDc = CreateCompatibleDC(Picture1.hdc)

SelectObject OldDc, Picture1.Picture.Handle
'把已经 Load 图形的 Pic 选入虚拟 DC
SelectObject Hmemdc, pic.Handle
End Sub

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

End Sub

Private Sub Command3_Click()
Call Instal
MoveForm 0 - bm.bmWidth, 0, "+1", "x"
End Sub

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

Private Sub Command4_Click()
Call Instal
MoveForm 0 - bm.bmHeight, 0, "+1", "y"
End Sub

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

End Sub

Private Sub Command5_Click()
Call Instal
Dim fen As Integer, kuan As Single

fen = 40
Picture1.Cls
sX = bm.bmWidth / fen
For kuan = 0 To sX + 1
    For i = 0 To fen
    BitBlt Picture1.hdc, sX * i, 0, kuan, Picture1.Height, _
        Hmemdc, sX * i, 0, vbSrcCopy
    Next i
delay 0.1
Next kuan
DeleteObject Hmemdc
DeleteObject OldDc
End Sub

Private Sub Command5_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "X轴的百叶窗"
End Sub

Private Sub Command6_Click()
Call Instal
Dim fen As Integer, kuan As Single
fen = 20
Picture1.Cls
sY = bm.bmHeight / fen
For kuan = 0 To sY + 1
    For i = 0 To fen
    BitBlt Picture1.hdc, 0, sY * i, Picture1.Width, kuan, _
        Hmemdc, 0, sY * i, vbSrcCopy
    Next i
delay 0.15
Next kuan
DeleteObject Hmemdc
DeleteObject OldDc
End Sub

Private Sub Command6_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "Y轴的百叶窗"
End Sub

Private Sub Command7_Click()
Dim difX As Single, difY As Single, W As Single, H As Single, _
    fen As Integer
Call Instal
Picture1.Cls
    fen = 40
    
    difX = Picture1.ScaleWidth / fen
    difY = Picture1.ScaleHeight / fen
    
For i = 1 To fen
sX = (Picture1.ScaleWidth - difX * i) / 2
sY = (Picture1.ScaleHeight - difY * i) / 2

StretchBlt Picture1.hdc, sX, sY, difX * i, difY * i, _
    Hmemdc, 0, 0, bm.bmWidth, bm.bmHeight, vbSrcCopy
delay 0.01
DoEvents
Next i
DeleteObject Hmemdc
DeleteObject OldDc
End Sub

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

Private Sub Command8_Click()
Call Instal
Dim ystep As Single
ystep = Picture1.ScaleHeight / Picture1.ScaleWidth
xiex Picture1.ScaleWidth, 0, Picture1.ScaleHeight, 0, _
    "-1", ystep, 0, 0
End Sub
Sub xiex(startX As Single, endX As Single, _
    startY As Single, endY As Single, Xstep As String, _
        ystep As Single, picX As Single, picY As Single)
Picture1.Cls
Dim XX As Single
XX = startY + ystep
For i = startX To endX Step Xstep
    XX = XX - ystep
BitBlt Picture1.hdc, i, XX, Picture1.Width, Picture1.Height, _
    Hmemdc, picX, picY, vbSrcCopy
delay 0.01
Next i
DeleteObject OldDc
DeleteObject Hmemdc
End Sub

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

End Sub

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

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

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "图片演示。"
End Sub

Private Sub Form_Unload(Cancel As Integer)
Unload Me
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Caption = "演示图片的 Picture."
End Sub