qrexport.pas

delphi7报表打印控件源码 可以设计报表

  ConvertToLines;
  StorePage;
end;

procedure TQRAbstractExportFilter.StorePage;
begin
end;

procedure TQRAbstractExportFilter.AcceptGraphic( Xoff, Yoff : extended; GControl : TControl);
begin
    inherited;
end; 

procedure TQRAbstractExportFilter.TextOut(X, Y : extended; Font : TFont; BGColor : TColor; Alignment : TAlignment; Text : string);
var
  aTextEntry : TTextEntry;
begin
  aTextEntry := TTextEntry.Create;
  with aTextEntry do
  begin
    XPos := X;
    YPos := Y;
    FText := Text;
    FAlignment := Alignment;
    TextFont := TFont.Create;
    TextFont.Assign(Font);
  end;
  Entries.Add(aTextEntry);
end;

function TQRAbstractExportFilter.GetText(X, Y : extended; var Font : TFont) : string;
var
  I : integer;
begin
  Result := '';
  for I := 0 to Entries.Count - 1 do
  begin
    if TObject(Entries[I]) is TTextEntry then
      with TTextEntry(Entries[I]) do
        if (X = XPos) and (Y = YPos) then
        begin
          Result := FText;
          Font := TextFont;
          Exit;
        end;
  end;
end;

function TQRCommaSeparatedFilter.GetFilterName : string;
begin
  Result := SqrCommaSeparated;
end;

function TQRCommaSeparatedFilter.GetDescription : string;
begin
  Result := SqrCommaSeparatedTextFilter;
end;

function TQRCommaSeparatedFilter.GetExtension : string;
begin
  Result := 'CSV'; // Do not translate
end;

procedure TQRCommaSeparatedFilter.StorePage;
var
  X, Y : integer;
  Font : TFont;
begin
  for Y := 1 to LineCount do
  begin
    for X := 1 to ColCount do
    begin
      WriteToStream('"'+GetText(X, Y, Font)+'"');
      if X = ColCount then
        WritelnToStream('')
      else
        WriteToStream(CSV_Separator);
    end;
  end;
end;

constructor TQRCSVFilter.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  QRExportFilterLibrary.AddFilter(TQRCommaSeparatedFilter);
  Separator := ',';
end;

destructor TQRCSVFilter.Destroy;
begin
  QRExportFilterLibrary.RemoveFilter(TQRCommaSeparatedFilter);
  inherited Destroy;
end;

function TQRCSVFilter.GetSeparator : char;
begin
  Result := CSV_Separator;
end;

procedure TQRCSVFilter.SetSeparator(Value : char);
begin
  CSV_Separator := Value;
end;

function FontValue(Size : integer) : integer;
begin
  if Size <= 8 then Result := 0
  else
    if Size <= 10 then Result := 1
    else
      if Size <= 12 then Result := 2
      else
        if Size <= 14 then Result := 3
        else
          if Size <= 18 then Result := 4
          else
            if Size <= 24 then Result := 5
            else
              Result := 7;
end;

function HTMLFontSizeAdjust(Size1, Size2 : integer) : string;
var
  Diff : integer;
begin
  Diff := FontValue(Size1) - FontValue(Size2);
  if Diff >= 0 then
    Result := '+' + IntToStr(Diff)
  else
    Result := IntToStr(Diff);
end;


const
  BOF       = $0009;
  BIT_BIFF5 = $0800;
  BOF_BIFF5 = BOF or BIT_BIFF5;
  BIFF_EOF = $000a;
  DIMENSIONS = $0200;
  DOCTYPE_XLS = $0010;
  LEN_RECORDHEADER = 4;
  XLACCUMROW = '___XLGlobRow';


{$ifndef QRSTANDARD}
procedure TQRXLSFilter.EndConcat;
begin
    Concatenating := false;
    Finish;
end;

procedure TQRXLSFilter.Start(PaperWidth, PaperHeight : integer; Font : TFont);
begin
     if concatenating and (FReportNum > 0 ) then
          exit;
     inc(FReportNum);
     inherited Start(PaperWidth, PaperHeight, Font);
end;

procedure TQRXLSFilter.Finish;
begin
    if not concatenating then
        inherited Finish;

end;

function TQRXLSFilter.GetFilterName : string;
begin
  Result := SqrExcel;
end;

function TQRXLSFilter.GetDescription : string;
begin
  Result := SqrExcelFile;
end;

function TQRXLSFilter.GetExtension : string;
begin
  Result := 'XLS'; // Do not translate
end;

function TQRXLSFilter.GetStreaming : boolean;
begin
  Result := true;
end;

procedure TQRXLSFilter.CreateStream(Filename : string);
var
  Buffer : array[0..4] of word;
  EvSheetRow : TQREvElement;
begin
  inherited CreateStream(Filename);
  Buffer[0] := 0;
  Buffer[1] := DOCTYPE_XLS;
  Buffer[2] := 0;
  WriteRecordHeader(BOF_BIFF5, 6);
  Stream.Write(Buffer, 6);
  Buffer[0] := 0;
  Buffer[1] := LineCount;
  Buffer[2] := 0;
  Buffer[3] := ColCount;
  Buffer[4] := 0;
  WriteRecordHeader(Dimensions, 10);
  Stream.Write(Buffer, 10);
  if (owner <> nil) and (owner is TCustomQuickRep) then begin
    EvSheetRow := TCustomQuickRep(owner).Functions.GetConstant(XLACCUMROW);
    if EvSheetRow = nil then
      TCustomQuickRep(owner).Functions.AddFunction(XLACCUMROW, '0')
    else
      TCustomQuickRep(owner).Functions.SetIntegerConstant(EvSheetRow, 0);
  end;
end;

procedure TQRXLSFilter.CloseStream;
begin
  WriteRecordHeader(BIFF_EOF, 0);
  inherited CloseStream;
end;

// CJM: Added code to update the progress bar as the data is being exported
procedure TQRXLSFilter.StorePage;
var
  I, J : integer;
  Cell, sCell : string;
  Font : TFont;
  NotUsed: extended;
  aQRPrinter: TQRPrinter;
  SheetRow: integer;
  EvSheetRow : TQREvElement;
  Env: TQREvEnvironment;
  NewPageWasForced: boolean;
  aForm: TForm;
  function StripSep(inval : string): string;
  var i : integer;
  begin
    result := '';
    for i := 1 to length(inval) do begin
      if inval[i] <> SysUtils.ThousandSeparator then
        result := result + inval[i];
    end;
  end;
begin
  SheetRow := 0;
  EvSheetRow := nil;
  Env := nil;
  aForm := nil;
  NewPageWasForced := false;
  if (owner <> nil) and (owner is TCustomQuickRep) then begin
    aQRPrinter := TCustomQuickRep(owner).QRPrinter;
    try
      Env := TCustomQuickRep(owner).Functions;
      if Env.IndexOf(XLACCUMROW) >= 0 then begin
        EvSheetRow := Env.GetConstant(XLACCUMROW);
        SheetRow := EvSheetRow.Value(nil).intResult;

        // A quick check to see if this report has forced
        // a new page.
        NewPageWasForced := SheetRow > 0;
      end;
    finally
    end;
  end
  else
    aQRPrinter := nil;

  // If the report did not force a new page, the StorePage method will
  // only get called once, after all the data has been read.  The
  // following code will change the caption of the progress form
  // so that user has some visual feedback to what is going on.
  if (not NewPageWasForced) and (LineCount > 0) then begin
    for i := pred(Screen.FormCount) downto 0 do
      with Screen.Forms[i] do
        if ClassName = 'TQRProgressForm' then begin
          aForm := Screen.Forms[i];
          break;
        end;
    if Assigned(aForm) then
      aForm.Caption := SqrWritingXLS;
  end;

  for I := 0 to LineCount - 1 do
  begin
    // If a new page was forced in the report, StorePage will be
    // called repeatedly.  The NewPageWasForced check will keep the
    // progress form from "ping-ponging"
    if (aQRPrinter <> nil) and (not NewPageWasForced) then begin
      aQRPrinter.Progress := (longint(I) * 100) div LineCount;
      Application.ProcessMessages;
    end;
    for J := 0 to ColCount - 1 do
    begin
      Cell := GetText(J + 1, I + 1, Font);
      if Cell <> '' then
      begin
        // CJM
        // Check to see what kind of value we have.  Strip out the
        // thousands separator in a copy of the value so we can check
        // to see if it is numeric.
        sCell := StripSep(Cell);
        if TextToFloat(PChar(sCell), NotUsed, fvExtended) then
          WriteData(CellDouble, SheetRow, J, sCell)
        else
          WriteData(CellLabel, SheetRow, J, Cell);
      end;
    end;
    inc(SheetRow);
  end;
  if Assigned(Env) then
    Env.SetIntegerConstant(EvSheetRow, SheetRow);
end;

procedure TQRXLSFilter.WriteRecordHeader(RecType, Size : integer);
var
  Buffer : array[0..1] of word;
begin
  Buffer[0] := RecType;
  Buffer[1] := Size;
  Stream.Write(Buffer, SizeOf(Buffer));
end;

procedure TQRXLSFilter.WriteData(CellType : TCellType; ARow, ACol: Integer; Cell : string);
const
  Attribute: Array[0..2] Of Byte = (0, 0, 0); { 24 bit bitfield }
var
  Buffer : array[0..1] of word;
  RecType : word;
  Size : word;
  AString : ShortString;
  aInt: integer;
  aDbl: double;
  Data: Pointer;
begin
  Buffer[0] := ARow;
  Buffer[1] := ACol;
  AString := Cell;
  Data := nil;

  case CellType of
    CellInteger   : begin
                    RecType := 2;
                    //Size := 9;
                    Size := 11;
                    WriteRecordHeader(RecType, Size);
                    //Size := 2;
                    Size := 4;
                    aInt := StrToInt(Cell);
                    Data := @aInt;
                  end;
    CellDouble   : begin
                    RecType := 3;
                    Size := 15;
                    WriteRecordHeader(RecType, Size);
                    Size := 8;
                    aDbl := StrToFloat(Cell);
                    Data := @aDbl;
                  end;
    CellLabel   : begin
                    RecType := 4;
                    Size := length(Cell) + 8;
                    WriteRecordHeader(RecType, Size);
                  end;
  else
    exit;
  end;
  Stream.Write(Buffer, SizeOf(Buffer));
  Stream.Write(Attribute, SizeOf(Attribute));
  if CellType = CellLabel then
    Stream.Write(AString, Length(AString) + 1)
  else
    Stream.Write(Data^, Size);
end;

constructor TQRExcelFilter.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  QRExportFilterLibrary.AddFilter(TQRXLSFilter);
end;

destructor TQRExcelFilter.Destroy;
begin
  QRExportFilterLibrary.RemoveFilter(TQRXLSFilter);
  inherited Destroy;
end;

var
  RTFFontList: TStringList;

// This is a callback function to get a list of all of the installed
// fonts.
function QRRTFEnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; stdcall;
var
  S: TStrings;
  Temp: string;
  Family: integer;
begin
  S := TStrings(Data);
  Temp := LogFont.lfFaceName;
  Family := LogFont.lfPitchAndFamily shr 4;
  if (S.Count = 0) or (AnsiCompareText(S[S.Count-1], Temp) <> 0) then
    S.AddObject(Temp, TObject(Family));
  Result := 1;
end;

procedure GetAllFonts;
var
  DC: HDC;
  LFont: TLogFont;
begin
  DC := GetDC(0);
  RTFFontList.Clear;

  try
    RTFFontList.Sorted := False;
    if Lo(GetVersion) >= 4 then
    begin
      FillChar(LFont, sizeof(LFont), 0);
      LFont.lfCharset := DEFAULT_CHARSET;
      EnumFontFamiliesEx(DC, LFont, @QRRTFEnumFontsProc, LongInt(RTFFontList), 0);
    end
    else
      EnumFonts(DC, nil, @QRRTFEnumFontsProc, Pointer(RTFFontList));
    RTFFontList.Sorted := TRUE;
  finally
    ReleaseDC(0, DC);
  end;
end;

// This function will build a RTF color tag for the specified
// color if it can find it on the list.  Colors not in this
// list will be considered black.  This should be addressed
// in a future release.
function RTFColorTag(Color : TColor): string;
var
  i: integer;
begin
  // If the color is not in the predefined list, then ignore it
  result := '';

  // Black is assumed to be the default color, we check the rest
  // of the colors
  for i := low(QRRTFColors) + 1 to high(QRRTFColors) do
    if QRRTFColors[i] = Color then
    begin
      result := '\cf' + IntToStr(i) + ' ';
      break;
    end;
end;

// Take a TColor variable and convert it to the RTF color table
function ColorToRTFColor(Color : TColor) : string;
begin
  Result := IntToHex(Color, 6);
  Result := format('\red%.1d\green%.1d\blue%.1d;',
             [StrToInt('$'+copy(Result, 5, 2)),
             StrToInt('$'+copy(Result, 3, 2)),
             StrToInt('$'+copy(Result, 1, 2))]);
end;

constructor TQRRTFLineItem.Create;
begin
  inherited Create;
  RTFItems := TList.Create;
end;

destructor TQRRTFLineItem.Destroy;
begin
  ClearLineItems;
  RTFItems.Free;
  inherited Destroy;
end;

// TQRRTFLineItem.Add
// function: Adds field to the lineitem list.  The horizontal location
// is checked to place the control in the list in the correct order
procedure TQRRTFLineItem.Add(value: TQRRTFItem);
var
  NewPos,
  nIdx: integer;
begin
  NewPos := -1;
  for nIdx := 0 to RTFItems.Count-1 do
  begin
    if TQRRTFItem(RTFItems[nIdx]).x > value.x then
    begin
      NewPos := nIdx;
      break;
    end;
  end;

  if NewPos = -1 then
    RTFItems.Add(value)
  else
    RTFItems.insert(NewPos, value)
end;

procedure TQRRTFLineItem.ClearLineItems;
var
  nIdx: integer;
begin
  for nIdx := 0 to RTFItems.Count-1 do
  begin
    TQRRTFItem(RTFItems[nIdx]).Free;
    RTFItems[nIdx] := nil;
  end;
  RTFItems.Clear;
end;

function TQRRTFExportFilter.GetDescription : string;
begin
  result := SqrRTFExportFilter;
end;

function TQRRTFExportFilter.GetFilterName : string;
begin
  result := SqrRTFFile;
end;

function TQRRTFExportFilter.GetExtension : string;
begin
  result := 'RTF';    // Do not locallize
end;

procedure TQRRTFExportFilter.Start(PaperWidth, PaperHeight : integer; Font : TFont);
var
  I : integer;
  aReport: TCustomQuickRep;
  aUnit: TQRUnit;
  IsLandScape: boolean;
begin
  if (owner <> nil) and (owner is TCustomQuickRep) then
    aReport := TCustomQuickRep(owner)
  else
    aReport := nil;

  // Starting with QR 3.0.2, the export filter's owner property
  // is set to the report that called it.  This allows us to get