rm_dsgctrls.pas

进销存·完整的·有数据库的·非常完整·只得参考

  Dlg := TRMColorPickDlg.CreateNew(Application);
  with Dlg do
  begin
    Left := P.X;
    Top := P.Y;
    BorderIcons := [];
    BorderStyle := bsNone;
    FColorPick := TRMColorPicker.Create(Dlg);
    FColorPick.Parent := Dlg;
    FColorPick.DDSelColor := Self.FCurrentColor;
    FColorPick.DDAutoColor := FAutomaticColor;
    FColorPick.FDDIsAuto := FIsAutomatic;
    FColorPick.DDFlat := True;
    FColorPick.AutoBtn.Caption := FAutoCaption;
    FColorPick.OtherBtn.Caption := FMoreColorsCaption;
    FColorPick.Left := 0;
    FColorPick.Top := 0;
    ClientHeight := FColorPick.Height;
    ClientWidth := FColorPick.Width;
    OnKeyDown := FormKeyDown;
    OnShow := FormShow;
    OnClose := FormClose;
    SelectedColor := TargetColor;
    Drop(TRMColorPickerButton(self));
  end;
end;

procedure TRMColorPickerButton.InterAdjustSize(var W: Integer; var H: Integer);
begin
  if (csLoading in ComponentState) then
    Exit;
  if FDrawButton = nil then
    Exit;
  W := H + FDDArrowWidth;
  FDrawButton.SetBounds(0, 0, H, H);
  FBtnDropDown.SetBounds(H, 0, FDDArrowWidth, H);
end;

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

{procedure TRMColorPickerButton.WMSize(var Message: TWMSize);
var
  W, H: Integer;
begin
  inherited;
  W := Width;
  H := Height;
  InterAdjustSize(W, H);
  if (W <> Width) or (H <> Height) then
    inherited SetBounds(Left, Top, W, H);
  message.Result := 0;
end;
}
procedure TRMColorPickerButton.SetCurrentColor(Value: TColor);
begin
  if Value <> FCurrentColor then
  begin
    FCurrentColor := Value;
    FDrawButton.Color := Value;
  end;
end;

procedure TRMColorPickerButton.SetFlat(value: Boolean);
begin
  if Value <> FFlat then
  begin
    FFlat := Value;
    FDrawButton.Flat := Value;
    FBtnDropDown.Flat := Value;
  end;
end;

procedure TRMColorPickerButton.SetControlEnabled;
begin
  FDrawButton.Enabled := Enabled;
  FBtnDropDown.Enabled := Enabled;
end;

procedure TRMColorPickerButton.SetColorType(Value: TRMColorType);
begin
  if Value <> FColorType then
  begin
    FColorType := Value;
    case FColorType of
      rmptFont:
        begin
          FDrawButton.Glyph.Handle := LoadBitmap(HInstance, 'RM_FONTCOLOR');
          FAutomaticColor := clWindowText;
        end;
      rmptHighlight:
        begin
          FDrawButton.Glyph.Handle := LoadBitmap(HInstance, 'RM_HIGHLIGHTCOLOR');
          FAutomaticColor := clWindow;
        end;
      rmptFill:
        begin
          FDrawButton.Glyph.Handle := LoadBitmap(HInstance, 'RM_FILLCOLOR');
          FAutomaticColor := clNone;
        end;
      rmptLine:
        begin
          FDrawButton.Glyph.Handle := LoadBitmap(HInstance, 'RM_LINECOLOR');
          FAutomaticColor := clWindow;
        end;
      rmptCustom:
        begin
          FDrawButton.Glyph := nil;
          FAutomaticColor := clWindow;
        end;
    end;
    if FDrawButton.Glyph <> nil then
      FDrawButton.NumGlyphs := 2;
    FDrawButton.Invalidate;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
function PixelsPerCentimeter: Double;
begin
  Result := Screen.PixelsPerInch / 2.54;
end;

{ TRMDesignerRuler.Create }

constructor TRMDesignerRuler.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  Color := clBtnFace;
  Font.Color := clBtnText;
  FGuide1X := -1;
  FGuide1Y := -1;
  FGuide2X := -1;
  FGuide2Y := -1;
  FGuideHeight := 0;
  FGuideWidth := 0;
  FHalfTicks := True;
  FMargin := 0;
  FPixelIncrement := Round(Screen.PixelsPerInch / 8);
  FOrientation := roHorizontal;
  FScrollOffset := 0;
  FThickness := 1;
  FTicksPerUnit := 8;
  FTickFactor := 0.125;
  FUnits := rmsuMM;
  ChangeUnits(rmsuPixels);
//  FUnits := rmsuPixels;
//  FUnits := rmsuInches;
end;

destructor TRMDesignerRuler.Destroy;
begin
  inherited Destroy;
end;

procedure TRMDesignerRuler.Paint;
begin
  if Visible and Enabled then
  begin
    PaintRuler;
  end;
end;

procedure TRMDesignerRuler.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if FOrientation = roHorizontal then
    SetGuides(X, 0)
  else
    SetGuides(Y, 0);
  inherited MouseMove(Shift, X, Y);
end;

procedure TRMDesignerRuler.SetUnits(aUnit: TRMSizeUnits);
begin
  if FUnits = aUnit then
    Exit;
  ChangeUnits(aUnit);
end;

procedure TRMDesignerRuler.SetOrientation(aOrientation: TRMRulerOrientationType);
begin
  if FOrientation = aOrientation then
    Exit;
  FOrientation := aOrientation;
  Invalidate;
end;

procedure TRMDesignerRuler.PaintRuler;
var
  liTickLength: Integer;
  liFullTickLength: Integer;
  liTick: Integer;
  liPosition: Integer;
  liMaxLength: Integer;
  liTextHeight: Integer;
  liTextWidth: Integer;
  liDrawPosition: Integer;
  ldPosition: Double;

  procedure DrawTick;
  begin
    if FOrientation = roHorizontal then
    begin
      Canvas.MoveTo(liDrawPosition, FMargin);
      Canvas.LineTo(liDrawPosition, FMargin + liTickLength);
    end
    else
    begin
      Canvas.MoveTo(FMargin, liDrawPosition);
      Canvas.LineTo(FMargin + liTickLength, liDrawPosition);
    end;
  end;

  procedure DrawLabel;
  var
    liSpacing: Integer;
    liChar: Integer;
    liLeft: Integer;
    liTop: Integer;
    lRect: TRect;
    lsText: string[10];
  begin
    if (liTick * FTickFactor) >= 10000 then
      lsText := IntToStr(Round((liTick * FTickFactor) / 1000)) + 'k'
    else
      lsText := IntToStr(Round(liTick * FTickFactor));

    if FOrientation = roHorizontal then
    begin
      liTop := FMargin + (FDrawRect.Bottom - FDrawRect.Top) - liTextHeight;
      Canvas.TextOut(liDrawPosition + 2, liTop, lsText);
    end
    else
    begin
      liSpacing := liDrawPosition + 2;
      for liChar := 1 to Length(lsText) do
      begin
        liLeft := FMargin + (FDrawRect.Right - FDrawRect.Left) - liTextWidth - 2;
        lRect.Left := liLeft;
        lRect.Top := liSpacing;
        lRect.Right := liLeft + liTextWidth;
        lRect.Bottom := liSpacing + liTextHeight;
        Canvas.TextRect(lRect, liLeft, liSpacing, lsText[liChar]);
        liSpacing := liSpacing + liTextHeight - 2;
      end;
    end;
  end;

begin
  liPosition := 0;
  liMaxLength := 0;

  InitGuides;
  FDrawRect.Top := 0;
  FDrawRect.Left := 0;
  FDrawRect.Bottom := Self.Height;
  FDrawRect.Right := Self.Width;

  Canvas.Brush.Color := Color;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(FDrawRect);
  if FOrientation = roHorizontal then
  begin
    FDrawRect.Top := 0;
    FDrawRect.Left := 0;
    FDrawRect.Bottom := Self.Height;
    FDrawRect.Right := Self.Width;
    FDrawRect.Top := FMargin;
    FDrawRect.Bottom := Self.Height - FMargin;
    liMaxLength := FDrawRect.Right;
    liPosition := FDrawRect.Left;
  end
  else if FOrientation = roVertical then
  begin
    FDrawRect.Top := 0;
    FDrawRect.Left := 0;
    FDrawRect.Bottom := Self.Height;
    FDrawRect.Right := Self.Width;
    FDrawRect.Left := FMargin;
    FDrawRect.Right := Self.Width - FMargin;
    liMaxLength := FDrawRect.Bottom;
    liPosition := FDrawRect.Top;
  end;

  Canvas.Brush.Color := clWindow;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(FDrawRect);
  Canvas.Font.Name := 'Small Fonts';
  Canvas.Font.Style := [];
  Canvas.Font.Size := 6;
  Canvas.Font.Color := Self.Font.Color;
  liTextHeight := Canvas.TextHeight('0');
  liTextWidth := Canvas.TextWidth('0');

  if FOrientation = roHorizontal then
    liFullTickLength := FDrawRect.Bottom - FDrawRect.Top
  else
    liFullTickLength := FDrawRect.Right - FDrawRect.Left;

  Canvas.Pen.Color := Font.Color;
  Canvas.Pen.Width := 1;
  liTick := 0;
  ldPosition := 0;
  while liPosition < (liMaxLength + FScrollOffset) do
  begin
    if ((liTick mod FTicksPerUnit) = 0) or (liTick = 0) then
      liTickLength := liFullTickLength
    else if ((liTick mod (FTicksPerUnit div 2)) = 0) and FHalfTicks then
      liTickLength := liFullTickLength div 2
    else
      liTickLength := liFullTickLength div 4;

    liDrawPosition := liPosition - FScrollOffset;
    if liTickLength = liFullTickLength then
      DrawLabel;

    if (liDrawPosition >= 0) and (liTick > 0) then
      DrawTick;

    ldPosition := ldPosition + FPixelIncrement;
    liPosition := Round(ldPosition);
    Inc(liTick);
  end;
end;

procedure TRMDesignerRuler.SetGuides(aPosition1, aPosition2: Integer);
begin
  if not (Visible and Enabled) then
    Exit;

  DrawGuide(FGuide1X, FGuide1Y);
  UpdateGuidePosition(aPosition1, FGuide1X, FGuide1Y);
  DrawGuide(FGuide1X, FGuide1Y);
end;

procedure TRMDesignerRuler.InitGuides;
begin
  if FOrientation = roHorizontal then
  begin
    FMargin := (Height - Round(0.1354 * Screen.PixelsPerInch)) div 2;
    FGuideWidth := 1;
    FGuideHeight := Round(0.1354 * Screen.PixelsPerInch);
  end
  else
  begin
    FMargin := (Width - Round(0.1354 * Screen.PixelsPerInch)) div 2;
    FGuideWidth := Round(0.1458 * Screen.PixelsPerInch);
    FGuideHeight := 1;
  end;

  FGuide1X := -1;
  FGuide1Y := -1;
  FGuide2X := -1;
  FGuide2Y := -1;
end;

function TRMDesignerRuler.UpdateGuidePosition(aNewPosition: Integer; var aGuideX, aGuideY: Integer): Boolean;
var
  liNewPosition: Integer;
begin
  Result := False;

  if ((FOrientation = roHorizontal) and (aNewPosition = aGuideX)) or
    ((FOrientation = roVertical) and (aNewPosition = aGuideY)) then
    Exit;

  if (FOrientation = roHorizontal) and (aNewPosition < FDrawRect.Left) then
    liNewPosition := FDrawRect.Left
  else if (FOrientation = roVertical) and (aNewPosition > FDrawRect.Bottom) then
    liNewPosition := FDrawRect.Bottom
  else
    liNewPosition := aNewPosition;

  if FOrientation = roHorizontal then
    aGuideX := liNewPosition
  else
    aGuideY := liNewPosition;

  Result := True;
end;

procedure TRMDesignerRuler.DrawGuide(aGuideX, aGuideY: Integer);
begin
  if FOrientation = roHorizontal then
  begin
    if aGuideX = -1 then
      Exit;
    Canvas.Pen.Mode := pmNot;
    Canvas.MoveTo(aGuideX, FMargin);
    Canvas.LineTo(aGuideX, FGuideHeight + FMargin);
  end
  else
  begin
    if aGuideY = -1 then
      Exit;
    Canvas.Pen.Mode := pmNot;
    Canvas.MoveTo(FMargin, aGuideY);
    Canvas.LineTo(FGuideWidth + FMargin, aGuideY);
  end;
end;

procedure TRMDesignerRuler.ChangeUnits(aUnit: TRMSizeUnits);
var
  liUnitLabel: Integer;
  ldScreenPixelsPerUnit: Double;
begin
  if FUnits <> aUnit then
  begin
    FUnits := aUnit;
    case FUnits of
      rmsuPixels:
        begin
          liUnitLabel := Screen.PixelsPerInch;
          ldScreenPixelsPerUnit := Screen.PixelsPerInch;
          FTicksPerUnit := Round(Screen.PixelsPerInch / 10);
          FPixelIncrement := ldScreenPixelsPerUnit / FTicksPerUnit;
          FTickFactor := liUnitLabel / FTicksPerUnit;
          FHalfTicks := True;
        end;
      rmsuInches:
        begin
          liUnitLabel := 1;
          ldScreenPixelsPerUnit := Screen.PixelsPerInch;
          FTicksPerUnit := 8;
          FPixelIncrement := ldScreenPixelsPerUnit / FTicksPerUnit;
          FTickFactor := liUnitLabel / FTicksPerUnit;
          FHalfTicks := True;
        end;
      rmsuMM:
        begin
          liUnitLabel := 10000;
          ldScreenPixelsPerUnit := PixelsPerCentimeter;
          FTicksPerUnit := 5;
          FPixelIncrement := ldScreenPixelsPerUnit / FTicksPerUnit;
          FTickFactor := liUnitLabel / FTicksPerUnit;
          FHalfTicks := False;
        end;
    end;

    Invalidate;
  end;
end;

procedure TRMDesignerRuler.Scroll(Value: Integer);
var
  liOldOffset : Integer;
begin
  liOldOffset := FScrollOffset;
  FScrollOffset := FScrollOffset + Value;
  if FScrollOffset < 0 then
    FScrollOffset := 0;
  if FScrollOffset <> liOldOffset then
    Invalidate;
end;

end.