作者：绿色风
分类：
时间：2022-08-17
浏览：179
楼主
chrisfang |
使用Excel中的VBA开发的窗体版的弹钢琴小游戏，与大家分享。
支持鼠标或键盘弹奏、支持弹奏的录音和回放、支持内置曲目的自动弹奏、支持音量和音调调节。
 我爱弹钢琴V1.2 for ET.rar
主要代码部分：
- Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
- If playflag = 0 Then
- keypress (KeyAscii)
- End If
- End Sub
- '׫д:chrisfang
- 'ÍøÖ·:http://club.excelhome.net/thread-488256-1-1.html
- 'ÈÕÆÚ:2009-12-20
- Private Declare Function midiOutSetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, ByVal dwVolume As Long) As Long
- Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
- Private Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long
- Private Declare Function midiOutOpen Lib "winmm.dll" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
- Private Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
- Private Declare Function midiOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As Long
- 'Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
- Public midiflag
- Public tipsflag
- Public exitflag
- Public recflag
- Public playflag
- Public rectimer, reccount
- Public arr1, arr2, arr3
- Public tone, keyindex
- Public mymidi As Long
- Public songindex
- Sub midi_on()
- midiOutOpen mymidi, 0, 0, 0, 0 '´ò¿ªmidiÉ豸
- End Sub
- Sub midi_off()
- midiOutClose mymidi '¹Ø±ÕmidiÉ豸
- End Sub
- Sub midiplay(keyindex As Integer)
- Dim T As Long
- Dim c1, c2 As Integer
- Dim start
- speed = 127
- channel = 0
- data = speed * &H10000 + (tone + keyindex) * &H100 + channel + &H90
- midiOutShortMsg mymidi, data
- If recflag = 1 Then '¼Ç¼°´¼ü¼°Ê±¼ä¼ä¸ô
- ThisWorkbook.Sheets("sheet1").Range("B" & reccount) = Timer - rectimer
- rectimer = Timer
- reccount = reccount + 1
- ThisWorkbook.Sheets("sheet1").Range("A" & reccount) = keyindex
- End If
- End Sub
- Sub keypress(KeyAscii)
- 'ÏìÓ¦°´¼ü
- 'For i = 1 To 36
- 'a = Mid("z1x2cv3b4n5ma6s7df8g9h0jq-w=er[t]y\u", i, 1)
- 'If Chr(keyascii) = a Then
- 'MsgBox i
- 'End If
- 'Next i
- On Error Resume Next
- i = Application.WorksheetFunction.Find(Chr(KeyAscii), "z1x2cv3b4n5ma6s7df8g9h0jq-w=er[t]y\u")
- midiplay i - 1
- keycolor i - 1
- End Sub
|
2楼
kuopao |
Excellent ! |
3楼
wnianzhong |
学无止境啊! |
4楼
wangqilong1980 |
学无止境啊! |
5楼
419841410 |
真厉害 |
6楼
danielxu07002 |
学会这个不知道要多久啊，年会就用电脑弹奏一首菊花台，估计能不少风头！
 |
7楼
moonlight101 |
楼主真的很有才啊~ |
8楼
v、_小乖 |
太有才了！不过就是声音有点小，很好听！ |
9楼
慢慢妮 |
高人呀，真是太厉害了
 |
10楼
sharkzhou |
有才啊。。这样都可以 |
11楼
gdgzlyh |
好多API函数，借鉴学习。 |
12楼
jiahua1010 |
楼主这个非常的强，要是有空把代码注释下更好！ |
13楼
令狐fox |
怎么我10版excel打不开呢 |
14楼
海洋之星 |
收藏了,学习 |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一