文档章节

绘制一个钢琴键盘

涂孟超
 涂孟超
发布于 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
pcDuino 香蕉钢琴

前面我们已经介绍使用TouchkeyUSB Shield在Arduino上实现香蕉钢琴,Arduino是通过模拟USB HID(Human Interface Device)的方法来实现的,而在强大的pcDuino上面直接通过模拟键盘的输入就可以...

酸酸苹果汁
2013/12/24
1K
3

没有更多内容

加载失败,请刷新页面

加载更多

Confluence 6 教程:在 Confluence 中导航

当你对 Confluence 有所了解后,你会发现 Confluence 使用起来非常简单。这个教程主要是针对你使用的 Confluence 界面进行一些说明,同时向你展示在那里可以进行一些通用的任务和操作。 空间...

honeymose
今天
2
0
sed, awk 练习

1. sed打印某行到某行之间的内容 2. sed 转换大小写 将单词首字母转化大写 将所有小写转化大写 3. sed 在某一行最后面添加一个数字 4. 删除某行到最后一行 解析: {:a;N;$!ba;d} :a : 是...

Fc丶
今天
2
0
babel6升级到7,jest-babel报错:Requires Babel "^7.0.0-0", but was loaded with "6.26.3".

自从将前端环境更新到babel7,jest-babel之前是基于babel6的,执行时候就会报:Requires Babel "^7.0.0-0", but was loaded with "6.26.3". 很烦,因为连续帮好几台电脑修复这个问题,所以记...

曾建凯
今天
1
0
探索802.11ax

802.11ax承诺在真实条件下改善峰值性能和最差情况。 如何改善今天的Wi-Fi? 在决定如何改进当前版本以外的Wi-Fi时,802.11ac,IEEE和Wi-Fi联盟调查了Wi-Fi部署和行为,以确定更广泛使用的障碍...

linuxprobe16
今天
2
0
使用linux将64G的SDCARD格式化为FAT32

一、命令如下: sudo fdisk -lsudo mkfs.vfat /dev/sda -Isudo fdisk /dev/sda Welcome to fdisk (util-linux 2.29.2). Changes will remain in memory only, until you decide to wri......

mbzhong
今天
4
0

没有更多内容

加载失败,请刷新页面

加载更多

返回顶部
顶部