qrprntr.pas

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

  if PageNumber > PageCount then
    result := nil
  else
  try
    LockList;
    SeekToPage(PageNumber);
    Stream.Read(Dummy,SizeOf(Dummy));
    Stream.Read(Dummy,SizeOf(Dummy));
    BytesToGet := BytesToGet-Stream.Position;
    result := TMetafile.Create;
    if Compression then
    begin
      Stream.Read(BytesToGet,SizeOf(BytesToGet));
      TempStream := TMemoryStream.Create;
      aCompressor := TQRCompress.Create(Stream, false);
      for I := 1 to BytesToGet do
      begin
        aCompressor.Expand(aByte);
        TempStream.Write(aByte,1);
      end;
      aCompressor.Free;
      TempStream.Position := 0;
      result.LoadFromStream(TempStream);
      TempStream.Free;
    end else
      result.LoadFromStream(Stream);
    Stream.Read(Dummy, SizeOf(Dummy));
  finally
    UnlockList;
  end;
end;

procedure TQRPageList.GetPageEx(PageNumber : integer; var AMetafile : TMetafile; var AHyperlinks : TList);
var
  Dummy : longint;
  TempStream : TMemoryStream;
  aByte : byte;
  BytesToGet : longint;
  I : longint;
  LinksToGet : longint;
  ARect : TRect;
  AString : string;
begin
  if PageNumber > PageCount then
  begin
    AMetafile := nil;
    AHyperlinks := nil;
  end else
  try
    LockList;
    SeekToPage(PageNumber);
    Stream.Read(Dummy,SizeOf(Dummy));
    Stream.Read(Dummy,SizeOf(Dummy));
    BytesToGet := BytesToGet-Stream.Position;
    AMetafile := TMetafile.Create;
    if Compression then
    begin
      Stream.Read(BytesToGet,SizeOf(BytesToGet));
      TempStream := TMemoryStream.Create;
      aCompressor := TQRCompress.Create(Stream, false);
      for I := 1 to BytesToGet do
      begin
        aCompressor.Expand(aByte);
        TempStream.Write(aByte,1);
      end;
      aCompressor.Free;
      TempStream.Position := 0;
      AMetafile.LoadFromStream(TempStream);
      TempStream.Free;
    end else
    begin
      AMetafile.LoadFromStream(Stream);
      Stream.Read(LinksToGet, Sizeof(LinksToGet));
      if LinksToGet > 0 then
      begin
        AHyperlinks := TList.Create;
        for I := 0 to LinksToGet - 1 do
        begin
          Stream.Read(ARect, SizeOf(ARect));
          Stream.Read(dummy, sizeOf(Dummy));
          SetLength(AString, Dummy);
          Stream.Read(AString[1], Dummy);
          AHyperlinks.Add(THyperlink.Create(ARect, AString));
        end
      end else
        AHyperlinks := nil;
    end;
    Stream.Read(Dummy, SizeOf(Dummy));
  finally
    UnlockList;
  end;
end;

procedure TQRPageList.ReadFileHeader;
var
  aFileHeader : TQRFileHeader;
begin
  Stream.Position := 0;
  Stream.Read(aFileHeader, GetFileHeaderSize(Stream));
  FixupFileHeader(Stream, aFileHeader);
  FPageCount := aFileHeader.PageCount;
end;

procedure TQRPageList.WriteFileHeader;
var
  aFileHeader : TQRFileHeader;
begin
  Stream.Position := 0;
  aFileHeader.FormatVersion := cQRPFormatVersion;
  aFileHeader.QRVersion := cQRVersion;
  aFileHeader.PageCount := PageCount;
  aFileHeader.CreateDateTime := Now;
  if Compression then
    aFileHeader.Compression := 1
  else
    aFileHeader.Compression := 0;
  Stream.Write(aFileHeader, SizeOf(aFileHeader));
end;

procedure TQRPageList.AddPage(aMetafile : TMetafile);
var
  I,
  SavePos1,
  SavePos2,
  SavePos3 : longint;
  TempStream : TMemoryStream;
  aByte : byte;

  procedure SavePreInfo;
  var
    aPageCount : longint;
  begin
    aPageCount := FPageCount;
    Stream.Position := Stream.Size;
    SavePos1 := Stream.Position;                    { Store start position }
    Stream.Write(aPageCount, SizeOf(aPageCount));   { Write page number }
    SavePos2 := Stream.Position;                    { Store metafile size pos }
    Stream.Write(SavePos2, SizeOf(SavePos2));       { Reserve space for size }
  end;

  procedure SavePostInfo;
  begin
    Stream.Write(SavePos1, Sizeof(SavePos1));       { Store previous start }
    SavePos3 := Stream.Position;                    { Store post of next }
    Stream.Position := SavePos2;                    { Go back to reserved pos }
    Stream.Write(SavePos3, Sizeof(SavePos3));       { Save pos of next};
    Stream.Position := SavePos3;                    { Go to end of stream }
  end;

begin
  try
    LockList;
    inc(FPageCount);
    if PageCount = 1 then
      WriteFileHeader;
    if Compression then
    begin
      TempStream := TMemoryStream.Create;
      AMetafile.SaveToStream(TempStream);
      SavePreInfo;
      aCompressor := TQRCompress.Create(Stream,true);
      TempStream.Position := 0;
      I := TempStream.Size;
      Stream.Write(I,SizeOf(I));
      for I := 0 to TempStream.Size - 1 do
      begin
        TempStream.Read(aByte,1);
        aCompressor.Compress(aByte);
      end;
      aCompressor.Free;
      TempStream.Free;
      SavePostInfo;
    end else
    begin
      SavePreInfo;
      AMetaFile.SaveToStream(Stream);               { Save the metafile }
      SavePostInfo;
    end;
  finally
    UnlockList;
  end;
end;

procedure TQRPageList.AddPageEx(aMetafile : TMetafile; AHyperlinks : TList);
var
  I,
  SavePos1,
  SavePos2,
  SavePos3 : longint;
  TempStream : TMemoryStream;
  aByte : byte;
  aLongint : Longint;

  procedure SavePreInfo;
  var
    aPageCount : longint;
  begin
    aPageCount := FPageCount;
    Stream.Position := Stream.Size;
    SavePos1 := Stream.Position;                    { Store start position }
    Stream.Write(aPageCount, SizeOf(aPageCount));   { Write page number }
    SavePos2 := Stream.Position;                    { Store metafile size pos }
    Stream.Write(SavePos2, SizeOf(SavePos2));       { Reserve space for size }
  end;

  procedure SavePostInfo;
  begin
    Stream.Write(SavePos1, Sizeof(SavePos1));       { Store previous start }
    SavePos3 := Stream.Position;                    { Store post of next }
    Stream.Position := SavePos2;                    { Go back to reserved pos }
    Stream.Write(SavePos3, Sizeof(SavePos3));       { Save pos of next};
    Stream.Position := SavePos3;                    { Go to end of stream }
  end;

begin
  try
    LockList;
    inc(FPageCount);
    if PageCount = 1 then
      WriteFileHeader;
    if Compression then
    begin
      TempStream := TMemoryStream.Create;
      AMetafile.SaveToStream(TempStream);
      SavePreInfo;
      aCompressor := TQRCompress.Create(Stream,true);
      TempStream.Position := 0;
      I := TempStream.Size;
      Stream.Write(I,SizeOf(I));
      for I := 0 to TempStream.Size - 1 do
      begin
        TempStream.Read(aByte,1);
        aCompressor.Compress(aByte);
      end;
      aCompressor.Free;
      TempStream.Free;
      SavePostInfo;
    end else
    begin
      SavePreInfo;
      AMetaFile.SaveToStream(Stream);               { Save the metafile }
      if AHyperlinks <> nil then
      begin
        aLongint := AHyperlinks.Count;
        Stream.Write(ALongint,SizeOf(Longint));
        for I := 0 to AHyperlinks.Count - 1 do
        begin
          with THyperlink(AHyperlinks[I]) do
          begin
            Stream.Write(Area, Sizeof(TRect));
            aLongint := Length(Link);
            Stream.Write(ALongint, Sizeof(ALongint));
            Stream.Write(Link[1],Length(link));
          end
        end;
      end else
      begin
        aLongint := 0;
        Stream.Write(ALongint,SizeOf(Longint));
      end;
      SavePostInfo;
    end;
  finally
    UnlockList;
  end;
end;

procedure TQRPageList.AddOutline(Level : integer; Caption : string; Target : TRect; PageNumber : integer);
begin
  QROutline.AddNode(Caption, Level, Target, PageNumber);
end;

function QREnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
                       FontType: Integer; Data: Pointer): Integer; stdcall;
begin
  TStrings(Data).Add(LogFont.lfFaceName);
  Result := 1;
end;

function GetFonts : TStrings;
begin
  if Printer.Printers.Count = 0 then
    Result := Screen.Fonts
  else
    Result := Printer.Fonts;
end;

{ TQRPreviewInterface }

function TQRPreviewInterface.Show(AQRPrinter : TQRPrinter) : TWinControl;
begin
  Result := nil;
end;

function TQRPreviewInterface.ShowModal(AQRPrinter : TQRPrinter) : TWinControl;
begin
  Result := nil;
end;

function TQRStandardPreviewInterface.Show(AQRPrinter : TQRPrinter) : TWinControl;
begin
  Result := TQRStandardPreview.CreatePreview(Application, AQRPrinter);
  TQRStandardPreview(Result).Show;
end;

function TQRStandardPreviewInterface.ShowModal(AQRPrinter : TQRPrinter) : TWinControl;
begin
  Result := TQRStandardPreview.CreatePreview(Application, AQRPrinter);
  TQRStandardPreview(Result).ShowModal;
end;

{ TQRPreviewImage }

constructor THyperlink.Create(AArea: TRect; ALink: string);
begin
  inherited Create;
  Area := AArea;
  Link := ALink;
end;

constructor TQRPreviewImage.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  Height := 50;
  Width := 100;
  Zoom := 100;
  QRPrinter := nil;
  FMetafile := nil;
  FHyperlinks := nil;
  FPageNumber := 1;
  FOnHyperlink := nil;
  FIsLink := false;
  FLastLink := '';
end;

destructor TQRPreviewImage.Destroy;
begin
  if ImageOK then
    FMetafile.Free;
  inherited Destroy;
end;

function TQRPreviewImage.ImageOK : boolean;
begin
  Result := FMetafile <> nil;
end;

function TQRPreviewImage.HyperlinksOK : boolean;
begin
  Result := FHyperlinks <> nil;
end;

procedure TQRPreviewImage.FreeHyperlinks;
var
  I : integer;
begin
  if HyperlinksOK then
  begin
    for I := 0 to FHyperlinks.Count - 1 do
      THyperlink(FHyperlinks[I]).Free;
    FHyperlinks.Free;
    FHyperlinks := nil;
  end;
end;

function TQRPreviewImage.Hyperlink(X, Y: integer): string;
var
  I : integer;
begin
  X := round(X/Zoom*100);
  Y := round(Y/Zoom*100);
  if FHyperlinks <> nil then
  begin
    I := 0;
    while I < FHyperlinks.Count do
      with THyperlink(FHyperlinks[I]).Area do
      begin
        if (X>=Left) and (X<=Right) and (Y>=Top) and (Y<=Bottom) then
        begin
          Result := THyperlink(FHyperlinks[I]).Link;
          FLastLink := Result;
          Exit;
        end else
          inc(I);
      end;
  end;
  Result := '';
end;

procedure TQRPreviewImage.SetIsLink(Value : boolean);
var
  Handled : boolean;
begin
  if Value <> FIsLink then
  begin
    FIsLink := Value;
    Handled := false;
    if assigned(FOnHyperlink) then
      if FIsLink then
        FOnHyperlink(QRPrinter, heCursorMoveOver, FLastLink, Handled)
      else
        FOnHyperlink(QRPrinter, heCursorMoveAway, '', Handled);
  end;
end;

procedure TQRPreviewImage.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  Handled : boolean;
begin
  inherited;
  Handled := false;
  if IsLink and assigned(