本帖最后由 caoliu023 于 2022-8-15 06:50 编辑
2.1更新
增加保存弹奏成果，为部分功能键增加音效，修复一些bug
功能说明：
键盘0-9 U I O为演奏按键，空格 回车及鼠标右键为退出程序
键盘字母区域第二第三排共16个字母按键为音色调整
其中按键Z为鼓声音色，其它为钢琴音色
按键P为回放键，按键Q为清除之前演奏的音符
按键+ -为回放速度调整，按键E为清除手动调整
按键W为写出文件到"D:\midi.lsp"
退出音效没发声，欢迎帮忙捉虫
欢迎大家把演奏成果导出的代码发到回帖里边
这是我今天第二贴，之前基于baitang36大神的成果发了lisp版弹钢琴《源码》
然后看highflybird大神在[原创]用纯lisp播放midi音乐帖子回复了
DynamicWrapperX版本的midi演示代码，发现该方法可以调整多达16种音色,
还支持64位cad，就马上着手用highflybird大神的代码改写了本演奏回放器
本代码的and部分抄至tjuzkj【分享系列1】grread函数应用例子大汇总，源码分享！
1.0功能说明：
键盘1-7为演奏按键，空格 回车及鼠标右键为退出程序
键盘字母区域第二第三排共16个字母按键为音色调整
按键P为回放键，按键Q为清除之前演奏的音符
之前以为时间函数错误，结果是少写了一个再次获取时间的代码
时间函数
 - (defun get-time->ms(/ time8 MM SS hsec)
- (setq time8(substr(rtos(getvar "cdate")2 8)10 8))
- (setq MM(atoi(substr time8 3 2)))
- (setq SS(atoi(substr time8 5 2)))
- (setq hsec(atoi(substr time8 7 2)))
- (+(* MM 60000)(* SS 1000)(* hsec 10))
- )
1.0主程序
- (defun c:tt(/ frec lst 1H 1P 2H 2P 3H 3P 4P 5P 6P 7P DWX H JD
- JP P0 P2 P4 PHANDLE Q1 R0 ys VL X Y Z)
- (setq JP 125) ;速度
- (setq P4(* 1 JP))
- (setq P2(* 2 JP))
- (setq Q1(* 3 JP))
- (setq 1P(* 4 JP))
- (setq 1H(* 6 JP))
- (setq 2P(* 8 JP))
- (setq 2H(* 10 JP))
- (setq 3P(* 12 JP))
- (setq 3H(* 14 JP))
- (setq 4P(* 16 JP))
- (setq 5P(* 20 JP))
- (setq 6P(* 24 JP))
- (setq 7P(* 28 JP))
- (setq P0 0)
- (setq R0 0) ;休止
- (setq ys 144) ;钢琴
- (setq vl(* 127 65536)) ;音量
- (setq JD 60)
- (setq dwx(vlax-create-object "DynamicWrapperX"))
- (vlax-invoke dwx 'register "Kernel32" "Sleep" "i=l")
- (vlax-invoke dwx 'register "winmm.dll" "midiOutOpen" "i=puuuu" "r=l")
- (vlax-invoke dwx 'register "winmm.dll" "midiOutShortMsg" "i=hu" "r=l")
- (vlax-invoke dwx 'register "winmm.dll" "midiOutClose" "i=h" "r=l")
- ;;打开MIDI设备
- (setq pHandle(vlax-invoke DWX 'MemAlloc 8))
- (vlax-invoke DWX 'midiOutOpen pHandle 0 0 0 0)
- (setq h(vlax-invoke DWX 'Numget phandle "h"))
- (while(and(setq pt(grread t 15 0))
- (not(and(= 2(car pt))
- (or(= 13(cadr pt))(= 32(cadr pt)))
- )
- );_Enter Space kongg
- (not(or(=(car pt)11)(=(car pt)25)));_Right button
- );and这段是抄的tjuzkj【分享系列1】grread函数应用例子大汇总，源码分享！
- ;http://bbs.mjtd.com/forum.php?mo ... 1313&fromuid=287566
- (if(=(car pt)2)
- (progn
- (if(and x y)
- (setq lst(cons(cons x y)lst))
- )
- (cond
- ((=(cadr pt)49)(vlax-invoke dwx 'midiOutShortMsg h(C1)));1
- ((=(cadr pt)50)(vlax-invoke dwx 'midiOutShortMsg h(C2)));2
- ((=(cadr pt)51)(vlax-invoke dwx 'midiOutShortMsg h(C3)));3
- ((=(cadr pt)52)(vlax-invoke dwx 'midiOutShortMsg h(C4)));4
- ((=(cadr pt)53)(vlax-invoke dwx 'midiOutShortMsg h(C5)));5
- ((=(cadr pt)54)(vlax-invoke dwx 'midiOutShortMsg h(C6)));6
- ((=(cadr pt)55)(vlax-invoke dwx 'midiOutShortMsg h(C7)));7
- ((member(cadr pt)(list 65 97 ))(setq ys 144));a
- ((member(cadr pt)(list 83 155))(setq ys 145));s
- ((member(cadr pt)(list 68 100))(setq ys 146));d
- ((member(cadr pt)(list 70 102))(setq ys 147));f
- ((member(cadr pt)(list 71 103))(setq ys 148));g
- ((member(cadr pt)(list 72 104))(setq ys 149));h
- ((member(cadr pt)(list 74 106))(setq ys 150));j
- ((member(cadr pt)(list 75 107))(setq ys 151));k
- ((member(cadr pt)(list 76 108))(setq ys 152));l
- ((member(cadr pt)(list 90 122))(setq ys 153));z
- ((member(cadr pt)(list 88 120))(setq ys 154));x
- ((member(cadr pt)(list 67 99 ))(setq ys 155));c
- ((member(cadr pt)(list 86 118))(setq ys 156));v
- ((member(cadr pt)(list 66 98 ))(setq ys 157));b
- ((member(cadr pt)(list 78 110))(setq ys 158));n
- ((member(cadr pt)(list 77 109))(setq ys 159));m
- ((member(cadr pt)(list 80 112))(setq lst(cons(cons x y)lst))(play (reverse lst))(princ "\n回放完\n"));p
- ((member(cadr pt)(list 81 113))(setq lst nil)(princ "\n记录已清除\n"));q
- )
- )
- )
- )
- ;;关闭MIDI设备
- (vlax-invoke DWX 'midiOutClose h)
- (vlax-invoke DWX 'MemFree pHandle)
- (vlax-release-object DWX)
- (PRINC"\N完...")
- (princ)
- )
完整的源码下载
| 
发表于 2022-8-13 19:45:22
置顶卡
变色卡
显身卡
楼主