文档章节

绘制一个钢琴键盘

涂孟超
 涂孟超
发布于 2014/09/26 15:35
字数 347
阅读 15
收藏 1

刚帮朋友解决了一个小问题, 这是其中的小片段:

本例效果图:



代码文件:
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    procedure FormCreate(Sender: TObject);
  end;

  TMyShape = class(TShape)
  private
    FColorTmp: TColor;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  {黑白键组合顺序}
  Keys = '0100101001010100101001010100101001010100101001010100101001010100101001010100101001010100';
  KeyWhiteWidth = 15;   {白键宽}
  KeyBlackWidth = 10;   {黑键宽}
  KeyWhiteHeight = 88;  {白键高}
  KeyBlackHeight = 56;  {黑键高}

var
  KeyArr: array[0..87] of TMyShape; {键数组}

procedure TForm1.FormCreate(Sender: TObject);
var
  i,L: Integer;
begin
  {控件布局}
  Panel1.Align := alTop;
  Panel1.Height := KeyWhiteHeight;
  ClientWidth := (KeyWhiteWidth-1) * 52 - 1; {共 52 个白键, 这是键盘宽度}
  ClientHeight := KeyWhiteHeight;

  {画键盘}
  L := 0;
  for i := 0 to Length(Keys) - 1 do
  begin
    KeyArr[i] := TMyShape.Create(Self);
    KeyArr[i].Pen.Color := clGray;
    KeyArr[i].Parent := Panel1;
    KeyArr[i].Top := 0;

    case Keys[i+1] of
      '0': begin
        KeyArr[i].Width := KeyWhiteWidth;
        KeyArr[i].Height := KeyWhiteHeight;
        KeyArr[i].Brush.Color := clWhite;
        KeyArr[i].Left := L;
        Inc(L, KeyWhiteWidth-1);
        KeyArr[i].SendToBack;
      end;
      '1': begin
        KeyArr[i].Width := KeyBlackWidth;
        KeyArr[i].Height := KeyBlackHeight;
        KeyArr[i].Brush.Color := clBlack;
        KeyArr[i].Left := L - KeyBlackWidth div 2;
      end;
    end;
  end;
end;


{ TMyShape }

procedure TMyShape.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FColorTmp := Brush.Color;
  Brush.Color := clWebGold;
end;

procedure TMyShape.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  Brush.Color := FColorTmp;
end;

end.

 
 
 
 
 

 

 

  

窗体文件:
object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 163
  ClientWidth = 290
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    Left = 56
    Top = 48
    Width = 185
    Height = 41
    Caption = 'Panel1'
    TabOrder = 0
  end
end

 
 
 
 
 

 

 

  

本文转载自:http://www.cnblogs.com/del/archive/2009/01/09/1372254.html

共有 人打赏支持
涂孟超
粉丝 12
博文 2011
码字总数 14107
作品 0
深圳
程序员
钢琴的原理

过去的一周,我在厦门。 原来的打算,就是去海边放松一下。但是没有料到,这次旅行的一个重大收获,却是我想通了一个问题: ----为什么钢琴会发出声音? 1. 那天在鼓浪屿上面,太阳暴晒,我就...

阮一峰
2010/07/25
0
0
厉害了我的琴!钢琴教育竟然用上了AI+云计算?

随着AI技术越来越成熟,许多传统行业也逐渐向互联网+的方向发展。如果学钢琴能加入AI新科技,是不是就能将学琴者从枯燥无味的学习过程中解脱出来,钢琴老师也将happy教学呢? 近日,广东琴趣...

zabenbrdit36243qnjx1
2017/12/14
0
0
陪你的不仅有键盘还有音乐-献给深夜撸代码的你!

每个夜晚陪你度过的不仅是 敲的pa pa 响的键盘 还有那些让我们在深夜敲代码不在孤单的 音乐,今天给大家推荐的一些音乐,也是我经常听de,希望大家喜欢... 1. 君が好きだと叫びたい 《好想大声...

不空大的Timo
2017/09/10
0
0
钢琴曲演奏软件--FreePiano

FreePiano是一款使用电脑键盘演奏钢琴音曲的开源软件。 FreePiano的特点: 完全免费的,您不需要购买就可以使用全部的功能。 直接调用VSTi音源,不需要安装虚拟MIDI设备。 支持多种音频输出方...

匿名
2013/05/27
2.4K
1
“双十一”Guitar Pro 带你高姿态过光棍节

中秋国庆八天小长假,已经过去了一小段时间,大家都已经陆续回到了各自的工作岗位中去,但心思却不如以往那般沉静,比如小编我就是其中的一个,总感觉少点了啥,算算日子,十月过去,便是十一...

半夏微凉1989
2017/11/09
0
0

没有更多内容

加载失败,请刷新页面

加载更多

ubuntu 18.04 desktop 截图快捷键

如图,点击下方的 add shortcut 为这个快捷键命名 输入截图 command gnome-screenshot -a 设置快捷键 常用为 Ctrl - Alt + a 参考 http://os.51cto.com/art/200903/113091_all.htm...

公孙衍
14分钟前
0
0
一个六年Java程序员的从业总结:比起掉发,我更怕掉队

恍然间,发现自己在这个行业里已经摸爬滚打了五、六年了,原以为自己就凭已有的项目经验和工作经历怎么着也应该算得上是一个业内比较资历的人士了,但是今年在换工作的过程中却遭到了重大的挫...

老道士
17分钟前
12
1
Spacemacs快捷键

由于Spacemacs快捷键太多,为方便使用,将常用的快捷键记录在此。 以下快捷键都是在emacs的evil模式下 Buffers操作 创建名称为<buffer-name>的buffer SPC b b <buffer-name> 从已打开的buf...

yxmsw2007
21分钟前
1
0
GO冒泡,二分查找

package mainimport("fmt")func main() {var arr [5]int = [5]int{11,13,9,2,25}maopao(&arr)fmt.Println("arr = ", arr) //[2 9 11 13 25]findIndex := binaryFind(&arr, 0......

汤汤圆圆
45分钟前
1
0
工作2年半跳槽面试阿里,成功拿到offer,凭什么?

2015年刚毕业的我,进入了一家小小的公司实习工作,在学校学了三年软件开发的我,还是想去寻找一份互联网行业的工作,这样更能学以致用发挥自己的特长。一直到18年三月份,我辞掉已有的工作,...

java知识分子
49分钟前
1
0

没有更多内容

加载失败,请刷新页面

加载更多

返回顶部
顶部