📄 play24_1.frm
字号:
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 6015
ClientLeft = 60
ClientTop = 345
ClientWidth = 8025
LinkTopic = "Form1"
ScaleHeight = 6015
ScaleWidth = 8025
StartUpPosition = 3 '窗口缺省
Begin VB.OptionButton Option1
Caption = "pulse"
Height = 255
Index = 3
Left = 4080
TabIndex = 9
Top = 1500
Width = 975
End
Begin VB.OptionButton Option1
Caption = "X*X"
Height = 255
Index = 2
Left = 4080
TabIndex = 8
Top = 1140
Width = 975
End
Begin VB.HScrollBar HScroll1
Height = 255
Left = 960
Max = 10
TabIndex = 6
Top = 2460
Width = 1935
End
Begin VB.CommandButton Command4
Caption = "Start"
Height = 315
Left = 4140
TabIndex = 5
Top = 2100
Width = 915
End
Begin VB.OptionButton Option1
Caption = "Sin"
Height = 255
Index = 1
Left = 4080
TabIndex = 4
Top = 780
Value = -1 'True
Width = 975
End
Begin VB.OptionButton Option1
Caption = "Rnd"
Height = 255
Index = 0
Left = 4080
TabIndex = 3
Top = 420
Width = 975
End
Begin VB.CommandButton Command1
Caption = "???"
Height = 315
Left = 4140
TabIndex = 2
Top = 2520
Width = 915
End
Begin VB.PictureBox Picture2
BackColor = &H00FFFFFF&
Height = 2175
Left = 60
ScaleHeight = 2115
ScaleWidth = 3495
TabIndex = 1
Top = 120
Width = 3555
End
Begin VB.PictureBox Picture1
BackColor = &H00FFFFFF&
ForeColor = &H00FF8080&
Height = 2175
Left = 0
Picture = "play24_1.frx":0000
ScaleHeight = 2115
ScaleWidth = 7395
TabIndex = 0
Top = 3060
Visible = 0 'False
Width = 7455
End
Begin VB.Label Label1
Alignment = 2 'Center
Caption = "5"
Height = 255
Left = 1740
TabIndex = 7
Top = 2700
Width = 555
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' 《VB前线》http://vbbattlefront.163.net
'************************************************************
'* VB 系列功能演示程序 *
'* *
'* 如果您发现此程序有任何不妥之处或存在需要改进的地方， *
'* 望告诉我本人，本人将非常感激您，并一定回信致谢！ *
'* *
'* by 池星泽(Xing) my Email:vbxing@990.net *
'************************************************************
'*程序编号∶024
'*功 能∶此程序演示了一个简单的滤波器
'*日 期∶4/4/1999
'************************************************************
'如果你觉得阅读程序有困难，请先看第2号演示程序，两个程序在道理上是一样的。
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)
Private Const PS_SOLID& = 0 '实线
Private Const SRCCOPY& = &HCC0020
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpPoint As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private dX As Long
Private dy As Long
Private cuX As Long
Private cuCopyX As Long
Private picHeigth As Integer
Private picWidth
Private isGrap As Integer
Private MyTimeEnabld As Boolean
Private wait As Integer
Private Sub Command1_Click()
MsgBox "你的心脏跳得很不正常，赶快去医院看看吧！^_^"
End Sub
Private Sub Command2_Click()
isStop = Not isStop
End Sub
Private Sub Command4_Click()
If Command4.Caption = "Start" Then
Command4.Caption = "Stop"
Else
Command4.Caption = "Start"
End If
If MyTimeEnabld = False Then
MyTimeEnabld = True
MyTimer
Else
MyTimeEnabld = False
End If
End Sub
Private Sub Form_Load()
Height = 3300: Width = 5475
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
setValue
isGrap = 1
HScroll1.Value = 5
End Sub
Sub setValue()
Dim dl&
Form1.ScaleMode = vbPixels
Picture1.ScaleMode = vbPixels
Picture2.ScaleMode = vbPixels
Picture1.AutoRedraw = True
Picture2.AutoRedraw = False
picHeigth = Picture2.Height
picWidth = Picture2.Width - 5
dy = Picture2.Height \ 2
dX = picWidth
cuCopyX = 0
dl& = MoveToEx(Picture1.hDC, dX, dy, 0&)
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub HScroll1_Change()
wait = HScroll1.Value
Label1.Caption = HScroll1.Value
End Sub
Private Sub Option1_Click(Index As Integer)
Picture1.Cls
setValue
isGrap = Index
End Sub
Private Sub MyTimer()
Do
Select Case isGrap
Case 0
Grap MyRnd()
Case 1
Grap MySin()
Case 2
Grap Xx()
Case 3
Grap Pulse()
End Select
Sleep wait
DoEvents
If MyTimeEnabld = False Then
Exit Do
End If
Loop
End Sub
Sub Grap(cuY As Long)
Dim dl&
Dim pen&, oldpen&
If cuY < 0 Then cuY = 0
If cuY > picHeigth Then cuY = picHeigth
cuX = dX + 1
cuCopyX = cuCopyX + 1
If cuCopyX > picWidth Then
dX = picWidth
cuX = dX + 1
cuCopyX = 1
Picture1.Cls
dl& = MoveToEx(Picture1.hDC, dX, dy, 0&)
dl& = BitBlt(Picture1.hDC, 0, 0, picWidth, picHeigth, Picture2.hDC, 0, 0, SRCCOPY)
End If
pen& = CreatePen(PS_SOLID, 1, RGB(255, 0, 0))
oldpen& = SelectObject(Picture1.hDC, pen&)
dl& = LineTo(Picture1.hDC, cuX, cuY)
dl& = SelectObject(Picture1.hDC, oldpen&)
dl& = DeleteObject(pen&)
dl& = BitBlt(Picture2.hDC, 0, 0, picWidth, picHeigth, Picture1.hDC, cuCopyX, 0, SRCCOPY)
dy = cuY: dX = dX + 1
If dy > 200 Then Stop
End Sub
'/////////////////////////////////
Function MyRnd() As Long
MyRnd = Rnd() * picHeigth
End Function
Function MySin()
Static Radim As Integer
MySin = Sin(Sin(Radim * 3.1426 / 180)) * picHeigth \ 2 + picHeigth \ 2
Radim = Radim + 4
If Radim > 360 Then Radim = 0
End Function
Function Xx()
Static x As Integer
Xx = x * x / 50
x = x + 1
If x = 100 Then x = 0
End Function
Function Pulse()
Static x As Integer
Static y As Integer
If x < 10 Then
y = y + 1
Pulse = 25
If y > 50 Then
x = 20
End If
Else
y = y - 1
Pulse = 125
If y < 0 Then
x = 0
End If
End If
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -