sgauge.pas

Alpha Controls 5.40,delphi上的alpha开发源码控件包。没有密码。5.40版的最新版。

//  BlendBmpByMask(FCommonData.FCacheBmp, TempBmp, TsColor(ForeColor));
//  FreeAndNil(TempBmp);
end;

procedure TsGauge.SetGaugeKind(Value: TsGaugeKind);
begin
  if Value <> FKind then begin
    FKind := Value;
    Refresh;
  end;
end;

procedure TsGauge.SetShowText(Value: Boolean);
begin
  if Value <> FShowText then begin
    FShowText := Value;
    Refresh;
  end;
end;

procedure TsGauge.SetMinValue(Value: Longint);
begin
  if Value <> FMinValue then begin
    if Value > FMaxValue then begin
      if not (csLoading in ComponentState) then begin
        raise EInvalidOperation.CreateFmt(SOutOfRange, [-MaxInt, FMaxValue - 1]);
      end;
    end;
    FMinValue := Value;
    if FCurValue < Value then FCurValue := Value;
    Refresh;
  end;
end;

procedure TsGauge.SetMaxValue(Value: Longint);
begin
  if Value <> FMaxValue then begin
    if Value < FMinValue then begin
      if not (csLoading in ComponentState) then begin
        raise EInvalidOperation.CreateFmt(SOutOfRange, [FMinValue + 1, MaxInt]);
      end;
    end;
    FMaxValue := Value;
    if FCurValue > Value then FCurValue := Value;
    Refresh;
  end;
end;

procedure TsGauge.SetProgress(Value: Longint);
var
  TempPercent: Longint;
begin
  TempPercent := GetPercentDone;
  Value := LimitIt(Value, FMinValue, FMaxValue);
  if FCurValue <> Value then begin
    FCurValue := Value;
    if TempPercent <> GetPercentDone then begin
      if not RestrictDrawing then FCommonData.BGChanged := True;
      Refresh;
    end;
    if Assigned(FOnChange) then FOnChange(Self);
  end;
end;

procedure TsGauge.AddProgress(Value: Longint);
begin
  Progress := FCurValue + Value;
  Refresh;
end;

destructor TsGauge.Destroy;
begin
  FreeAndNil(FCommonData);
  inherited Destroy;
end;

procedure TsGauge.WndProc(var Message: TMessage);
begin
  if Message.Msg = SM_ALPHACMD then case Message.WParamHi of
    AC_CTRLHANDLED : begin Message.LParam := 1; Exit end; // AlphaSkins supported
    AC_GETAPPLICATION : begin Message.Result := longint(Application); Exit end;
    AC_REMOVESKIN : if LongWord(Message.LParam) = LongWord(SkinData.SkinManager) then begin
      CommonWndProc(Message, FCommonData);
      Repaint;
      Exit
    end;
    AC_REFRESH : if (LongWord(Message.LParam) = LongWord(SkinData.SkinManager)) then begin
      CommonWndProc(Message, FCommonData);
      Repaint;
      Exit
    end;
    AC_SETNEWSKIN : if (LongWord(Message.LParam) = LongWord(SkinData.SkinManager)) then begin CommonWndProc(Message, FCommonData); exit end;
    AC_ENDPARENTUPDATE : if FCommonData.Updating then begin
      FCommonData.Updating := False;
      Repaint; Exit
    end;
  end;
  if not ControlIsReady(Self) or not Assigned(FCommonData) or not FCommonData.Skinned then inherited else begin
    if not CommonWndProc(Message, FCommonData) then inherited;
{    case Message.Msg of WM_SIZE : Repaint; end;}
  end;
end;

procedure TsGauge.SkinPaintBody(aRect: TRect);
begin
  case Kind of
    gkHorizontalBar, gkVerticalBar: SkinPaintAsBar(aRect);
    gkPie: SkinPaintAsPie(aRect);
    gkNeedle: SkinPaintAsNeedle(aRect);
  end;
  if ShowText then SkinPaintAsText(aRect);
end;

procedure TsGauge.WMEraseBkGND(var Message: TWMPaint);
begin
  
end;

procedure TsGauge.SetSuffix(const Value: string);
begin
  if FSuffix <> Value then begin
    FSuffix := Value;
    FCommonData.Invalidate;
  end;
end;

procedure TsGauge.AfterConstruction;
begin
  inherited;
  FCommonData.Loaded;
end;

procedure TsGauge.Loaded;
begin
  inherited;
  FCommonData.Loaded;
end;

procedure TsGauge.SetForeColor(const Value: TColor);
begin
  if FForeColor <> Value then begin
    FForeColor := Value;
    Repaint;
  end;
end;

procedure TsGauge.PaintBackground(AnImage: TBitmap);
var
  ARect: TRect;
begin
  with AnImage.Canvas do begin
    CopyMode := cmBlackness;
    ARect := Rect(0, 0, Width, Height);
    CopyRect(ARect, Animage.Canvas, ARect);
    CopyMode := cmSrcCopy;
  end;
end;

procedure TsGauge.SetBorderStyle(const Value: TBorderStyle);
begin
  if Value <> FBorderStyle then begin
    FBorderStyle := Value;
    Refresh;
  end;
end;

procedure TsGauge.PaintAsBar(AnImage: TBitmap; PaintRect: TRect);
var
  FillSize: Longint;
  W, H: Integer;
begin
  W := PaintRect.Right - PaintRect.Left + 1;
  H := PaintRect.Bottom - PaintRect.Top + 1;
  with AnImage.Canvas do begin
    Brush.Color := BackColor;
    FillRect(PaintRect);
    Pen.Color := ForeColor;
    Pen.Width := 1;
    Brush.Color := ForeColor;
    case FKind of
      gkHorizontalBar: begin
        FillSize := SolveForX(PercentDone, W);
        if FillSize > W then FillSize := W;
        if FillSize > 0 then FillRect(Rect(PaintRect.Left, PaintRect.Top, FillSize, H));
      end;
      gkVerticalBar: begin
        FillSize := SolveForX(PercentDone, H);
        if FillSize >= H then FillSize := H - 1;
        FillRect(Rect(PaintRect.Left, H - FillSize, W, H));
      end;
    end;
  end;
end;

procedure TsGauge.PaintAsNeedle(AnImage: TBitmap; PaintRect: TRect);
var
  MiddleX: Integer;
  Angle: Double;
  X, Y, W, H: Integer;
begin
  with PaintRect do begin
    X := Left;
    Y := Top;
    W := Right - Left;
    H := Bottom - Top;
    if FBorderStyle = bsSingle then begin
      Inc(W);
      Inc(H);
    end;
  end;
  with AnImage.Canvas do begin
    Brush.Color := Color;
    FillRect(PaintRect);
    Brush.Color := BackColor;
    Pen.Color := ForeColor;
    Pen.Width := 1;
    Pie(X, Y, W, H * 2 - 1, X + W, PaintRect.Bottom - 1, X, PaintRect.Bottom - 1);
    MoveTo(X, PaintRect.Bottom);
    LineTo(X + W, PaintRect.Bottom);
    if PercentDone > 0 then begin
      Pen.Color := ForeColor;
      MiddleX := Width div 2;
      MoveTo(MiddleX, PaintRect.Bottom - 1);
      Angle := (Pi * ((PercentDone / 100)));
      LineTo(Integer(Round(MiddleX * (1 - Cos(Angle)))),
        Integer(Round((PaintRect.Bottom - 1) * (1 - Sin(Angle)))));
    end;
  end;
end;

procedure TsGauge.PaintAsNothing(AnImage: TBitmap; PaintRect: TRect);
begin
  with AnImage do begin
    Canvas.Brush.Color := BackColor;
    Canvas.FillRect(PaintRect);
  end;
end;

procedure TsGauge.PaintAsPie(AnImage: TBitmap; PaintRect: TRect);
var
  MiddleX, MiddleY: Integer;
  Angle: Double;
  W, H: Integer;
begin
  W := PaintRect.Right - PaintRect.Left;
  H := PaintRect.Bottom - PaintRect.Top;
  if FBorderStyle = bsSingle then begin
    Inc(W);
    Inc(H);
  end;
  with AnImage.Canvas do begin
    Brush.Color := Color;
    FillRect(PaintRect);
    Brush.Color := BackColor;
    Pen.Color := ForeColor;
    Pen.Width := 1;
    Ellipse(PaintRect.Left, PaintRect.Top, W, H);
    if PercentDone > 0 then begin
      Brush.Color := ForeColor;
      MiddleX := W div 2;
      MiddleY := H div 2;
      Angle := (Pi * ((PercentDone / 50) + 0.5));
      Pie(PaintRect.Left, PaintRect.Top, W, H,
        Integer(Round(MiddleX * (1 - Cos(Angle)))),
        Integer(Round(MiddleY * (1 - Sin(Angle)))), MiddleX, 0);
    end;
  end;
end;

procedure TsGauge.PaintAsText(AnImage: TBitmap; PaintRect: TRect);
var
  S: string;
  X, Y: Integer;
  OverRect: TBitmap;
begin
  OverRect := CreateBmpLike(AnImage);
  OverRect.Canvas.Brush.Color := clWindowFrame;
  OverRect.Canvas.Brush.Style := bsSolid;
  OverRect.Canvas.FillRect(Rect(0, 0, Width, Height));
  try
    PaintBackground(OverRect);
    S := Format('%d%%', [PercentDone]);
    with OverRect.Canvas do begin
      Brush.Style := bsClear;
      Font := Self.Font;
      Font.Color := clWhite;
      with PaintRect do begin
        X := (Right - Left + 1 - TextWidth(S)) div 2;
        Y := (Bottom - Top + 1 - TextHeight(S)) div 2;
      end;
      TextRect(PaintRect, X, Y, S);
    end;
    AnImage.Canvas.CopyMode := cmSrcInvert;
    AnImage.Canvas.Draw(0, 0, OverRect);
  finally
    OverRect.Free;
  end;
end;

procedure TsGauge.SetBackColor(const Value: TColor);
begin
  if Value <> FBackColor then
  begin
    FBackColor := Value;
    Refresh;
  end;
end;

procedure TsGauge.SetProgressSkin(const Value: TsSkinSection);
begin
  if FProgressSkin <> Value then begin
    FProgressSkin := Value;
    FCommonData.Invalidate;
  end;
end;

end.