tntqrctrls.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

unit TntQrCtrls;

interface

uses
  Windows, Controls, Classes, Graphics, SysUtils, TntClasses, TntControls,
  DB, TntDB, TntSysUtils, QRPrntr, QuickRpt, QRCtrls;

type
  TTntQRLabelOnPrintEvent = procedure(sender: TObject; var Value: WideString) of object;
  TTntQRCustomLabel = class(TQRCustomLabel)
  private
    FOnPrint: TTntQRLabelOnPrintEvent;
    FPrintCaption: WideString;
    FFormattedLines: TTntStrings;
    FLines: TTntStrings;
    FCurrentLine: Integer;
    UpdatingBounds: Boolean;

    function GetCaption: WideString;
    procedure SetCaption(const Value: WideString);
    procedure SetLines(const Value: TTntStrings);
  protected
    function GetCaptionBased: Boolean; virtual;
    procedure FormatLines; override;
    procedure Paint; override;
    procedure Prepare; override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure PaintToCanvas(aCanvas: TCanvas; aRect: TRect; CanExpand: Boolean; LineHeight:
      Integer);
    procedure PrintToCanvas(aCanvas: TCanvas; aLeft, aTop, aWidth, aHeight, LineHeight:
      extended;
      CanExpand: Boolean);
    procedure Print(OfsX, OfsY: Integer); override;
    procedure SetName(const Value: TComponentName); override;
    procedure CreateWindowHandle(const Params: TCreateParams); override;
    property PrintCaption: WideString read FPrintCaption write FPrintCaption;
    property CaptionBased: Boolean read GetCaptionBased;
    property OnPrint: TTntQRLabelOnPrintEvent read FOnPrint write FOnPrint;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Caption: WideString read GetCaption write SetCaption;
    property Lines: TTntStrings read FLines write SetLines;
  end;

  TTntQRLabel = class(TTntQRCustomLabel)
  published
    property Alignment;
    property AlignToBand;
    property AutoSize;
    property AutoStretch;
    property BiDiMode;
    property ParentBiDiMode;
    property Caption;
    property Color;
    property Font;
    property OnPrint;
    property ParentFont;
    property Transparent;
    property WordWrap;
  end;

  TTntQRMemo = class(TTntQRCustomLabel)
  protected
    function GetCaptionBased: Boolean; override;
  public
    procedure Paint; override;
    procedure Print(OfsX, OfsY: Integer); override;
  published
    property Alignment;
    property AlignToBand;
    property AutoSize;
    property AutoStretch;
    property BiDiMode;
    property ParentBiDiMode;
    property Color;
    property Font;
    property Lines;
    property ParentFont;
    property Transparent;
    property WordWrap;
  end;

  TTntQRDBText = class(TTntQRCustomLabel)
  private
    Field: TField;
    FieldNo: Integer;
    FieldOK: Boolean;
    DataSourceName: string;
    FDataSet: TDataSet;
    FDataField: string;
    FMask: string;
    IsMemo: Boolean;
    procedure SetDataSet(Value: TDataSet);
    procedure SetDataField(Value: string);
    procedure SetMask(Value: string);
  protected
    function GetCaptionBased: Boolean; override;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Prepare; override;
    procedure Print(OfsX, OfsY: Integer); override;
    procedure Unprepare; override;
  public
    constructor Create(AOwner: TComponent); override;
    function UseRightToLeftAlignment: Boolean; override;
  published
    property Alignment;
    property AlignToBand;
    property AutoSize;
    property AutoStretch;
    property BiDiMode;
    property ParentBiDiMode;
    property Color;
    property DataSet: TDataSet read FDataSet write SetDataSet;
    property DataField: string read FDataField write SetDataField;
    property Font;
    property Mask: string read FMask write SetMask;
    property OnPrint;
    property ParentFont;
    property Transparent;
    property WordWrap;
  end;

  TTntQRSysData = class(TTntQRCustomLabel)
  private
    FData: TQRSysDataType;
    FText: WideString;
    procedure SetData(Value: TQRSysDataType);
    procedure SetText(Value: WideString);
  protected
    procedure CreateCaption; virtual;
    procedure Print(OfsX, OfsY: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Alignment;
    property AlignToBand;
    property AutoSize;
    property BiDiMode;
    property ParentBiDiMode;
    property Color;
    property Data: TQRSysDataType read FData write SetData;
    property Font;
    property OnPrint;
    property ParentFont;
    property Text: WideString read FText write SetText;
    property Transparent;
  end;


implementation

uses
  QR3Const, Forms, TntGraphics;

type
  THackQRPrintable = class(TQRPrintable)
  end;

  THackQRFrame = class(TQRFrame)
  end;

var
  Win9xFarEast: Boolean;
  RefCanvas: TCanvas;

function BugFixExtTextOutW(DC: HDC; X, Y: Integer; Options: Longint;
  Rect: PRect; Str: PWideChar; Count: Longint; Dx: PInteger): BOOL;
var
  BitmapDC: HDC;
  OldBitmapHandle, BitmapHandle: THandle;
  DCCanvas: TCanvas;
  TempRect: TRect;
begin
  // Try to workaround the TextOutW bug to metafiles in Win9x fareast editions
  BitmapDC := CreateCompatibleDC(DC);
  DCCanvas := TCanvas.Create;
  try
    DCCanvas.Handle := BitmapDC;
    TempRect := Classes.Rect(0, 0, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
    BitmapHandle := CreateCompatibleBitmap(DC, TempRect.Right, TempRect.Bottom);
    OldBitmapHandle := SelectObject(DCCanvas.Handle, BitmapHandle);
    SetBkMode(DCCanvas.Handle, Windows.TRANSPARENT);
    SetTextColor(DCCanvas.Handle, RGB(0, 0, 0));
    PatBlt(DCCanvas.Handle, 0, 0, TempRect.Right,
      TempRect.Bottom, WHITENESS);
    SetTextAlign(DCCanvas.Handle, TA_LEFT + TA_TOP + TA_NOUPDATECP);
    DCCanvas.FillRect(TempRect);
    DCCanvas.Font.Handle := GetCurrentObject(DC, OBJ_FONT);
    Result := ExtTextOutW(DCCanvas.Handle, 0, 0, Options, @TempRect, Str, Count, Dx);
    BitBlt(DC, X, Y,
      Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
      DCCanvas.Handle, 0, 0, SRCCOPY);
    SelectObject(DCCanvas.Handle, OldBitmapHandle);
    DeleteObject(BitmapHandle);
  finally
    DCCanvas.Free;
    DeleteDC(BitmapDC);
  end;
end;

function OkToChangeFieldAlignment(AField: TField; Alignment: TAlignment): Boolean;
begin
  if Assigned(AField) then
    with AField do
      Result := (DataType < ftSmallInt) or
        (DataType = ftBoolean) or
        ((DataType > ftDateTime) and (DataType <> ftAutoInc))
  else
    Result := Alignment <> taCenter;
end;

function QRDBUseRightToLeftAlignment(AControl: TControl; AField: TField): Boolean;
var
  AAlignment: TAlignment;
begin
  if Assigned(AField) then
    AAlignment := AField.Alignment
  else
    AAlignment := taLeftJustify;

  Result := (AControl.BiDiMode = bdRightToLeft) and
    (OkToChangeFieldAlignment(AField, AAlignment));
end;

{ TTntQRCustomLabel }

constructor TTntQRCustomLabel.Create(AOwner: TComponent);
begin
  inherited;
  FLines := TTntStringList.Create;
  UpdatingBounds := False;
end;

procedure TTntQRCustomLabel.DefineProperties(Filer: TFiler);
begin
  inherited;
  TntPersistent_AfterInherited_DefineProperties(Filer, Self);
end;

destructor TTntQRCustomLabel.Destroy;
begin
  FFormattedLines.Free;
  FLines.Free;
  inherited;
end;

procedure TTntQRCustomLabel.FormatLines;
var
  I, J: Integer;
  NewLine: WideString;
  LineFinished: Boolean;
  HasParent: Boolean;
  MaxLineWidth: Integer;
  AAlignment: TAlignment;
  DefLineHeight: LongInt;

  function aLineWidth(const Line: WideString): Integer;
  begin
    if HasParent then
    begin
      Result := Muldiv(WideCanvasTextWidth(RefCanvas, Line), Zoom, 100);
    end
    else
      Result := WideCanvasTextWidth(RefCanvas, Line);
  end;

  procedure FlushLine;
  begin
    FFormattedLines.Add(NewLine);
    NewLine := '';
  end;

  procedure AddWord(aWord: WideString);
  begin
    if aLineWidth(NewLine + aWord) > Width then
    begin
      if NewLine = '' then
      begin
        while aLineWidth(NewLine + copy(aWord, 1, 1)) < Width do
        begin
          NewLine := NewLine + copy(aWord, 1, 1);
          Delete(aWord, 1, 1);
        end;
        aWord := '';
      end;
      FlushLine;
      if aLineWidth(aWord) > Width then
      begin
        if NewLine = '' then
        begin
          if Width = 0 then
            aWord := ''
          else
            while aLineWidth(aWord) > Width do
              Delete(aWord, Length(aWord), 1);
        end;
        NewLine := aWord;
        FlushLine;
        aWord := '';
      end;
      if not WordWrap then
      begin
        aWord := '';
        LineFinished := true;
      end;
    end;
    NewLine := NewLine + aWord;
  end;

  procedure AddLine(Line: WideString);
  var
    aPos: Integer;
  begin
    while pos(#10, Line) > 0 do
      Delete(Line, Pos(#10, Line), 1);
    aPos := pos(#13, Line);
    if aPos > 0 then
    begin
      repeat
        AddLine(copy(Line, 1, aPos - 1));
        Delete(Line, 1, aPos);
        aPos := pos(#13, Line);
      until aPos = 0;
      AddLine(Line);
    end
    else
    begin
      J := 0;
      NewLine := '';
      LineFinished := false;
      if AutoSize then
      begin
        NewLine := Line;
        FlushLine;
        LineFinished := True;
      end
      else
      begin
        while (J < Length(Line)) and (Length(Line) > 0) do
        begin
          repeat
            inc(J)
          until ((Line[J] = #13) or (WordWrap and ((Line[j] = '-') or (Line[j] = ' ')))
            or (J >= Length(Line)));
          AddWord(copy(Line, 1, J));
          Delete(Line, 1, J);
          J := 0;
        end;
        if not LineFinished then
          FlushLine;
      end;
    end;
  end;

  procedure FormatFromCaption;
  begin
    AddLine(FPrintCaption);
    if not UpdatingBounds and HasParent then
    begin
      UpdatingBounds := true;
      if Height < (DefLineHeight * Zoom div 100) + 1 then
        Height := (DefLineHeight * Zoom div 100) + 1;
      UpdatingBounds := false;
    end
  end;

  procedure FormatFromStringList;
  var
    J: Integer;
  begin
    if (FLines.Count <> 0) then
    begin
      if AutoSize then
        FFormattedLines.Assign(FLines)
      else
        for J := 0 to FLines.Count - 1 do
          AddLine(FLines[J]);
    end
    else if csDesigning in ComponentState then
    begin
      FPrintCaption := Name;
      FormatFromCaption;
      FPrintCaption := '';
    end;
  end;

begin
  if Parent <> nil then
  begin
    if assigned(FFormattedLines) then
      FFormattedLines.Clear
    else
      FFormattedLines := TTntStringList.Create;
    HasParent := ParentReport <> nil;
    LineFinished := false;
    RefCanvas.Font.Assign(Font);
    DefLineHeight := RefCanvas.TextHeight('W');
    if CaptionBased then
      FormatFromCaption
    else
      FormatFromStringList;
    if AutoSize and (not UpdatingBounds) and HasParent then
    begin
      MaxLineWidth := 0;
      for I := 0 to FFormattedLines.Count - 1 do
        if aLineWidth(FFormattedLines[I]) > MaxLineWidth then
          MaxLineWidth := aLineWidth(FFormattedLines[I]);
      if Frame.DrawLeft then
        MaxLineWidth := MaxLineWidth + Frame.Width;
      if Frame.DrawRight then
        MaxLineWidth := MaxLineWidth + Frame.Width;
      UpdatingBounds := true;
      AAlignment := Alignment;
      if UseRightToLeftAlignment then
        ChangeBiDiModeAlignment(AAlignment);
      case AAlignment of
        taCenter: Left := Left + ((Width - MaxLineWidth) div 2);
        taRightJustify: Left := Left + Width - MaxLineWidth;
      end;
      Width := MaxLineWidth;
      if (FFormattedLines.Count = 0) and (csDesigning in ComponentState) then
        Height := (DefLineHeight * Zoom div 100) + 1;
      if Height < (DefLineHeight * Zoom div 100) + 1 then
        Height := (DefLineHeight * Zoom div 100) + 1;
      UpdatingBounds := false;
    end;
  end;
end;

function TTntQRCustomLabel.GetCaption: WideString;
begin
  Result := TntControl_GetText(Self);
end;

procedure TTntQRCustomLabel.Paint;
var
  GrandParentPaint: procedure of object;
begin
  Canvas.Font.Assign(Font);
  if Canvas.Font.Size <> round(Font.Size * Zoom / 100) then
    Canvas.Font.Size := round(Font.Size * Zoom / 100);

  TMethod(GrandParentPaint).Code := @THackQRPrintable.Paint;
  TMethod(GrandParentPaint).Data := Self;
  GrandParentPaint;

  PaintToCanvas(Canvas, rect(0, 0, Width, Height), false, round(Canvas.TextHeight('W')));
  PaintCorners;
end;

procedure TTntQRCustomLabel.CreateWindowHandle(const Params: TCreateParams);
begin
  CreateUnicodeHandle(Self, Params, '');
end;

procedure TTntQRCustomLabel.PrintToCanvas(aCanvas: TCanvas; aLeft, aTop, aWidth, aHeight,
  LineHeight: extended;
  CanExpand: Boolean);
var
  aRect: TRect;
  ControlBottom: extended;
  X, Y: extended;
  SavedCaption: WideString;
  NewCaption: WideString;
  HasSaved: Boolean;
  HasExpanded: Boolean;
  Flags: Integer;
  TAFlags: Integer;
  AAlignment: TAlignment;
  AFExpanded: extended;
  OrgWidth: extended;

  function CanPrint: Boolean;
  var
    PrevTop: extended;
  begin
    Result := true;
    if Y + LineHeight > ControlBottom then
    begin
      if CanExpand and TQRCustomBand(Parent).CanExpand(LineHeight) then
      begin
        PrevTop := AFExpanded;
        TQRCustomBand(Parent).ExpandBand(LineHeight, AFExpanded, HasExpanded);
        ControlBottom := aTop + aHeight + 1 + AFExpanded;
        if ParentReport.FinalPass and not Transparent then
          with aCanvas do
          begin
            Pen.Width := 0;
            Brush.Color := Color;
            Brush.Style := bsSolid;
            FillRect(rect(QRPrinter.XPos(aLeft),
              QRPrinter.YPos(aTop + AHeight + PrevTop),
              QRPrinter.XPos(aLeft + aWidth),