10年前的代码 抛砖引玉 供新手练习
Esc键 或 Ctrl + F9 或 Shift + F10 退出程序
'本代码将可学习到下列小技巧
'CBM666 制作
'1.获取最下面任务栏的高度,窗体随时保持置顶层
'2.多张图片组合成动画
'3.如何制作不规则并且半透明的窗体
'4.如何控制动画在桌面上 上下左右 碰壁折返
'5.如何用API转换路径为短路径
'6.如何循环播放背景音乐
'7.全局键盘事件如何检测 示例使用 Esc键 或 Ctrl + F9 或 Shift + F10 退出程序
'8.自定义图像数组控件装载12张图片,播放动画可以提速并避免不停的LoadPicture减低内存耗用
Option Explicit
'*****************************************
'播放音乐使用的API
Dim Pic(12) As StdPicture '定义12张图片为标准图片
Private Sub Form_Load()
On Error Resume Next
Timer1.Interval = 50: Timer1.Enabled = False
TaskBarHeight = GetTaskbarHeight '获取任务栏的高度
'*******************************************
For i = 1 To 12 '将12张图片放入自定义的图像框内
Set Pic(i) = LoadPicture(AppDisk & "Image\" & "Angel" & CStr(i) & ".gif")
Next i
SongName = AppDisk & "Music\I_Love.mid" '将路径与歌曲名赋值给变量SongName
Call PlayMusic '调用副程序开始播放音乐
TransColor = vbBlue '定义蓝色为透明色
With Me '窗体定义属性
.BorderStyle = 0 '窗体无边框
.Caption = "" '窗体标题清除
.BackColor = TransColor '窗体背景色设置为透明色
.Picture = Pic(1) '先将Pic(1)这张图片当窗体背景
.Width = 96 * 15 '窗体宽度
.Height = 80 * 15 '窗体高度
End With
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 '窗体居中
AniCount = 1: LR = True: UD = True '宣告 上下 左右 并定义图片由第一张开始播放
Call TM(Me.hwnd, 130, TransColor) '让窗体屏蔽掉透明色 并让它半透明
Timer1.Enabled = True '启动定时器
Me.Caption = "飞舞的小天使"
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Erase Pic '清除数组
Controls.Remove ("Timer1") '卸载线上添加的定时器Timer1
Call CleanMemory '清除内存
Me.Move Screen.Width '将窗体移动到屏幕外
Call ReleaseTrans(Me.hwnd) '释放影像占用内存
Call StopMusic '停止播放音乐
Set Angel = Nothing '清除窗体占用内存
End Sub
Private Sub Timer1_Timer() '利用定时器控件改变窗体图片并移动位置
On Error Resume Next
If GetForegroundWindow <> Me.hwnd Then SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3 '设定总在最前
Me.Picture = IIf(LR, Pic(AniCount), Pic(AniCount + 6))
AniCount = IIf(AniCount + 1 > 6, 1, AniCount + 1)
'如果LR变量为True(真),窗体的左边座标是一次加100缇向右移动 ; 如果LR变量为False(假),窗体的左边座标是一次减100缇向左移动
Me.Left = IIf(LR, Me.Left + 100, Me.Left - 100)
'如果窗体的左边界值小於等於 0 , 或窗体的左边界值大於或等於 屏幕的宽度减去窗体的宽度,则LR左右将反向,否则维持原来的方向不变换
LR = IIf(Me.Left <= 0 Or Me.Left >= Screen.Width - Me.Width, Not LR, LR)
'如果UD变量为True(真),窗体的顶部座标是一次加75缇向下移动 ; 如果UD变量为False(假),窗体的顶部座标是一次减75缇向上移动
Me.Top = IIf(UD, Me.Top + 75, Me.Top - 75)
'如果窗体的顶部边界值小於等於 0 , 或窗体的顶部边界值大於或等於 屏幕的高度减去窗体的高度,则UD上下将反向,否则维持原来的方向不变换
UD = IIf(Me.Top <= 0 Or Me.Top >= Screen.Height - Me.Height - TaskBarHeight, Not UD, UD)
If GetAsyncKeyState(vbKeyEscape) Or (GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyF9)) Or (GetAsyncKeyState(vbKeyShift) And GetAsyncKeyState(vbKeyF10)) Then Timer1.Enabled = False: Unload Me
End Sub
,************************************** 模块 .bas 代码
Option Explicit
Public Declare Function SetProcessWorkingSetSize Lib "kernel32" (ByVal hProcess As Long, ByVal dwMinimumWorkingSetSize As Long, ByVal dwMaximumWorkingSetSize As Long) As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Sub 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)
Public Declare Function GetForegroundWindow Lib "USER32" () As Long '检测置前窗口使用的API
Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
'************************************************************************** 透明窗体用到的API
Public Declare Function GdiTransparentBlt Lib "gdi32" (ByVal hdc1 As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal W1 As Long, ByVal H1 As Long, ByVal Hdc2 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal W2 As Long, ByVal H2 As Long, ByVal Color As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "USER32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Const WS_EX_LAYERED = &H80000
Const GWL_EXSTYLE = (-20)
Const LWA_ALPHA = &H2
Const LWA_COLORKEY = &H1
Public Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'****************************************
Public Declare Function SystemParametersInfo Lib "USER32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_GETWORKAREA = 48
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Rec As RECT
'***************************************
Public Declare Function GetAsyncKeyState Lib "USER32" (ByVal vKey As Long) As Integer
Public Const vbKeyAlt = vbKeyMenu 'VB忽略了它 我们自己补上
Public AppDisk$, SongName$, OldSong$
Public TransColor&, TmLevel&, NowLevel&, LvStep%, UD As Boolean, LR As Boolean
Public i&, X1&, Y1&, Rtn&, TaskBarHeight&, AniCount& '变量宣告与定义变量型态
Sub Main()
If App.PrevInstance Then MsgBox "本程序已运行中!", vbCritical, "飞舞的小天使": End
AppDisk = GetShortName(IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\"))
Angel.Show
End Sub
Public Function GetTaskbarHeight() As Long '获取最下面那排任务栏占用的高度 调用涵数
'获取最下面任务栏的高度
On Error Resume Next
Dim lRes As Long
Dim RectVal As RECT
lRes = SystemParametersInfo(SPI_GETWORKAREA, 0, RectVal, 0)
GetTaskbarHeight = ((Screen.Height / Screen.TwipsPerPixelX) - RectVal.Bottom) * 15
End Function
'*********** 让窗体透明并且屏蔽颜色
Public Sub TM(ByVal Phwnd As Long, Tlevel As Long, Optional TColor As Long = -1)
On Error Resume Next
Rtn = GetWindowLong(Phwnd, GWL_EXSTYLE)
Rtn = Rtn Or WS_EX_LAYERED
SetWindowLong Phwnd, GWL_EXSTYLE, Rtn
If TColor >= 0 Then
SetLayeredWindowAttributes Phwnd, TColor, Tlevel, LWA_COLORKEY Or LWA_ALPHA '将扣去窗口中的指定颜色背景
Else
SetLayeredWindowAttributes Phwnd, 0, Tlevel, LWA_ALPHA
End If
End Sub
Public Function GetShortName(ByVal sLongFileName As String) As String '获取文件短路径
On Error Resume Next
Dim lRetVal&, sShortPathName$
sShortPathName = Space(255)
Call GetShortPathName(sLongFileName, sShortPathName, 255)
If InStr(sShortPathName, Chr(0)) > 0 Then
GetShortName = Mid(sShortPathName, 1, InStr(sShortPathName, Chr(0)) - 1)
Else
GetShortName = Trim(Mid(sShortPathName, 1))
End If
End Function
Public Sub ReleaseTrans(ByVal Phwnd As Long) '释放影像内存
On Error Resume Next
Rtn = GetWindowLong(Phwnd, GWL_EXSTYLE)
Rtn = Rtn And Not WS_EX_LAYERED
SetWindowLong Phwnd, GWL_EXSTYLE, Rtn
End Sub
Public Sub StopMusic() '停止播放音乐
On Error Resume Next
mciSendString "stop " & OldSong, vbNullString, 0, 0
mciSendString "close " & OldSong, vbNullString, 0, 0
End Sub
Public Sub PlayMusic() '播放音乐的副程序
On Error Resume Next
If Dir(SongName) <> "" Then
mciSendString "open " & SongName & " type mpegvideo", vbNullString, 0, 0
mciSendString "play " & SongName & " repeat", vbNullString, 0, 0
OldSong = SongName
End If
End Sub
Public Sub CleanMemory() '清除内存
SetProcessWorkingSetSize GetCurrentProcess, -1, -1
End Sub
Esc键 或 Ctrl + F9 或 Shift + F10 退出程序
'本代码将可学习到下列小技巧
'CBM666 制作
'1.获取最下面任务栏的高度,窗体随时保持置顶层
'2.多张图片组合成动画
'3.如何制作不规则并且半透明的窗体
'4.如何控制动画在桌面上 上下左右 碰壁折返
'5.如何用API转换路径为短路径
'6.如何循环播放背景音乐
'7.全局键盘事件如何检测 示例使用 Esc键 或 Ctrl + F9 或 Shift + F10 退出程序
'8.自定义图像数组控件装载12张图片,播放动画可以提速并避免不停的LoadPicture减低内存耗用
Option Explicit
'*****************************************
'播放音乐使用的API
Dim Pic(12) As StdPicture '定义12张图片为标准图片
Private Sub Form_Load()
On Error Resume Next
Timer1.Interval = 50: Timer1.Enabled = False
TaskBarHeight = GetTaskbarHeight '获取任务栏的高度
'*******************************************
For i = 1 To 12 '将12张图片放入自定义的图像框内
Set Pic(i) = LoadPicture(AppDisk & "Image\" & "Angel" & CStr(i) & ".gif")
Next i
SongName = AppDisk & "Music\I_Love.mid" '将路径与歌曲名赋值给变量SongName
Call PlayMusic '调用副程序开始播放音乐
TransColor = vbBlue '定义蓝色为透明色
With Me '窗体定义属性
.BorderStyle = 0 '窗体无边框
.Caption = "" '窗体标题清除
.BackColor = TransColor '窗体背景色设置为透明色
.Picture = Pic(1) '先将Pic(1)这张图片当窗体背景
.Width = 96 * 15 '窗体宽度
.Height = 80 * 15 '窗体高度
End With
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 '窗体居中
AniCount = 1: LR = True: UD = True '宣告 上下 左右 并定义图片由第一张开始播放
Call TM(Me.hwnd, 130, TransColor) '让窗体屏蔽掉透明色 并让它半透明
Timer1.Enabled = True '启动定时器
Me.Caption = "飞舞的小天使"
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Erase Pic '清除数组
Controls.Remove ("Timer1") '卸载线上添加的定时器Timer1
Call CleanMemory '清除内存
Me.Move Screen.Width '将窗体移动到屏幕外
Call ReleaseTrans(Me.hwnd) '释放影像占用内存
Call StopMusic '停止播放音乐
Set Angel = Nothing '清除窗体占用内存
End Sub
Private Sub Timer1_Timer() '利用定时器控件改变窗体图片并移动位置
On Error Resume Next
If GetForegroundWindow <> Me.hwnd Then SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3 '设定总在最前
Me.Picture = IIf(LR, Pic(AniCount), Pic(AniCount + 6))
AniCount = IIf(AniCount + 1 > 6, 1, AniCount + 1)
'如果LR变量为True(真),窗体的左边座标是一次加100缇向右移动 ; 如果LR变量为False(假),窗体的左边座标是一次减100缇向左移动
Me.Left = IIf(LR, Me.Left + 100, Me.Left - 100)
'如果窗体的左边界值小於等於 0 , 或窗体的左边界值大於或等於 屏幕的宽度减去窗体的宽度,则LR左右将反向,否则维持原来的方向不变换
LR = IIf(Me.Left <= 0 Or Me.Left >= Screen.Width - Me.Width, Not LR, LR)
'如果UD变量为True(真),窗体的顶部座标是一次加75缇向下移动 ; 如果UD变量为False(假),窗体的顶部座标是一次减75缇向上移动
Me.Top = IIf(UD, Me.Top + 75, Me.Top - 75)
'如果窗体的顶部边界值小於等於 0 , 或窗体的顶部边界值大於或等於 屏幕的高度减去窗体的高度,则UD上下将反向,否则维持原来的方向不变换
UD = IIf(Me.Top <= 0 Or Me.Top >= Screen.Height - Me.Height - TaskBarHeight, Not UD, UD)
If GetAsyncKeyState(vbKeyEscape) Or (GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyF9)) Or (GetAsyncKeyState(vbKeyShift) And GetAsyncKeyState(vbKeyF10)) Then Timer1.Enabled = False: Unload Me
End Sub
,************************************** 模块 .bas 代码
Option Explicit
Public Declare Function SetProcessWorkingSetSize Lib "kernel32" (ByVal hProcess As Long, ByVal dwMinimumWorkingSetSize As Long, ByVal dwMaximumWorkingSetSize As Long) As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Sub 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)
Public Declare Function GetForegroundWindow Lib "USER32" () As Long '检测置前窗口使用的API
Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
'************************************************************************** 透明窗体用到的API
Public Declare Function GdiTransparentBlt Lib "gdi32" (ByVal hdc1 As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal W1 As Long, ByVal H1 As Long, ByVal Hdc2 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal W2 As Long, ByVal H2 As Long, ByVal Color As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "USER32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Const WS_EX_LAYERED = &H80000
Const GWL_EXSTYLE = (-20)
Const LWA_ALPHA = &H2
Const LWA_COLORKEY = &H1
Public Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'****************************************
Public Declare Function SystemParametersInfo Lib "USER32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_GETWORKAREA = 48
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Rec As RECT
'***************************************
Public Declare Function GetAsyncKeyState Lib "USER32" (ByVal vKey As Long) As Integer
Public Const vbKeyAlt = vbKeyMenu 'VB忽略了它 我们自己补上
Public AppDisk$, SongName$, OldSong$
Public TransColor&, TmLevel&, NowLevel&, LvStep%, UD As Boolean, LR As Boolean
Public i&, X1&, Y1&, Rtn&, TaskBarHeight&, AniCount& '变量宣告与定义变量型态
Sub Main()
If App.PrevInstance Then MsgBox "本程序已运行中!", vbCritical, "飞舞的小天使": End
AppDisk = GetShortName(IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\"))
Angel.Show
End Sub
Public Function GetTaskbarHeight() As Long '获取最下面那排任务栏占用的高度 调用涵数
'获取最下面任务栏的高度
On Error Resume Next
Dim lRes As Long
Dim RectVal As RECT
lRes = SystemParametersInfo(SPI_GETWORKAREA, 0, RectVal, 0)
GetTaskbarHeight = ((Screen.Height / Screen.TwipsPerPixelX) - RectVal.Bottom) * 15
End Function
'*********** 让窗体透明并且屏蔽颜色
Public Sub TM(ByVal Phwnd As Long, Tlevel As Long, Optional TColor As Long = -1)
On Error Resume Next
Rtn = GetWindowLong(Phwnd, GWL_EXSTYLE)
Rtn = Rtn Or WS_EX_LAYERED
SetWindowLong Phwnd, GWL_EXSTYLE, Rtn
If TColor >= 0 Then
SetLayeredWindowAttributes Phwnd, TColor, Tlevel, LWA_COLORKEY Or LWA_ALPHA '将扣去窗口中的指定颜色背景
Else
SetLayeredWindowAttributes Phwnd, 0, Tlevel, LWA_ALPHA
End If
End Sub
Public Function GetShortName(ByVal sLongFileName As String) As String '获取文件短路径
On Error Resume Next
Dim lRetVal&, sShortPathName$
sShortPathName = Space(255)
Call GetShortPathName(sLongFileName, sShortPathName, 255)
If InStr(sShortPathName, Chr(0)) > 0 Then
GetShortName = Mid(sShortPathName, 1, InStr(sShortPathName, Chr(0)) - 1)
Else
GetShortName = Trim(Mid(sShortPathName, 1))
End If
End Function
Public Sub ReleaseTrans(ByVal Phwnd As Long) '释放影像内存
On Error Resume Next
Rtn = GetWindowLong(Phwnd, GWL_EXSTYLE)
Rtn = Rtn And Not WS_EX_LAYERED
SetWindowLong Phwnd, GWL_EXSTYLE, Rtn
End Sub
Public Sub StopMusic() '停止播放音乐
On Error Resume Next
mciSendString "stop " & OldSong, vbNullString, 0, 0
mciSendString "close " & OldSong, vbNullString, 0, 0
End Sub
Public Sub PlayMusic() '播放音乐的副程序
On Error Resume Next
If Dir(SongName) <> "" Then
mciSendString "open " & SongName & " type mpegvideo", vbNullString, 0, 0
mciSendString "play " & SongName & " repeat", vbNullString, 0, 0
OldSong = SongName
End If
End Sub
Public Sub CleanMemory() '清除内存
SetProcessWorkingSetSize GetCurrentProcess, -1, -1
End Sub