rm_common.pas

来自「report machine 2.3 功能强大」· PAS 代码 · 共 2,143 行 · 第 1/4 页

    FillRect(Rect);
    BmpWidth := 20;
    if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0 then
      Bitmap := FTrueTypeBMP
    else if (Integer(Items.Objects[Index]) and DEVICE_FONTTYPE) <> 0 then
      Bitmap := FDeviceBMP
    else Bitmap := nil;
    if Bitmap <> nil then
    begin
      BmpWidth := Bitmap.Width;
      BrushCopy(Bounds(Rect.Left + 2, (Rect.Top + Rect.Bottom - Bitmap.Height)
        div 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
        Bitmap.Height), Bitmap.TransparentColor);
    end;
    StrPCopy(Text, Items[Index]);
    Rect.Left := Rect.Left + BmpWidth + 6;
    if FUseFonts and (Integer(Items.Objects[Index]) and WRITABLE_FONTTYPE <> 0) then
    begin
      Font.Name := Items[Index];
    end;
    DrawText(Handle, Text, StrLen(Text), Rect,
{$IFDEF Delphi5}
      DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX));
{$ELSE}
      DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
{$ENDIF}
  end;
end;

procedure TRMFontComboBox.WMFontChange(var Message: TMessage);
begin
  inherited;
  Reset;
end;

procedure TRMFontComboBox.Change;
var
  I: Integer;
begin
  inherited Change;
  if Style <> csDropDownList then
  begin
    I := Items.IndexOf(inherited Text);
    if (I >= 0) and (I <> ItemIndex) then
    begin
      ItemIndex := I;
      DoChange;
    end;
  end;
end;

procedure TRMFontComboBox.Click;
begin
  inherited Click;
  DoChange;
end;

procedure TRMFontComboBox.DoChange;
begin
  if not (csReading in ComponentState) then
  begin
    if not FUpdate and Assigned(FOnChange) then FOnChange(Self);
  end;
end;

procedure TRMFontComboBox.Reset;
var
  SaveName: TFontName;
begin
  if HandleAllocated then
  begin
    FUpdate := True;
    try
      SaveName := FontName;
      PopulateList;
      FontName := SaveName;
    finally
      FUpdate := False;
      if FontName <> SaveName then DoChange;
    end;
  end;
end;

procedure TRMFontComboBox.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Init;
end;

procedure TRMFontComboBox.CMFontChange(var Message: TMessage);
begin
  inherited;
  Reset;
end;

procedure TRMFontComboBox.Init;
begin
  if GetFontHeight(Font) > FTrueTypeBMP.Height then
    ItemHeight := GetFontHeight(Font)
  else
    ItemHeight := FTrueTypeBMP.Height + 1;
  RecreateWnd;
end;

procedure TRMFontComboBox.CNCommand(var Message: TWMCommand);
var
  pnt: TPoint;
begin
  inherited;
  if not FUseFonts then exit;
  if (Message.NotifyCode in [CBN_CLOSEUP]) then
  begin
    FRMFontViewForm.Visible := False;
    if (ItemIndex = -1) or (ItemIndex = 0) then exit;
  end;
  if (Message.NotifyCode in [CBN_DROPDOWN]) then
  begin
    if ItemIndex < 5 then
      PostMessage(FListHandle, LB_SETCURSEL, 0, 0);
    pnt.x := (Self.Left) + Self.width;
    pnt.y := (Self.Top) + Self.height;
    pnt := Parent.ClientToScreen(pnt);
    FRMFontViewForm.Top := pnt.y;
    FRMFontViewForm.Left := pnt.x;

    if FRMFontViewForm.Left + FRMFontViewForm.Width > Screen.Width then
    begin
      pnt.x := (Self.Left);
      pnt := Parent.ClientToScreen(pnt);
      FRMFontViewForm.Left := pnt.x - FRMFontViewForm.Width - 1;
    end;
    if FUpDropdown then
    begin
      pnt.y := (Self.Top);
      pnt := Parent.ClientToScreen(pnt);
      FRMFontViewForm.Top := pnt.y - FRMFontViewForm.Height;
    end;
    FRMFontViewForm.Visible := True;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMColorSelector}

{constructor TRMColorSelector.Create(AOwner: TComponent);
var
  b: TSpeedButton;
  i, j: Integer;
  bmp: TBitmap;
begin
  inherited Create(AOwner);
  Visible := FALSE;
  Parent := AOwner as TWinControl;
  Width := 96; Height := 132;
  bmp := TBitmap.Create;
  bmp.Width := 16; bmp.Height := 17;
  with bmp.Canvas do
  begin
    Brush.Color := clBtnFace;
    FillRect(Rect(0, 0, 16, 17));
  end;
  for i := 0 to 3 do
  begin
    for j := 0 to 3 do
    begin
      b := TSpeedButton.Create(Self);
      b.Parent := Self;
      b.SetBounds(j * 22 + 4, i * 22 + 4, 22, 22);
      with bmp.Canvas do
      begin
        Brush.Color := RMColors[i * 4 + j];
        Pen.Color := clBtnShadow;
        Rectangle(0, 0, 16, 16);
      end;
      b.Glyph.Assign(bmp);
      b.Tag := i * 4 + j;
      b.OnClick := ButtonClick;
      b.GroupIndex := 1;
      b.Flat := True;
    end;
  end;

  b := TSpeedButton.Create(Self);
  with b do
  begin
    Parent := Self;
    SetBounds(4, 92, 88, 18);
    Tag := 16;
    Caption := STransparent;
    OnClick := ButtonClick;
    GroupIndex := 1;
    Flat := True;
  end;

  FOtherBtn := TSpeedButton.Create(Self);
  with FOtherBtn do
  begin
    Parent := Self;
    SetBounds(4, 110, 88, 18);
    Tag := 17;
    Caption := SOther;
    OnClick := ButtonClick;
    GroupIndex := 1;
    Flat := True;
  end;
  bmp.Free;
end;

procedure TRMColorSelector.ButtonClick(Sender: TObject);
var
  cd: TColorDialog;
  i: Integer;
begin
  Hide;
  i := (Sender as TSpeedButton).Tag;
  case i of
    0..15: FColor := RMColors[i];
    16: FColor := clNone;
    17:
      begin
        cd := TColorDialog.Create(Self);
        cd.Options := [cdFullOpen];
        if cd.Execute then
          FColor := cd.Color
        else
          Exit;
      end;
  end;
  if Assigned(FOnColorSelected) then FOnColorSelected(Self);
end;

procedure TRMColorSelector.SetColor(Value: TColor);
var
  i, j: Integer;
  c: TSpeedButton;
  bmp: TBitmap;
begin
  for i := 0 to 16 do
  begin
    if ((i = 16) and (Value = clNone)) or (RMColors[i] = Value) then
    begin
      for j := 0 to ControlCount - 1 do
      begin
        c := Controls[j] as TSpeedButton;
        if c.Tag = i then
        begin
          c.Down := True;
          FOtherBtn.Glyph.Assign(nil);
          break;
        end;
      end;
      Exit;
    end;
  end;
  bmp := TBitmap.Create;
  bmp.Width := 12; bmp.Height := 13;
  with bmp.Canvas do
  begin
    Brush.Color := clBtnFace;
    FillRect(Rect(0, 0, 12, 13));
    Brush.Color := Value;
    Pen.Color := clBtnShadow;
    Rectangle(0, 0, 12, 12);
  end;
  FOtherBtn.Glyph.Assign(bmp);
  bmp.Free;
end;
}

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMTrackIcon}

constructor TRMTrackIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  TrackBmp := TBitmap.create;
end;

destructor TRMTrackIcon.Destroy;
begin
  TrackBmp.Free;
  TrackBmp := nil;
  inherited Destroy;
end;

procedure TRMTrackIcon.Paint;
var
  TempRect: TRect;
begin
  Canvas.Lock;
  TempRect := Rect(0, 0, TrackBmp.Width, TrackBmp.Height);
  try
    Canvas.Brush.Style := bsClear;
    Canvas.BrushCopy(TempRect, TrackBmp, TempRect,
      TrackBmp.Canvas.Pixels[0, Height - 1]);
  finally
    Canvas.Unlock;
  end;
end;

procedure TRMTrackIcon.SetBitmapName(const Value: string);
begin
  if FBitmapName <> Value then
  begin
    FBitmapName := Value;
    if Value <> '' then begin
      TrackBmp.Handle := LoadBitmap(HInstance, PChar(BitmapName));
      Width := TrackBmp.Width;
      Height := TrackBmp.Height;
    end;
    invalidate;
  end
end;


{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMRuler}
const
  rmTwipsPerInch = 1440;

constructor TRMRuler.Create(AOwner: TComponent);
var
  DC: HDC;
begin
  inherited Create(AOwner);
  Parent := TWinControl(AOwner);
  BevelInner := bvNone; //bvLowered;
  BevelOuter := bvNone;
  Caption := '';
  DC := GetDC(0);
  ScreenPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
  ReleaseDC(0, DC);

  FirstInd := TRMTrackIcon.Create(Self);
  with FirstInd do
  begin
    BitmapName := 'RM_RULERDOWN';
    Parent := Self;
    Left := 3; Top := 2;
//    SetBounds(3, 2, 16, 12);
    DragCursor := crArrow;
    OnMouseDown := OnRulerItemMouseDown;
    OnMouseMove := OnRulerItemMouseMove;
    OnMouseUp := OnFirstIndMouseUp;
  end;
  LeftInd := TRMTrackIcon.Create(Self);
  with LeftInd do
  begin
    BitmapName := 'RM_RULERUP';
    Parent := Self;
    Left := 3; Top := 12;
//    SetBounds(3, 12, 16, 12);
    DragCursor := crArrow;
    OnMouseDown := OnRulerItemMouseDown;
    OnMouseMove := OnRulerItemMouseMove;
    OnMouseUp := OnLeftIndMouseUp;
  end;
  RightInd := TRMTrackIcon.Create(Self);
  with RightInd do
  begin
    BitmapName := 'RM_RULERUP';
    Parent := Self;
    Left := 475; Top := 13;
//    SetBounds(475, 13, 15, 12);
    DragCursor := crArrow;
    OnMouseDown := OnRulerItemMouseDown;
    OnMouseMove := OnRulerItemMouseMove;
    OnMouseUp := OnRightIndMouseUp;
  end;
end;

procedure TRMRuler.Paint;
var
  i, j: integer;
  PageWidth: double;
  ScreenPixelsPerUnit: Double;
  liRect: TRect;
begin
  inherited Paint;
  ScreenPixelsPerUnit := ScreenPixelsPerInch;
  liRect := Rect(6, 4, Width - 6, Height - 4);
  with Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(liRect);

    Pen.Color := clBtnShadow;
    MoveTo(liRect.Left - 1, liRect.Bottom);
    LineTo(liRect.Left - 1, liRect.Top);
    LineTo(liRect.Right + 1, liRect.Top);

    Pen.Color := clBlack;
    MoveTo(liRect.Left, liRect.Bottom);
    LineTo(liRect.Left, liRect.Top + 1);
    LineTo(liRect.Right + 1, liRect.Top + 1);

    Pen.Color := clBtnFace;
    MoveTo(liRect.Left - 1, liRect.Bottom);
    LineTo(liRect.Right + 1, liRect.Bottom);
    LineTo(liRect.Right + 1, liRect.Top);

    Pen.Color := clBtnHighlight;
    MoveTo(liRect.Left - 1, liRect.Bottom + 1);
    LineTo(liRect.Right + 2, liRect.Bottom + 1);
    LineTo(liRect.Right + 2, liRect.Top);

    PageWidth := (RichEdit.Width - 12) / ScreenPixelsPerUnit;
    for i := 0 to trunc(pageWidth) + 1 do
    begin
      if (i >= PageWidth) then continue;
      if i > 0 then
        TextOut(Trunc(liRect.Left + i * ScreenPixelsPerUnit - TextWidth(inttostr(i)) div 2),
          liRect.Top + 3, inttostr(i));
      for j := 1 to 3 do
      begin
        Pen.color := clBlack;
        if (i + j / 4 >= PageWidth) then Continue;

        if (j = 4 div 2) then
        begin
          MoveTo(liRect.Left + Trunc((i + (j / 4)) * ScreenPixelsPerUnit), liRect.Top + 7);
          LineTo(liRect.Left + Trunc((i + (j / 4)) * ScreenPixelsPerUnit), liRect.Bottom - 5);
        end
        else begin
          MoveTo(liRect.Left + Trunc((i + (j / 4)) * ScreenPixelsPerUnit), liRect.Top + 8);
          LineTo(liRect.Left + Trunc((i + (j / 4)) * ScreenPixelsPerUnit), liRect.Bottom - 7);
        end
      end
    end;
  end;
end;

procedure TRMRuler.DrawLine;
var
  P: TPoint;
begin
  FLineVisible := not FLineVisible;
  P := Point(0, 0);
  Inc(P.X, FLineOfs);
  with P, RichEdit do
  begin
    MoveToEx(FLineDC, X, Y, nil);
    LineTo(FLineDC, X, Y + ClientHeight);
  end;
end;

procedure TRMRuler.CalcLineOffset(Control: TControl);
var
  P: TPoint;
begin
  with Control do P := ClientToScreen(Point(0, 0));
  P := RichEdit.ScreenToClient(P);
  FLineOfs := P.X + FDragOfs;
end;

function TRMRuler.IndentToRuler(Indent: Integer; IsRight: Boolean): Integer;
var
  R: TRect;
  P: TPoint;
begin
  Indent := Trunc(Indent * RulerAdj);
  with RichEdit do
  begin
    SendMessage(Handle, EM_GETRECT, 0, Longint(@R));
    if IsRight then
    begin
      P := R.BottomRight;
      P.X := P.X - Indent;
    end
    else
    begin
      P := R.TopLeft;
      P.X := P.X + Indent;
    end;
    P := ClientToScreen(P);
  end;

  P := ScreenToClient(P);
  Result := P.X;
end;

function TRMRuler.RulerToIndent(RulerPos: Integer; IsRight: Boolean): Integer;
var
  R: TRect;
  P: TPoint;
begin
  P.Y := 0; P.X := RulerPos;
  P := ClientToScreen(P);
  with RichEdit do
  begin
    P := ScreenToClient(P);
    SendMessage(Handle, EM_GETRECT, 0, Longint(@R));
    if IsRight then
      Result := R.BottomRight.X - P.X
    else
      Result := P.X - R.TopLeft.X;
  end;
  Result := Trunc(Result / RulerAdj);
end;

procedure TRMRuler.UpdateInd;
begin
  with RichEdit.Paragraph do
  begin
    FirstInd.Left := IndentToRuler(FirstIndent, False) - (FirstInd.Width div 2);
    LeftInd.Left := IndentToRuler(LeftIndent + FirstIndent, False) - (LeftInd.Width div 2);
    RightInd.Left := IndentToRuler(RightIndent, True) - (RightInd.Width div 2);
  end;
end;

procedure TRMRuler.OnRulerItemMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDragOfs := (TControl(Sender).Width div 2);
  TControl(Sender).Left := Max(0, TControl(Sender).Left + X - FDragOfs);
  FLineDC := GetDCEx(RichEdit.Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS
    or DCX_LOCKWINDOWUPDATE);
  FLinePen := SelectObject(FLineDC, CreatePen(PS_DOT, 1, ColorToRGB(clWindowText)));
  SetROP2(FLineDC, R2_XORPEN);
  CalcLineOffset(TControl(Sender));
  DrawLine;
  FDragging := True;
end;

procedure TRMRuler.OnRulerItemMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin
  if FDragging then
  begin
    DrawLine;
    TControl(Sender).Left := Min(Max(0, TControl(Sender).Left + X - FDragOfs),
      ClientWidth - FDragOfs * 2);
    CalcLineOffset(TControl(Sender));