jantracker.pas

这是整套横扫千军3D版游戏的源码

    Buffer.canvas.pen.style:=pssolid;
    if FTrackBorder then
      Frame3D( Buffer.Canvas, FTrackRect, clBlack, clBtnHighlight, 1 );
  end;

  procedure DrawCaption;
  begin
    { Changed By Steve Childs 18/04/00 - Now Refers To Buffer Bitmap}
    s := intToStr(FValue);
    Buffer.canvas.brush.style:=bsclear;
    if FCaptionBold then
      Buffer.canvas.font.style:=canvas.font.style+[fsbold]
    else
      Buffer.canvas.font.style:=canvas.font.style-[fsbold];
    Buffer.canvas.font.color:=FCaptionColor;
    drawText(Buffer.canvas.handle,pchar(s),-1,FTumbRect,DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS);
  end;

  procedure DrawTumb;
  begin
    { Changed By Steve Childs 18/04/00 - Now Refers To Buffer Bitmap}
    Buffer.canvas.brush.color:=FTumbColor;
    Buffer.canvas.FillRect(FTumbRect);
    Buffer.canvas.pen.style:=pssolid;
    Frame3D( Buffer.Canvas, FTumbRect, clBtnHighlight, clBlack, 1 );
  end;

begin
  { Added By Steve Childs 18/04/00 - Added Double Buffering}
  Buffer := TBitmap.Create;
  Try
    { Added By Steve Childs 18/04/00 - Setup DoubleBuffer Bitmap}
    Buffer.Width := ClientWidth;
    Buffer.Height := ClientHeight;

    SetTumbMinMax;
    SetTumbRect;
    SetTrackRect;
    if assigned(FBackBitmap) and (FBackBitmap.Height <> 0) and (FBackBitmap.Width <> 0) then
      DrawBackBitmap
    else
      DrawBackground;
    DrawTrack;
    DrawTumb;
    if FShowCaption then
      DrawCaption;
  Finally
    { Added By Steve Childs 18/04/00 - Finally, Draw the Buffer Onto Main Canvas}
    Canvas.Draw(0,0,Buffer);
    { Added By Steve Childs 18/04/00 - Free Buffer}
    Buffer.Free;
  End;
end;

procedure TjanTracker.SetBackColor(const Value: TColor);
begin
  FBackColor := Value;
  invalidate;
end;

procedure TjanTracker.SetMaximum(const Value: integer);
begin
  if value>FMinimum then
  begin
    FMaximum := Value;
    if FValue>FMaximum then
      FValue:=FMaximum;
    UpdatePosition;
  end;
end;

procedure TjanTracker.SetMinimum(const Value: integer);
begin
  if value<FMaximum then
  begin
    FMinimum := Value;
    if FValue<FMinimum then
      FValue:=FMinimum;
    UpdatePosition;
  end;
end;

procedure TjanTracker.UpdatePosition;
var fac:extended;
begin
  fac:=(FValue-FMinimum)/(FMaximum-FMinimum);
  FTumbPosition:=FTumbMin+round((FTumbMax-FTumbMin)*fac);
  invalidate;
end;

procedure TjanTracker.SetTrackColor(const Value: TColor);
begin
  FTrackColor := Value;
  invalidate;
end;

procedure TjanTracker.SetTumbColor(const Value: TColor);
begin
  FTumbColor := Value;
  invalidate;
end;

procedure TjanTracker.SetValue(const Value: integer);
begin
  if (FValue>=FMinimum) and (FValue<=FMaximum) then
  begin
    FValue := Value;
    UpdatePosition;
    invalidate;
  end;
end;

procedure TjanTracker.SetTumbWidth(const Value: integer);
begin
  FTumbWidth := Value;
  SetTumbMinMax;
  SetTumbrect;
  SetTrackRect;
  invalidate;
end;

procedure TjanTracker.SetTumbHeight(const Value: integer);
begin
  if value<height then
  begin
    FTumbHeight := Value;
    SetTumbMinMax;
    SetTumbrect;
    SetTrackrect;
    invalidate;
  end;
end;

procedure TjanTracker.SetTrackHeight(const Value: integer);
begin
  case Orientation of
  jtbHorizontal:
  begin
    if value<(Height) then
    begin
    FTrackHeight := Value;
    setTrackrect;
    invalidate;
    end;
  end;
  jtbVertical:
  begin
    if value<(Width) then
    begin
    FTrackHeight := Value;
    setTrackrect;
    invalidate;
    end;
  end;
  end;
end;

procedure TjanTracker.SetOnChangedValue(const Value: TonChangedValue);
begin
  FonChangedValue := Value;
end;

procedure TjanTracker.SetOnMouseUpAfterChange(const Value: TOnMouseUpAfterChange);
begin
  FOnMouseUpAfterChange := Value;
end;

procedure TjanTracker.doChangedValue(NewValue: integer);
begin
  if assigned(onChangedValue) then
   onchangedvalue(self,NewValue);
end;

procedure TjanTracker.Resize;
begin
  inherited;
  SetTumbMinMax;
  SetTrackRect;
  UpdatePosition;
end;

procedure TjanTracker.SetCaptionColor(const Value: TColor);
begin
  FCaptionColor := Value;
  invalidate;
end;

procedure TjanTracker.SetShowCaption(const Value: boolean);
begin
  FShowCaption := Value;
  invalidate;
end;

procedure TjanTracker.SetBackBorder(const Value: boolean);
begin
  FBackBorder := Value;
  invalidate
end;

procedure TjanTracker.SetTrackBorder(const Value: boolean);
begin
  FTrackBorder := Value;
  invalidate
end;

procedure TjanTracker.SetTumbBorder(const Value: boolean);
begin
  FTumbBorder := Value;
  invalidate;
end;

procedure TjanTracker.SetCaptionBold(const Value: boolean);
begin
  FCaptionBold := Value;
  invalidate;
end;

procedure TjanTracker.SetOrientation(const Value: TjtbOrientation);
var
  tmp:integer;
  change: Boolean;
begin
  change := FOrientation <> Value;
  FOrientation:= Value;
  if (csDesigning in ComponentState) and (change) and  not (csReading in ComponentState) then
  begin
    tmp:=width;
    width:=height;
    height:=tmp;
  end;

  if (csDesigning in ComponentState) then
  begin
    SetTumbMinMax;
    UpdatePosition;
    SetTumbRect;
  end; //*** am not sure if this is right. It works more or less though.
  invalidate;
end;

procedure TjanTracker.SetBackBitmap(const Value: TBitmap);
begin
  FBackBitmap.assign(Value);
end;

procedure TjanTracker.BackBitmapChanged(sender: TObject);
begin
  invalidate;
end;

procedure TjanTracker.WMEraseBkgnd(var Msg: TWmEraseBkgnd);
{ Added By Steve Childs 18/04/00
  This elimates the flickering background when the thumb is updated
}
Begin
{ Added By Steve Childs 18/04/00 - Tell Windows that we have cleared background }
  msg.Result := -1
End;

procedure TjanTracker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
 inherited;
 if (ssleft in shift) then
  if FbClickWasInRect then
  begin
    {
      - Added By Steve Childs 18/04/00
      OK, we know that when the mouse button went down, the
      click was in the rect. So, we only need to check that it's now
      within the bounds of the track (otherwise the button goes off the
      end of the track!!)

    }
//    If (X >= FTrackRect.Left) and (X <= FTrackRect.Right) then
    if ptinrect(FTrackRect,point(x,y)) then  // 2-jul-2000 Jan Verhoeven
     If Orientation = jtbHorizontal then
       FTumbPosition := x
     else
       FTumbPosition := y
    Else
    Begin
      { Added By Steve Childs 18/04/00
        If it's off the edges - Set Either to left or right, depending on
        which side the mouse is!!
      }
      // 2-jul-2000 Jan Verhoeven
      if Orientation=jtbHorizontal then begin
        if x<FTrackRect.left then
          FTumbPosition := FTrackRect.Left-1
        else if x>FTrackRect.right then
          FTumbPosition := FTrackRect.Right+1
        else
          FTumbPosition:=x;
      end
      else begin
        if y<FTrackRect.top then
          FTumbPosition := FTrackRect.top-1
        else if y>FTrackRect.bottom then
          FTumbPosition := FTrackRect.bottom+1
        else
          FTumbPosition:=y;
      end;
{      If X < FTrackRect.Left then
        FTumbPosition := FTrackRect.Left-1
      else
        // Must Be Off Right
        FTumbPosition := FTrackRect.Right+1;}
    End;
    UpdateValue;
    SetTumbRect;
    invalidate;
    dochangedValue(FValue);
  end;
end;

procedure TjanTracker.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  if FbClickWasInRect then
    if Assigned(OnMouseUpAfterChange) then OnMouseUpAfterChange(Self);

  { Added By Steve Childs 18/04/00 -  Clear Flag}
  FbClickWasInRect := False;
  inherited;
end;

procedure TjanTracker.SetBorderColor(const Value: Tcolor);
begin
  FBorderColor := Value;
end;

procedure TjanTracker.SetTrackPositionColor(const Value: boolean);
begin
  FTrackPositionColor := Value;
  invalidate;
end;

end.