fctrackbar.pas

一套及时通讯的原码

         end;

         case Msg.Message of
            WM_MOUSEMOVE: begin
               if FirstTime then begin
                  if (abs(X-ACursor.X)<=2) and (abs(y-ACursor.Y)<=2) then continue;  // Some tolerance
                  if TrackBar.orientation = trfcHorizontal then
                  begin
                    DragOffset:= X;
                    SetValue(Left - Trackbar.SpacingLeftTop +  ACursor.X-DragOffset);
                  end
                  else begin
                    DragOffset:= Y;
                    SetValue(Top - Trackbar.SpacingLeftTop +  ACursor.Y-DragOffset);
                  end;

                  FirstTime:= False;
                  DraggingThumb:= True;
               end
               else begin
                  if TrackBar.orientation = trfcHorizontal then
                     SetValue(Left - Trackbar.SpacingLeftTop + ACursor.X-DragOffset)
                  else
                     SetValue(Top - Trackbar.SpacingLeftTop + ACursor.Y-DragOffset)
               end
            end;

            WM_LBUTTONUP: begin
               if not FirstTime then
               begin
                  if Assigned(FOnEndDrag) then OnEndDrag(self);
               end;
               if GetCapture = CaptureHandle then ReleaseCapture;
               DraggingThumb:= False;
               if fcUseThemes(Trackbar) then Trackbar.Invalidate;
               TranslateMessage(Msg);
               DispatchMessage(Msg);
            end

            else begin
               TranslateMessage(Msg);
               DispatchMessage(Msg);
            end
         end { Case }
      end;
   finally
       if GetCapture = CaptureHandle then ReleaseCapture;
   end;
end;

procedure TfcTrackIcon.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if Parent.CanFocus then Parent.SetFocus;
   if not (ssRight in Shift) then MouseLoop_Drag(X,Y);
end;

constructor TfcTrackBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Caption:= '';
  FInverted:= False;
  FTextAttributes:= TfcTrackBarText.create(self);
  ControlStyle := ControlStyle + [csReplicatable];
  ParentColor:=True;
  FSpacingLeftTop:= 5;
  FSpacingRightBottom:= 5;
  FSpacingEdgeTrackbar:= 2;
  Width := 150;
  Height := 45;
  TabStop := True;
  FMin := 0;
  FMax := 10;
  FPosition := 0;
  FIncrement := 1.0;
  FPageSize := 2;
  FFrequency := 1;
  FSelStart := 0;
  FSelEnd := 0;
  FThumbLength := 20;
  FThumbThickness:= 10;
  FTickMarks := tmfcBottomRight;
  FTickStyle := tsfcAuto;
  FOrientation := trfcHorizontal;
  ControlStyle := ControlStyle - [csDoubleClicks];
  FSliderVisible := True;
  FThumbTrackSeparation:=5;
  TrackButton:= TfcTrackIcon.create(self);
//  TrackButton.parent:= self;
  FTrackThumbIcon:= TBitmap.Create;
  FThumbColor:= clBtnFace;

  FDataLink := TFieldDataLink.Create;
  FDataLink.Control := Self;
  FDataLink.OnDataChange := DataChange;
  FDataLink.OnUpdateData := UpdateData;

  BevelInner:= bvNone;
  BevelOuter:= bvNone;
  TrackColor:= clWhite;
  TrackPartialFillColor:= clNone;
end;

destructor TfcTrackBar.Destroy;
begin
  FDataLink.OnDataChange := nil;
  FDataLink.Free;
  FDataLink := nil;
  TrackButton.Free;
  TrackButton:=nil;
  TrackThumbIcon.Free;
  if FRepeatTimer <> nil then
    FRepeatTimer.Free;
  FTextAttributes.Free;
  inherited Destroy;
end;

procedure TfcTrackBar.SetThumbIcon(Value: TBitmap);
begin
   FTrackThumbIcon.Assign(Value);
   Invalidate;
end;

Function TfcTrackBar.GetThumbIcon: TBitmap;
begin
  result:= FTrackThumbIcon;
end;

procedure TfcTrackBar.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  ControlStyle := ControlStyle - [csAcceptsControls];
  //, csCaptureMouse, csClickEvents,
//    csSetCaption, csOpaque, csDoubleClicks, csReplicatable];
end;

procedure TfcTrackBar.CreateWnd;
var dest, source: TRect;
begin
  inherited CreateWnd;
  if HandleAllocated then
  begin
     with TrackButton do begin
       Parent:= self;
       if not TrackthumbIcon.Empty then
       begin
//         TrackBmp.height:= ThumbLength;
         TrackBmp.height:= TrackThumbIcon.Height; ;
         TrackBmp.width:= TrackThumbIcon.Width;
         dest:= Rect(0, 0, TrackBmp.width, TrackBmp.height);
         source:= Rect(0, 0, TrackThumbIcon.Width, TrackThumbIcon.height);
         TrackBmp.Canvas.CopyRect(dest, TrackThumbIcon.Canvas,source);
       end;
       if orientation = trfcHorizontal then
       begin
         Height:= ThumbLength;
         if TrackBmp.Empty then
            Width:= ThumbThickness
         else
            Width:= TrackBmp.Width;
       end
       else begin
         Width:= ThumbLength;
         if TrackBmp.Empty then
            Height:= ThumbThickness
         else
//            Height:= TrackBmp.Width;
            Height:= TrackBmp.Height;
       end;
//       if TrackBmp.Empty then
//          Width:= self. -5
//       else Height:= TrackBmp.Height;

//       if TrackBmp.Empty then
//          Height:= self.height -5
//       else Height:= TrackBmp.Height;

       if orientation = trfcHorizontal then
       begin
         Left:= 1;
         Top:= GetTrackBarRect.Top-FThumbTrackSeparation+2; // Icon is 6 pixels above trackbar fill rectangle
       end
       else begin
         Top:= 1;
         Left:= GetTrackBarRect.Left-FThumbTrackSeparation+2; // Icon is 6 pixels above trackbar fill rectangle
       end;
       OnEndDrag:= UpdateFromButton;
       if orientation = trfcHorizontal then
         TrackButton.Left:=
            GetTrackBarRect.Left + ValToPixel(Position) - (TrackButton.Width div 2)
       else
         TrackButton.Top:=
            GetTrackBarRect.Top + ValToPixel(Position) - (TrackButton.Height div 2);
     end;
     UpdateSelection;
  end;

end;

procedure TfcTrackBar.UpdateFromButton(Sender: TObject);
begin
end;

procedure TfcTrackBar.DestroyWnd;
begin
  inherited DestroyWnd;
end;

procedure TfcTrackBar.CNHScroll(var Message: TWMHScroll);
begin
  inherited;
  Changed;
  Message.Result := 0;
end;

procedure TfcTrackBar.CNVScroll(var Message: TWMVScroll);
begin
  inherited;
  Changed;
  Message.Result := 0;
end;

function TfcTrackBar.GetThumbLength: Integer;
begin
    Result := FThumbLength;
end;

function TfcTrackBar.GetThumbThickness: Integer;
begin
    Result := FThumbThickness
end;

procedure TfcTrackBar.SetOrientation(Value: TfcTrackBarOrientation);
begin
  if Value <> FOrientation then
  begin
    FOrientation := Value;
    if ComponentState * [csLoading, csUpdating] = [] then
      SetBounds(Left, Top, Height, Width);
    RecreateWnd;
  end;
end;

procedure TfcTrackBar.SetParams(APosition, AMin, AMax: Double);
begin
  if AMax < AMin then
    raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  if APosition < AMin then APosition := AMin;
  if APosition > AMax then APosition := AMax;
  if (AMax - AMin > MaxAutoTicks) <> (FMax - FMin > MaxAutoTicks) then
  begin
    FMin := AMin;
    FMax := AMax;
    RecreateWnd;
  end;
  if (FMin <> AMin) then
  begin
    FMin := AMin;
  end;
  if (FMax <> AMax) then
  begin
    FMax := AMax;
  end;

  if FPosition <> APosition then
  begin
    PositionChanging;

    if (not EffectiveReadOnly) or SkipEdit then
       FPosition := fcMaxFloat(FMin, APosition);
    Changed;
    if (DataSource<>nil) and (DataSource.State in [dsEdit, dsInsert]) then
        FDatalink.modified;
  end;

end;

procedure TfcTrackBar.SetPosition(Value: Double);
const Tolerance = 0.005;
begin

  if abs(FPosition-Value)>=(Increment/2) then  // Tolerance is 1/2 of increment
  begin
    if Value>FPosition then
       Value:= FPosition + Increment * Round((Value-FPosition)/Increment)
    else
       Value:= FPosition - Increment * Round((FPosition-Value)/Increment);

    // Round to multiple of increment
    Value:= Round(Value / Increment) * Increment;

    if Value>FMax then Value:= FMax
    else if Value<FMin then Value:= FMin
  end;
  if abs(FPosition-Value)+Tolerance>=Increment then begin // Now make sure it is at least of increment size before adjustnig position
    invalidate;
    SetParams(Value, FMin, FMax);

    if orientation = trfcHorizontal then
       TrackButton.Left:=
         GetTrackBarRect.Left + ValToPixel(Value) - (TrackButton.Width div 2)
    else begin
       TrackButton.Top:=
           GetTrackBarRect.top + ValToPixel(Value) - (TrackButton.Height div 2)
    end
  end;

end;

procedure TfcTrackBar.SetMin(Value: Double);
begin
  if Value <= FMax then
    SetParams(FPosition, Value, FMax);
  FMin:=Value;
end;

procedure TfcTrackBar.SetMax(Value: Double);
begin
  if Value >= FMin then
    SetParams(FPosition, FMin, Value);
  FMax:= Value;
end;

procedure TfcTrackBar.SetFrequency(Value: Double);
begin
  if Value <> FFrequency then
  begin
    FFrequency := Value;
    Invalidate;
  end;
end;

{procedure TfcTrackBar.SetTick(Value: Integer);
begin
  if HandleAllocated then
    SendMessage(Handle, TBM_SETTIC, 0, Value);
end;
}
procedure TfcTrackBar.SetTickStyle(Value: TfcTickStyle);
begin
  if Value <> FTickStyle then
  begin
    FTickStyle := Value;
    RecreateWnd;
  end;
end;

procedure TfcTrackBar.SetTickMarks(Value: TfcTickMark);
begin
  if Value <> FTickMarks then
  begin
    FTickMarks := Value;
    RecreateWnd;
  end;
end;

procedure TfcTrackBar.SetIncrement(Value: Double);
begin
  if (Value <> FIncrement) then
  begin
    if Value=0 then Value:= 1;
    FIncrement := Value;
  end;
end;

procedure TfcTrackBar.SetPageSize(Value: Integer);
begin
  if Value <> FPageSize then
  begin
    FPageSize := Value;
  end;
end;

procedure TfcTrackBar.SetThumbLength(Value: Integer);
begin
  if Value <> FThumbLength then
  begin
    FThumbLength := Value;
    with TrackButton do begin
       if orientation = trfcHorizontal then
       begin
         if TrackBmp.Empty then
            Height:= ThumbLength;
       end
       else begin
         if TrackBmp.Empty then
            Width:= ThumbLength;
       end
    end;
    Invalidate;
  end;
end;

procedure TfcTrackBar.SetThumbThickness(Value: Integer);
begin
  if Value <> FThumbThickness then
  begin
    FThumbThickness := Value;
    with TrackButton do begin
       if orientation = trfcHorizontal then
       begin
         if TrackBmp.Empty then