qrprntr.pas

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

    result := FileStream.Read(Buffer,Count);
  UnlockStream;
end;

function TQRStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  LockStream;
  if InMemory then
    result := MemoryStream.Seek(Offset,Origin)
  else
    result := FileStream.Seek(Offset,Origin);
  UnlockStream;
end;

procedure TQRStream.SaveToStream(AStream : TStream);
var
  Buffer : array[0..10240] of byte;
  BytesRead : longint;
begin
  LockStream;
  Position := 0;
  repeat
    BytesRead := Read(Buffer,10240);
    AStream.Write(Buffer,BytesRead);
  until BytesRead=0;
  UnlockStream;
end;

{ TQRCompress }

constructor TQRCompress.Create(aStream : TStream; CompressData : boolean);
begin
  Stream := aStream;
  InitializeSplay;
  if CompressData then
    BitPos := 0
  else
    BitPos := 7;
  OutByte := 0;
  CompressFlag := CompressData;
end;

destructor TQRCompress.Destroy;
begin
  if CompressFlag and (BitPos<>0) then
    Stream.Write(OutByte,1);
  inherited Destroy;
end;

procedure TQRCompress.InitializeSplay;
var
  I : DownIndex;
  J : UpIndex;
  K : DownIndex;
begin
  for I := 1 to TwiceMax do
    Up[I] := (I-1) shr 1;
  for J := 0 to PredMax do
  begin
    K := (J+1) shl 1;
    Left[J] := K-1;
    Right[J] := K;
  end;
end;

procedure TQRCompress.Splay(Plain : CodeType);
var
  A, B : DownIndex;
  C, D : UpIndex;
begin
  A := Plain+MaxChar;
  repeat
    C := Up[A];
    if C <> ROOT then
    begin
      D := Up[C];
      B := Left[D];
      if C = B then
      begin
        B := Right[D];
        Right[D] := A;
      end else
        Left[D] := A;
      if A = Left[C] then
        Left[C] := B
      else
        Right[C] := B;
      Up[A] := D;
      Up[B] := C;
      A := D;
    end else
      A := C;
  until A = ROOT;
end;

procedure TQRCompress.Compress(Plain : CodeType);
{ Compress a single byte }
var
  A : DownIndex;
  U : UpIndex;
  Sp : 0..MaxChar;
  Stack : array[UpIndex] of Boolean;
begin
  A := Plain+MaxChar;
  Sp := 0;
  repeat
    U := Up[A];
    Stack[Sp] := (Right[U] = A);
    inc(Sp);
    A := U;
  until A = ROOT;
  repeat
    dec(Sp);
    if Stack[Sp] then
      OutByte := OutByte or BitMask[BitPos];
    if BitPos = 7 then
    begin
      Stream.Write(OutByte, 1); { writebyte }
      BitPos := 0;
      OutByte := 0;
    end else
      inc(BitPos);
  until Sp = 0;
  Splay(Plain);
end;

function TQRCompress.GetByte : Byte;
begin
  Stream.Read(Result, 1);
end;

procedure TQRCompress.Expand(var Expanded : byte);
{ Expand a single byte }
var
  A : DownIndex;
begin
  A := ROOT;
  repeat
    if BitPos = 7 then
    begin
      InByte := GetByte;
      BitPos := 0;
    end else
      inc(BitPos);
    if InByte and BitMask[BitPos] = 0 then
      A := Left[A]
    else
      A := Right[A];
  until A > PredMax;
  dec(A, MaxChar);
  Splay(A);
  Expanded := A;
end;

{ TQROutline }

constructor TQROutline.Create;
begin
  inherited Create;
  NodeList := TList.Create;
  TreeNodes := nil;
end;

destructor TQROutline.Destroy;
begin
  Clear;
  NodeList.Free;
  inherited Destroy;
end;

procedure TQROutline.Clear;
begin
  while NodeList.Count > 0 do
  begin
    Dispose(PQROutLineNode(NodeList.Items[0]));
    NodeList.Delete(0);
  end;
end;

procedure TQROutline.AddNode(ACaption: string; ALevel: integer; ARect: TRect; APage: integer);
var
  ANode : PQROutlineNode;
  I : integer;
begin
  New(ANode);
  with ANode^ do
  begin
    Caption := ACaption;
    Level := ALevel;
    Rect := ARect;
    Page := APage;                                                                            
    TreeNode := nil;
  end;
  NodeList.Add(ANode);
  if TreeNodes <> nil then
  begin
    if TreeNodes.Count = 0 then
      ANode^.TreeNode := TreeNodes.Add(nil, ACaption)
    else
      for I := TreeNodes.Count - 1 downto 0 do
      begin
        if TreeNodes.Item[I].Level < ALevel then
          ANode^.TreeNode := TreeNodes.AddChild(TreeNodes.Item[I], ACaption)
        else if TreeNodes.Item[I].Level = ALevel then
          ANode^.TreeNode := TreeNodes.Add(TreeNodes.Item[I], ACaption);
        if ANode^.TreeNode <> nil then Break;
      end;
  end;
end;

procedure TQROutline.LoadFromStream(AStream: TStream);
var
  I, J : integer;
  ANode : TQROutlineNode;
  ATreeNodes : TTreeNodes;
begin
  Clear;
  AStream.Read(J, SizeOf(J));
  ATreeNodes := TreeNodes;
  TreeNodes := nil;
  for I := 0 to J - 1 do
  begin
    AStream.Read(ANode, Sizeof(ANode));
    AddNode(ANode.Caption, ANode.Level, ANode.Rect, ANode.Page);
  end;
  TreeNodes := ATreeNodes;
end;

procedure TQROutline.SaveToStream(AStream: TStream);
var
  I : integer;
begin
  I := NodeList.Count;
  AStream.Write(I, SizeOf(I));
  for I := 0 to NodeList.Count - 1 do
    AStream.Write(NodeList.Items[I]^, SizeOf(TQROutlineNode));
end;

procedure TQROutline.SetTreeNodes(const Value: TTreeNodes);
begin
  FTreeNodes := Value;
  if Value <> nil then
    UpdateTreeNodes;
end;

procedure TQROutline.UpdateTreeNodes;
var
  Nodes : array[0..31] of TTreeNode;
  I : integer;
  ANode : TQROutlineNode;
  PrevLevel : integer;
begin
  TreeNodes.Clear;
  TreeNodes.BeginUpdate;
  FillChar(Nodes, SizeOf(Nodes), 0);
  PrevLevel := -1;
  for I := 0 to NodeList.Count - 1 do
  begin
    ANode := PQROutlineNode(NodeList[I])^;
    if PrevLevel < ANode.Level then
      ANode.TreeNode := TreeNodes.AddChild(Nodes[ANode.Level - 1], ANode.Caption)
    else
      ANode.TreeNode := TreeNodes.Add(Nodes[ANode.level], ANode.Caption);
    Nodes[ANode.Level] := ANode.TreeNode;
  end;
  TreeNodes.EndUpdate;
end;

procedure TQROutline.FindPosition(ATreeNode: TTreeNode; var ARect: TRect; var APage: integer);
var
  I : integer;
begin
  for I := 0 to NodeList.Count - 1 do
  begin
    APage := 0;
    ARect := Rect(0, 0, 0, 0);
    if PQROutlineNode(NodeList[I])^.TreeNode = ATreeNode then
      with PQROutlineNode(NodeList[I])^ do
      begin
        ARect := Rect;
        APage := Page;
        Break;
      end;
  end;
end;

{ TQRPageList }

constructor TQRPageList.Create;
begin
  inherited Create;
  FPageCount := 0;
  FCompression := false;
  FStream := nil;
  InitializeCriticalSection(FLock);
  FQROutline := TQROutline.Create;
  QROutline.TreeNodes := nil;
end;

destructor TQRPageList.Destroy;
begin
  DeleteCriticalSection(FLock);
  if assigned(FStream) then
  begin
    FStream.Free;
    FStream := nil;
  end;
  QROutline.Free;
  inherited Destroy;
end;

procedure TQRPageList.Clear;
begin
  FPageCount := 0;
end;

procedure TQRPageList.LockList;
begin
  EnterCriticalSection(FLock);
end;

procedure TQRPageList.UnlockList;
begin
  LeaveCriticalSection(FLock);
end;

procedure TQRPageList.Finish;
begin
  WriteFileHeader;
end;

procedure TQRPageList.LoadFromFile;
begin
  if assigned(FStream) then
    Stream.Free;
  Stream := TQRStream.CreateFromFile(Filename);
  ReadFileHeader;
  GetPage(PageCount);
end;

procedure TQRPageList.SaveToFile(Filename : string);
var
  AStream : TFileStream;
begin
  AStream := TFileStream.Create(Filename,fmCreate or fmOpenReadWrite);
  Stream.SaveToStream(AStream);
  AStream.Free;
end;

procedure TQRPageList.SeekToFirst;
begin
  Stream.Position := GetFileHeaderSize( Stream );
end;

procedure TQRPageList.SeekToLast;
var
  PrevPosition : longint;
begin
  Stream.Seek(-SizeOf(PrevPosition), soFromEnd);
  Stream.Read(PrevPosition,SizeOf(PrevPosition));
  Stream.Position := PrevPosition;
end;

procedure TQRPageList.SeekToPage(PageNumber : integer);
var
  ThisPageNum : longint;
  NextPosition : longint;
  PrevPosition : longint;
begin
  if PageNumber = 1 then
    SeekToFirst
  else
{    if PageNumber = PageCount then
      SeekToLast
    else}
    begin
      if Stream.Position = Stream.Size then
        SeekToLast;
      Stream.Read(ThisPageNum, SizeOf(ThisPageNum));
      Stream.Seek(-SizeOf(ThisPageNum), soFromCurrent);
      if ThisPageNum<PageNumber then
      begin
        repeat
          Stream.Read(ThisPageNum, SizeOf(ThisPageNum));
          if ThisPageNum<>PageNumber then
          begin
            Stream.Read(NextPosition, SizeOf(NextPosition));
            Stream.Position := NextPosition;
          end;
        until ThisPageNum=PageNumber;
        Stream.Seek(-SizeOf(ThisPageNum), soFromCurrent);
      end else
        if ThisPageNum>PageNumber then
        begin
          repeat
            Stream.Read(ThisPageNum,SizeOf(ThisPageNum));
            if ThisPageNum<>PageNumber then
            begin
              Stream.Position := Stream.Position - SizeOf(PrevPosition) - SizeOf(ThisPageNum);
              Stream.Read(PrevPosition,SizeOf(PrevPosition));
              Stream.Position := PrevPosition;
            end;
          until ThisPageNum=PageNumber;
          Stream.Seek(-SizeOf(ThisPageNum), soFromCurrent);
        end;
    end;
end;

function TQRPageList.GetPage(PageNumber : integer) : TMetafile;
var
  Dummy : longint;
  TempStream : TMemoryStream;
  aByte : byte;
  BytesToGet : longint;
  I : longint;
begin