cmpbarcontrol.pas

Delphi的另一款钢琴软件

procedure TCustomBarControl.DisplayBarMapContents;
begin

end;

procedure TCustomBarControl.DisplayBarMap;
var
  n, p, t : Integer;
  region : HRgn;
  rect : TRect;
  oldColor : TColor;
  s : string;
begin
  rect := ActiveRect;
  Dec (rect.Bottom, BottomMargin);

  with Canvas do
  begin
    Refresh;

    oldColor := brush.Color;
    region := CreateRectRgn (ActiveRect.left, ActiveRect.Top, ActiveRect.right, ActiveRect.bottom);
    SelectClipRgn (handle, region);
    DeleteObject (region);
    FillRect (rect);

    rect.Top := rect.Bottom;
    rect.Bottom := ActiveRect.Bottom;
    Brush.Color := clBtnFace;

    FillRect (rect);

    for n := 0 to fNoBars - 1 do
    begin
      p := fBarMap [n].fx;
      if n > 0 then
      begin
        MoveTo (p, 0);
        LineTo (p, ActiveRect.Bottom);
        s := IntToStr (HorzScrollBar.Position + n);
        TextOut (p - (fBarMap [n-1].fBeatsPerBar * fBarMap [n-1].fBeatWidth) div 2 - TextWidth (s) div 2, rect.top + 3, s);
      end;

      for t := 1 to fBarMap [n].fBeatsPerBar - 1 do
      begin
        Inc (p, fBarMap [n].fBeatWidth);
        MoveTo (p, ActiveHeight + 6);
        LineTo (p, ActiveHeight)
      end
    end;

    p := ActiveHeight;
    MoveTo (0, p);
    LineTo (ActiveRect.right, p);

    Brush.Color := oldColor;
  end
end;

function TCustomBarControl.GetActiveHeight: Integer;
begin
  result := ActiveRect.Bottom - BottomMargin
end;


procedure TCustomBarControl.HorizScrollbarScroll(Sender: TObject;
  ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
  with fIterator do if Bar <> ScrollPos then
  begin
    SetBarPosition (ScrollPos, 0, 0);
    fTrackerX := -1;
    Invalidate
  end
end;

procedure TCustomBarControl.Paint;
var pt : TPoint;
begin
  if fTrackerX <> -1 then
  begin
    fTrackerCanvas.MoveTo (fTrackerX, 0);
    fTrackerCanvas.LineTo (fTrackerX, activeRect.Bottom);
    fTrackerX := -1;
  end;

  CalcBarMap;
  if fFullPaint then
    DisplayBarMap;
  DisplayBarMapContents;
  GetCursorPos (pt);
  pt := ScreenToClient (pt);
  CursorMoved (pt);
  fFullPaint := True
end;

procedure TCustomBarControl.Reset;
begin
  fIterator.Reset;
  fIterator.SetEndPosition;
  fHorzScrollBar.Max := fIterator.Bar;
  fiterator.SetPosition (0);
  Track := 0;
end;

procedure TCustomBarControl.SetActivePosition(const Value: Integer);
var x : Integer;
begin
  if fNoBars = 0 then CalcBarMap;
  if value <> fActivePosition then
  begin
    x := CalcPosX (value);
    if (x < 0) or (x > ActiveRect.right) then
    begin
      LeftPosition := value;
      x := CalcPosX (value)
    end;

    if fTrackerX <> -1 then
    begin
      fTrackerCanvas.MoveTo (fTrackerX, 0);
      fTrackerCanvas.LineTo (fTrackerX, ActiveRect.Bottom)
    end;

    fTrackerCanvas.MoveTo (x, 0);
    fTrackerCanvas.LineTo (x, ActiveRect.Bottom);
    fTrackerX := x;
    fActivePosition := value;
  end
end;

procedure TCustomBarControl.SetLeftPosition(const Value: Integer);
begin
  if value <> fLeftPosition then
  begin
    fLeftPosition := value;
    fIterator.position := value;
    with fIterator do SetBarPosition (Bar, 0, 0);
    HorzScrollBar.Position := fIterator.bar;
    Invalidate;
  end
end;

procedure TCustomBarControl.SetMidiData(const Value: TMidiData);
begin
  if value <> fMidiData then
  begin
    fMidiData := value;
    fIterator.MidiData := value;
    Reset
  end
end;

procedure TCustomBarControl.SetQNWidth(const Value: Integer);
begin
  if (value <> fQNWidth) and (value >= 4) then
  begin
    fQNWidth := value;
    Invalidate
  end
end;

procedure TCustomBarControl.SetSelEndPos(value: Integer;
  NoInvalidate: boolean);
begin
  if value <> fSelEndPos then
  begin
    fSelEndPos := value;
    if NoInvalidate then
    begin
      fFullPaint := False;
      Repaint;
    end
    else Invalidate
  end
end;

procedure TCustomBarControl.SetSelStartPos(value: Integer;
  NoInvalidate: boolean);
begin
  if value <> fSelStartPos then
  begin
    fSelStartPos := value;
    if NoInvalidate then
    begin
      fFullPaint := False;
      Repaint;
    end
    else
      invalidate;
  end
end;

procedure TCustomBarControl.SetTrack(const Value: Integer);
begin
  if fTrack <> value then
  begin
    fTrack := value;
    Refresh
  end
end;

procedure TCustomBarControl.UpdateScrollBars;
begin
  HorzScrollBar.Width := ActiveRect.Right;
  HorzScrollBar.Top := ActiveRect.Bottom;
  VertScrollBar.Left := ActiveRect.Right;
  VertScrollBar.Height := ActiveRect.Bottom;
end;

procedure TCustomBarControl.VertScrollbarScroll(Sender: TObject;
  ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
  if ScrollPos <> vertScrollBar.Position then
  begin
    fTrackerX := -1;
    Invalidate;
    if Assigned (fOnScroll) then fOnScroll (sender, ScrollCode, ScrollPos)
  end
end;

procedure TCustomBarControl.WMEraseBkgnd(var Message: TWmEraseBkgnd);
var
  SnibRect : TRect;
  Brush : TBrush;
begin
  Brush := TBrush.Create;
  Brush.Color := clBtnFace;

  SnibRect.Left := ActiveRect.Right;
  SnibRect.Top := ActiveRect.Bottom;
  SnibRect.Right := Width;
  SnibRect.Bottom := Height;
  FillRect (Message.DC, SnibRect, Brush.Handle);

  SnibRect.Top := SnibRect.Bottom;
  SnibRect.Bottom := ActiveRect.Bottom;
  FillRect (Message.DC, SnibRect, Brush.Handle);

  Message.Result := 1;
end;

procedure TCustomBarControl.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  inherited;
  Message.Result := Message.Result or DLGC_WANTARROWS;
end;

procedure TCustomBarControl.WMKeyDown(var Message: TMessage);
begin
  inherited;
  with Message do
  case wParam of
    VK_UP, VK_DOWN : VertScrollBar.Perform (Msg, wParam, lParam);
    VK_LEFT, VK_RIGHT, VK_HOME, VK_END : HorzScrollBar.Perform (Msg, wParam, lParam);
  end
end;

procedure TCustomBarControl.WMLButtonDown(var Message: TWmLButtonDown);
begin
  if Assigned (fOnStartSelection) then
    OnStartSelection (self, CalcPosFromX (SmallPointToPoint (message.pos).x));
  inherited;
end;

procedure TCustomBarControl.WMLButtonUp(var Message: TWmLButtonDown);
begin
  if Assigned (fOnEndSelection) then
    OnEndSelection (self, CalcPosFromX (SmallPointToPoint (message.pos).x));
  inherited;
end;

procedure TCustomBarControl.WMMouseActivate(var Message: TMessage);
begin
  fFullPaint := True;
  Repaint
end;

procedure TCustomBarControl.WMMouseMove(var Message: TWmMouseMove);
begin
  CursorMoved (SmallPointToPoint (Message.pos));
  inherited;
end;

procedure TCustomBarControl.WMPaint(var Msg: TWMPaint);
var
  DC: HDC;
  PS: TPaintStruct;
  saveIndex : Integer;
begin
  DC := Msg.DC;
  if DC = 0 then DC := BeginPaint(Handle, PS);
  try
    SaveIndex := SaveDC(DC);
    try
      fCanvas.Lock;
      try
        fCanvas.Handle := DC;
        try
          Paint;
        finally
          fCanvas.Handle := 0
        end
      finally
        fCanvas.Unlock
      end
    finally
      RestoreDC(DC, SaveIndex)
    end
  finally
    if Msg.DC = 0 then EndPaint(Handle, PS);
  end
end;

procedure TCustomBarControl.WMSize(var Message: TWMSize);
begin
  inherited;
  ActiveRect := ClientRect;
  Dec (ActiveRect.Bottom, GetSystemMetrics (SM_CYHSCROLL));
  Dec (ActiveRect.right, GetSystemMetrics (SM_CXVSCROLL));
  UpdateScrollBars;
end;

{ TBar }

procedure TBar.Assign(Position, BeatsPerBar, BeatDiv, x,
  BeatWidth: Integer);
begin
  fPosition := Position;
  fBeatsPerBar := BeatsPerBar;
  fBeatDiv := BeatDiv;
  fx := x;
  fBeatWidth := BeatWidth
end;

end.