明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 8303|回复: 49

[不死猫出品] Lisp钢琴演奏家 (完整源码+演奏乐谱)

    [复制链接]
发表于 2011-7-18 16:08 | 显示全部楼层 |阅读模式
本帖最后由 nonsmall 于 2013-4-24 17:40 编辑

呵呵 工作之余还可以放松下下
这个简谱 大家都可以弹一弹^_^





  1. (defun c:piano()
  2.   (vl-load-com)
  3.   (setq reg_path "HKEY_LOCAL_MACHINE\\SOFTWARE\\Autodesk\\piano_v1.0")
  4.   (setq Wsh (vlax-create-object "Wscript.Shell"))
  5.   (setq WMP (vlax-get-or-create-object "wmplayer.ocx"))
  6.     (setq control (vlax-get-property WMP 'controls))
  7.     (setq setting (vlax-get-property WMP 'settings))
  8.     (setq path (vl-registry-read reg_path "path"))
  9.     (if (or (not path) (= path ""))
  10.       (setq path (strcat (vl-string-trim "\\" (vl-filename-directory (getfiled "请选择钢琴声音文件" "" "wav" 0))) "\\"))
  11.     )
  12.   (vl-registry-write reg_path "path" path)
  13.   (setq i -2)
  14.   (repeat 14
  15.   (set (read (strcat "n" (itoa i))) (Vlax-Invoke-Method wmp 'newMedia (strcat path (itoa i) ".wav") ))
  16.     (setq i (1+ i))
  17.   )
  18.   (vl-registry-write reg_path "path" path)
  19.   (print "开始弹奏")
  20.   (print "按照乐谱在小键盘上面弹奏 空格退出 <C>改变音乐文件目录")
  21.   (print)
  22.   (setq go 1)
  23.   (while go
  24.     (setq get(grread 1))
  25.     (setq wrong 1)
  26.     (cond
  27.       ((/= 2 (car get))
  28.         (setq wrong 0)
  29.       )
  30.       ((and (= 2 (car get)) (= 48 (cadr get)))
  31.         (Vlax-Put-Property wmp 'currentMedia n-2)
  32.       )
  33.       ((and (= 2 (car get)) (= 46 (cadr get)))
  34.         (Vlax-Put-Property wmp 'currentMedia n-1)
  35.       )
  36.       ((and (= 2 (car get)) (= 13 (cadr get)))
  37.         (Vlax-Put-Property wmp 'currentMedia n0)
  38.       )
  39.       ((and (= 2 (car get)) (= 43 (cadr get)))
  40.         (Vlax-Put-Property wmp 'currentMedia n10)
  41.       )
  42.       ((and (= 2 (car get)) (= 47 (cadr get)))
  43.         (Vlax-Put-Property wmp 'currentMedia n11)
  44.       )
  45.       ((and (= 2 (car get)) (= 32 (cadr get)))
  46.         (setq go nil)
  47.         (setq wrong -1)
  48.       )
  49.       ((and (= 2 (car get)) (= 99 (cadr get)))
  50.         (setq path (strcat (vl-string-trim "\\" (vl-filename-directory (getfiled "请选择钢琴声音文件" "" "wav" 0))) "\\"))
  51.         
  52.         (setq i -2)
  53.         (repeat 14
  54.           (set (read (strcat "n" (itoa i))) (Vlax-Invoke-Method wmp 'newMedia (strcat path (itoa i) ".wav") ))
  55.           (setq i (1+ i))
  56.         )
  57.         (vl-registry-write reg_path "path" path)
  58.       )
  59.       ((and (= 2 (car get)) (< 48 (cadr get)) (> 58 (cadr get)))
  60.         (Vlax-Put-Property wmp 'currentMedia (eval (read (strcat "n" (itoa (- (cadr get) 48))))))
  61.       )
  62.       (1
  63.         (setq wrong 0)
  64.       )
  65.     )
  66.     (cond
  67.       ((= wrong 1)
  68.         (print (strcat "正确弹奏" (itoa (cadr get))))
  69.       )
  70.       ((= wrong -1)
  71.         (print (strcat "退出"))
  72.       )
  73.     )
  74.   )
  75.   (vl-registry-write reg_path "path" path)
  76.   (vlax-release-object Wsh)
  77.   (vlax-release-object WMP)
  78.   (princ)
  79. )
  80. (print "nonsmall原创vlisp作品之 <<钢琴演奏 v1.0>> 使用命令:piano 推荐使用小键盘弹奏 空格退出 (电脑越快效果越好)")
  81. (princ)

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

评分

参与人数 8威望 +1 明经币 +2 金钱 +200 收起 理由
wayne_myles + 1 赞一个!haha
328302216 + 20 很给力!
zwqgdhl + 30
hhh454 + 50 原创内容,
gbhsu + 20 精品文章
alwtyp + 20
jh1005 + 30 精品文章
highflybir + 1 + 1 + 30 好程序。

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下
 楼主| 发表于 2011-7-18 16:10 | 显示全部楼层
本帖最后由 nonsmall 于 2011-7-18 16:11 编辑

源码、使用说明、声音文件都在一楼的压缩包里
免币下载



发表于 2011-7-18 16:15 | 显示全部楼层
谢谢!下来试试
发表于 2011-7-18 16:18 | 显示全部楼层
Dear Sir,
thx for source
发表于 2011-7-18 17:58 | 显示全部楼层
感谢分享!
发表于 2011-7-18 17:59 | 显示全部楼层
真是厉害!来看看
发表于 2011-7-18 18:12 | 显示全部楼层
顶下,老猫总会带给大家惊喜
发表于 2011-7-18 21:33 | 显示全部楼层
楼主厉害!
发表于 2011-7-18 21:36 | 显示全部楼层
真的是大强大啦,下载先,谢谢啦
发表于 2011-7-18 21:42 | 显示全部楼层
真的是大强大啦,下载先,谢谢啦
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 06:44 , Processed in 0.231503 second(s), 32 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表