pianokeyboard.pas

Delphi钢琴源码

end;

procedure TPianoButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  InMask: Boolean;
begin
  inherited MouseMove(Shift, X, Y);
  InMask := PtInMask(X, Y);
  if FPreciseShowHint and not InMask then
  begin
    if not FPrevShowHintSaved then
    begin
      ParentShowHint := False;
      FPrevShowHint := ShowHint;
      ShowHint := False;
      FPrevShowHintSaved := True;
    end;
  end else if not InMask then
  begin
    if not FPrevCursorSaved then
    begin
      FPrevCursor := Cursor;
      Cursor := crDefault;
      FPrevCursorSaved := True;
    end;
  end else
  begin
    if FPrevShowHintSaved then
    begin
      ShowHint := FPrevShowHint;
      FPrevShowHintSaved := False;
    end;
    if FPrevCursorSaved then
    begin
      Cursor := FPrevCursor;
      FPrevCursorSaved := False;
    end;
  end;
end;

procedure TPianoButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);
  DoClick := PtInMask(X, Y);
  if (FState = bsDown) then
  begin
    FState := bsUp;
    Repaint;
  end;
  if DoClick then Click;
end;

procedure TPianoButton.Click;
begin
  inherited Click;
end;

function TPianoButton.GetPalette: HPALETTE;
begin
  Result := FBitmap.Palette;
end;

procedure TPianoButton.SetBitmap(Value: TBitmap);
begin
  FBitmap.Assign(Value);
end;

procedure TPianoButton.SetBitmapUp(Value: TBitmap);
begin
  FBitmapUp.Assign(Value);
end;

procedure TPianoButton.SetBitmapDown(Value: TBitmap);
begin
  FBitmapDown.Assign(Value);
end;

procedure TPianoButton.BitmapChanged(Sender: TObject);
var
  OldCursor: TCursor;
  W, H: Integer;
begin
  AdjustBounds;
  if not ((csReading in ComponentState) or (csLoading in ComponentState)) then
  begin
    if FBitmap.Empty then
    begin
      SetBitmapUp(nil);
      SetBitmapDown(nil);
    end else
    begin
      W := FBitmap.Width;
      H := FBitmap.Height;
      OldCursor := Screen.Cursor;
      Screen.Cursor := crHourGlass;
      try
        if (FBitmapUp.Width <> W) or (FBitmapUp.Height <> H) or
          (FBitmapDown.Width <> W) or (FBitmapDown.Height <> H) then
        begin
          FBitmapUp.Width := W;
          FBitmapUp.Height := H;
          FBitmapDown.Width := W;
          FBitmapDown.Height := H;
        end;
        Create3DBitmap(FBitmap, bsUp, FBitmapUp);
        Create3DBitmap(FBitmap, bsDown, FBitmapDown);

        FHitTestMask.Free;
        FHitTestMask := MakeMask(FBitmapUp, FBitmap.TransparentColor);
      finally
        Screen.Cursor := OldCursor;
      end;
    end;
  end;
  Invalidate;
end;

procedure TPianoButton.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and Enabled then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;

procedure TPianoButton.CMFontChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TPianoButton.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TPianoButton.CMHitTest(var Message: TCMHitTest);
begin
  inherited;
  if PtInMask(Message.XPos, Message.YPos) then
    Message.Result := HTCLIENT
  else
    Message.Result := HTNOWHERE;
end;

procedure TPianoButton.CMSysColorChange(var Message: TMessage);
begin
  BitmapChanged(Self);
end;

function TPianoButton.BevelColor(const AState: TButtonState; const TopLeft: Boolean): TColor;
begin
  // clBtnHighlight
  // clBtnShadow
  if (AState = bsUp) then
  begin
    if TopLeft then
      Result := $FEFEFE else
      Result := -$FFFFF0;
  end else
  begin
    if TopLeft then
      Result := -$FFFFF0 else
      Result := $FEFEFE;
  end;
end;

procedure TPianoButton.Create3DBitmap(Source: TBitmap; const AState: TButtonState; Target: TBitmap);
type
  OutlineOffsetPts = array[1..3, 0..1, 0..12] of TPairArray;
const
  OutlinePts: OutlineOffsetPts = (
    (
    ((1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0)),
    ((-1, 0), (-1, -1), (0, -1), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0))
    ), (
    ((2, -2), (2, -1), (2, 0), (2, 1), (2, 2), (1, 2), (0, 2), (-1, 2), (-2, 2), (0, 0), (0, 0), (0, 0), (0, 0)),
    ((-2, 1), (-2, 0), (-2, -1), (-2, -2), (-1, -2), (0, -2), (1, -2), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0), (0, 0))
    ), (
    ((3, -3), (3, -2), (3, -1), (3, 0), (3, 1), (3, 2), (3, 3), (2, 3), (1, 3), (0, 3), (-1, 3), (-2, 3), (-3, 3)),
    ((-3, 2), (-3, 1), (-3, 0), (-3, -1), (-3, -2), (-3, -3), (-2, -3), (-1, -3), (0, -3), (1, -3), (2, -3), (0, 0), (0, 0)))
    );
var
  I, J, W, H, Outlines: Integer;
  R: TRect;
  OutlineMask, Overlay, NewSource: TBitmap;
begin
  if (Source = nil) or (Target = nil) then
    Exit;

  W := Source.Width;
  H := Source.Height;
  R := Rect(0, 0, W, H);

  Overlay := TBitmap.Create;
  NewSource := TBitmap.Create;
  try
    NewSource.Width := W;
    NewSource.Height := H;

    Target.Canvas.CopyMode := cmSrcCopy;
    Target.Canvas.CopyRect(R, Source.Canvas, R);

    Overlay.Width := W;
    Overlay.Height := H;

    Outlines := FBevelWidth;
    //Inc(Outlines);
    for I := 1 to Outlines do
    begin
      with NewSource.Canvas do
      begin
        CopyMode := cmSrcCopy;
        CopyRect(R, Target.Canvas, R);
      end;
      for J := 0 to 1 do
      begin
        if (AState = bsDown) and (I = Outlines) and (J = 0) then
          Continue;
        OutlineMask := MakeBorder(Source, NewSource, OutlinePts[I, J],
          FBitmap.TransparentColor);
        try
          with Overlay.Canvas do
          begin
            Brush.Color := BevelColor(AState, (J = 1));
            CopyMode := $0030032A; { PSna }
            CopyRect(R, OutlineMask.Canvas, R);
          end;
          with Target.Canvas do
          begin
            CopyMode := cmSrcAnd; { DSa }
            CopyRect(R, OutlineMask.Canvas, R);

            CopyMode := cmSrcPaint; { DSo }
            CopyRect(R, Overlay.Canvas, R);
            CopyMode := cmSrcCopy;
          end;
        finally
          OutlineMask.Free;
        end;
      end;
    end;
  finally
    Overlay.Free;
    NewSource.Free;
  end;
end;

procedure TPianoButton.DrawButtonText(Canvas: TCanvas; const Caption: string;
  TextBounds: TRect; State: TButtonState);
var
  CString: array[0..255] of Char;
begin
  StrPCopy(CString, Caption);
  Canvas.Brush.Style := bsClear;
  if State = bsDown then OffsetRect(TextBounds, 1, 1);
  DrawText(Canvas.Handle, CString, -1, TextBounds,
    DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;

procedure TPianoButton.Loaded;
var
  BigMask: TBitmap;
  R: TRect;
begin
  inherited Loaded;
  if (FBitmap <> nil) and (FBitmap.Width > 0) and (FBitmap.Height > 0) then
  begin
    FHitTestMask.Free;
    FHitTestMask := MakeMask(FBitmap, FBitmap.TransparentColor);
    BigMask := MakeMask(FBitmapUp, FBitmap.TransparentColor);
    try
      R := Rect(0, 0, FBitmap.Width, FBitmap.Height);
      FHitTestMask.Canvas.CopyMode := cmSrcAnd;
      FHitTestMask.Canvas.CopyRect(R, BigMask.Canvas, R);
    finally
      BigMask.Free;
    end;
  end;
end;

procedure TPianoButton.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('BitmapUp', ReadBitmapUpData, WriteBitmapUpData, not FBitmapUp.Empty);
  Filer.DefineBinaryProperty('BitmapDown', ReadBitmapDownData, WriteBitmapDownData, not FBitmapDown.Empty)
end;

procedure TPianoButton.ReadBitmapUpData(Stream: TStream);
begin
  FBitmapUp.LoadFromStream(Stream);
end;

procedure TPianoButton.WriteBitmapUpData(Stream: TStream);
begin
  FBitmapUp.SaveToStream(Stream);
end;

procedure TPianoButton.ReadBitmapDownData(Stream: TStream);
begin
  FBitmapDown.LoadFromStream(Stream);
end;

procedure TPianoButton.WriteBitmapDownData(Stream: TStream);
begin
  FBitmapDown.SaveToStream(Stream);
end;

procedure TPianoButton.AdjustBounds;
begin
  SetBounds(Left, Top, Width, Height);
end;

procedure TPianoButton.AdjustSize(var W, H: Integer);
begin
  if not (csReading in ComponentState) and FAutoSize and not FBitmap.Empty then
  begin
    W := FBitmap.Width;
    H := FBitmap.Height;
  end;
end;

procedure TPianoButton.SetAutoSize(Value: Boolean);
begin
  if FAutoSize <> Value then
  begin
    FAutoSize := Value;
    AdjustBounds;
  end;
end;

procedure TPianoButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
  W, H: Integer;
begin
  W := AWidth;
  H := AHeight;
  AdjustSize(W, H);
  inherited SetBounds(ALeft, ATop, W, H);
end;

procedure TPianoButton.Invalidate;
var
  R: TRect;
begin
  if (Visible or (csDesigning in ComponentState)) and
    (Parent <> nil) and Parent.HandleAllocated then
  begin
    R := BoundsRect;
    InvalidateRect(Parent.Handle, @R, True);
  end;
end;

procedure TPianoButton.SetBevelWidth(Value: TBevelWidth);
begin
  if Value > 2 then
    Value := 2;
  if Value <> FBevelWidth then
  begin
    FBevelWidth := Value;
    BitmapChanged(Self);
  end;
end;

procedure TPianoButton.SetState(const Value: TButtonState);
begin
  FState := Value;
  Repaint;
end;

{ TPianoKeyboard }

procedure TPianoKeyboard.LoadBitmapFromResource;
var
  i: Integer;
  FBitmap: TBitmap;
begin
  FBitmap := TBitmap.Create;
  try
    for i := 0 to 4 do
    begin
      //FPianoBlackImgList.ResourceLoad(rtBitmap, 'B' + IntToStr(i), clNone);
      FBitmap.LoadFromResourceName(HInstance, 'B' + IntToStr(i));
      FPianoBlackImgList.Add(FBitmap, FBitmap);
    end;
    for i := 0 to 24 do
    begin
      //FPianoWhiteImgList.ResourceLoad(rtBitmap, 'W' + IntToStr(i), clNone);
      FBitmap.LoadFromResourceName(HInstance, 'W' + IntToStr(i));
      FPianoWhiteImgList.Add(FBitmap, FBitmap);
    end;
  finally
    FBitmap.Free;
  end;
end;

procedure TPianoKeyboard.InitPianoKeyboard;
var
  i: integer;
begin
  LoadBitmapFromResource; // Load Resource File

  for i := 0 to 11 do
  begin
    FPianoButton[i] := TPianoButton.Create(Self);
    with FPianoButton[i] do
    begin
      Name := 'PianoButton' + IntToStr(i);
      Parent := Self;
      Tag := i;
      BorderStyle := bsNone;
      Top := FKeyBoardTop + 16;
      case i of
        0, 2, 4: // White Button 0,2,4
          begin
            Width := 24;
            Height := 108;
            Left := KeyBoardLeft + i * 10;
            BevelWidth := 1;
          end;
        5, 7, 9, 11: // White Button 5,7,9,11
          begin
            Width := 24;
            Height := 108;
            Left := KeyBoardLeft + 60 + (i - 5) * 10;
            BevelWidth := 1;
          end;
        1, 3: // Black Button 1,3
          begin
            Width := 18;
            Height := 77;
            Left := KeyBoardLeft + 11 + (i - 1) * 12;
            BevelWidth := 2;
          end;
        6, 8, 10: // Black Button 6,8,10
          begin
            Width := 18;
            Height := 77;
            Left := KeyBoardLeft + 71 + (i - 6) * 11;
            BevelWidth := 2;
          end;
      end;
    end;
    BtnsList.AddObject(IntToStr(i), FPianoButton[i]);
  end;

  FGroupBox := TGroupBox.Create(Self);
  with FGroupBox do
  begin
    Name := 'FGroupBox0';