qrprntr.pas

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

    property LeftWaste : integer read GetLeftWaste;
    property Master : TWinControl read FMaster write FMaster;
    property Orientation : TPrinterOrientation read GetOrientation write SetOrientation;
    property OnExportToFilter : TQRExportToFilterEvent read FOnExportToFilterEvent
                                                       write FOnExportToFilterEvent;
    property OnPreview : TNotifyEvent read FOnPreviewEvent write FOnPreviewEvent;
    property OnPrintSetup : TQRPrintSetupEvent read FOnPrintSetupEvent write FOnPrintSetupEvent;
    property OnGetPrinterSettings : TQRPrinterSettingsEvent read GetOnGetPrinterSettings write SetOnGetPrinterSettings;
    property OnApplyPrinterSettings : TQRPrinterSettingsEvent read GetOnApplyPrinterSettings write SetOnApplyPrinterSettings;
    property PageList : TQRPageList read FPageList write FPageList;
    property PaperLength : Integer read GetPaperLength write SetPaperLength;
    property UseStandardPrinter : boolean read GetUseStandardPrinter write SetUseStandardPrinter;
    property UseExtendedDuplex : boolean read GetUseExtendedDuplex write SetUseExtendedDuplex;
    property UseCustomBinCode : boolean read GetUseCustomBinCode write SetUseCustomBinCode;
    property UseCustomPaperCode : boolean read GetUseCustomPaperCode write SetUseCustomPaperCode;
    property CustomBinCode : integer read GetCustomBinCode write SetCustomBinCode;
    property ExtendedDuplex : integer read GetExtendedDuplex write SetExtendedDuplex;
    property CustomPaperCode : integer read GetCustomPaperCode write SetCustomPaperCode;
    property Outline : TTreeview read FOutlineControl write SetOutline;
    property Page : TMetafile read FPage;
    property PageCount : integer read FPageCount write FPageCount;
    property PageNumber : Integer read FPageNumber write SetPageNumber;
    property PaperWidth : Integer read GetPaperWidth write SetPaperWidth;
    property PaperSize : TQRPaperSize read GetPaperSize write SetPaperSize;
    property PrinterIndex : integer read GetPrinterIndex write SetPrinterIndex;
    property PrintMetafile : boolean read GetPrintMetafile write SetPrintMetafile;
    property PrinterOK : boolean read FPrinterOK;
    property Printers : TStrings read GetPrinters;
    property Progress : integer read FProgress write SetProgress;
    property MasterProgressStart : integer read FMasterProgressStart write FMasterProgressStart;
    property MasterProgressEnd : integer read FMasterProgressEnd write FMasterProgressEnd;
    property ShowingPreview : boolean read FShowingPreview write SetShowingPreview;
    property Status : TQRPrinterStatus read FStatus;
    property Title : string read FTitle write FTitle;
    property TopWaste : integer read GetTopWaste;
    property XFactor : extended read FXFactor write FXFactor;
    property YFactor : extended read FYFactor write FYFactor;
    property PrintQuality : integer read GetPrintQuality write SetPrintQuality;
    property Collate : integer read GetCollate write SetCollate;
    property ColorOption : integer read GetColorOption write SetColorOption;
    property PrinterHandle : THandle read GetPrinterHandle;
  end;

//ERP 2

  TQRHyperlinkSourceMethod = procedure (Sender : TObject; Parameters : string) of object;

  procedure RegisterHyperlinkSource(ASignature : string; SourceMethod : TQRHyperlinkSourceMethod);
  procedure UnregisterHyperlinkSource(ASignature : string);
  procedure PerformHyperlink(Sender : TObject; Link : string);
  procedure PaintPageToCanvas(APage : TMetafile; ACanvas : TCanvas; ARect : TRect; PaintFrameAnyway : boolean);

  function AnsiPos(Substr: string; S: string): integer;
  function GetFonts : TStrings;

  function TempFilename : string;
  function QRPaperName(Size : TQRPaperSize) : string;

  procedure RegisterPreviewClass(APreviewInterface : TQRPreviewInterfaceClass);

  //function QRPrinter : TQRPrinter;
  function QRHyperlinkSources : TList;

var
  QRExportFilterLibrary : TQRExportFilterLibrary;
{$ifdef LLIONPDF}
  function TranslatePagesize( qrps : TQRPapersize ) : TPDFPageSize;
{$endif}  

implementation

uses
  QRPrev, ShellAPI, quickrpt;

var
  FQRPrinter : TQRPrinter;
  GlobalPreviewInterface : TQRPreviewInterfaceClass;
  FQRHyperlinkSources : TList;

const
  cQRPFormatVersion = 3;

type
  TQRFileHeader = record
    FormatVersion : word;                   { File format version }
    QRVersion : word;                       { QR version }
    PageSize : TQRPaperSize;
    PageCount : integer;
    CreateDateTime : TDateTime;
    Portrait : boolean;                     { field added in header version 2 }
    Compression : byte;                     { 0 - no compression, 1 - splay }
    EmptySpace : array[0..100] of byte;
  end;

  TQRHyperlinkSourceRecord = record
    Signature : string;
    SourceMethod : TQRHyperlinkSourceMethod;
  end;

  PQRHyperlinkSourceRecord = ^TQRHyperlinkSourceRecord;

type
  bar = array of char;
var
  MFSearchStr : string;
  MFFound : boolean;
  MFMatchCase : boolean;

function MetaEnum(DC : THandle; HandleTable : pointer; MetaRec : Pointer; Count : word; dummy : pointer) : shortint stdcall;
var
  aStr : string;
  Ofs : integer;
  Len : integer;
  I : integer;
begin
  with tagENHMETARECORD(MetaRec^) do
  begin
    case iType of
      EMR_EXTTEXTOUTW,
      EMR_EXTTEXTOUTA : begin
                          aStr := '';
                          Ofs := (tagEMREXTTEXTOUTA(Metarec^).EMRText.offString);
                          Len := (tagEMREXTTEXTOUTA(Metarec^).EMRText.nChars);
                          SetLength(aStr, Len);
                          for I := 0 to len - 1 do
                            aStr[I+1] := char(bar(MetaRec^)[ofs + (I*2)]);
                        end;
    end;
  end;
  if not MFMatchCase then aStr := AnsiUppercase(AStr);
  if Pos(MFSearchStr, aStr) > 0 then
  begin
    Result := 0;
    MFFound := true;
  end else
    Result := 1;
end;

function StrInMetafile(AString : string; AMetafile : TMetafile; MatchCase : boolean) : boolean;
begin
  if MatchCase then
    MFSearchStr := AString
  else
    MFSearchStr := AnsiUppercase(AString);
  MFFound := false;
  MFMatchCase := MatchCase;
  EnumEnhMetafile(0, AMetafile.handle, @MetaEnum, nil, rect(0,0,0,0));
  Result := MFFound;
end;

procedure RegisterHyperlinkSource(ASignature : string; SourceMethod : TQRHyperlinkSourceMethod);
var
  ASource : PQRHyperlinkSourceRecord;
begin
  New(ASource);
  try
    ASource^.Signature := ASignature;
    ASource^.SourceMethod := SourceMethod;
  finally
    QRHyperlinkSources.Add(ASource);
  end;
end;

procedure UnregisterHyperlinkSource(ASignature : string);
var
  I : integer;
  ASource : PQRHyperlinkSourceRecord;
begin
  for I := 0 to QRHyperlinkSources.Count - 1 do
  begin
    ASource := PQRHyperlinkSourceRecord(QRHyperlinkSources[I]);
    if ASource^.Signature = ASignature then
    begin
//      Release(ASource); //Must fix!
      QRHyperlinkSources.Delete(I);
      Exit;
    end;
  end;
end;

procedure PerformHyperlink(Sender : TObject; Link : string);

  procedure DoExternal(ALink : string);
  begin
    ShellExecute(TQRPrinter(Sender).PreviewControl.Handle, 'open', PChar(ALink), nil, nil, SW_SHOW);
  end;

  function DoInternal(ALink : string) : boolean;
  var
    I : integer;
  begin
    Result := false;
    for I := 0 to QRHyperlinkSources.Count - 1 do
    begin
      with PQRHyperlinkSourceRecord(QRHyperlinkSources[I])^ do
      begin
        if Signature = copy(ALink, 1, Length(Signature)) then
        begin
          SourceMethod(Sender, copy(ALink, Length(Signature) + 1, Length(Link)));
          Result := true;
          exit;
        end;
      end;
    end;
  end;

begin
  if Uppercase(copy(Link, 1, 4)) = 'EXT:' then
    DoExternal(copy(Link, 5, Length(Link) - 4))
  else
    if Uppercase(copy(Link, 1,4)) = 'INT:' then
      DoInternal(copy(Link, 5, Length(Link) - 4))
    else
    begin
      if not DoInternal(Link) then
        DoExternal(Link);
    end;
end;

{$ifdef EvalVersion}
function DelphiRunning : boolean;
var
  H1, H2, H3, H4 : Hwnd;
const
  A1 : array[0..12] of char = 'TApplication'#0;
  A2 : array[0..15] of char = 'TAlignPalette'#0;
  A3 : array[0..18] of char = 'TPropertyInspector'#0;
  A4 : array[0..11] of char = 'TAppBuilder'#0;
  T1 : array[0..6] of char = 'Delphi'#0;
begin
  H2 := FindWindow(A2, nil);
  H3 := FindWindow(A3, nil);
  H4 := FindWindow(A4, nil);
  Result := (H2 <> 0) and
            (H3 <> 0) and (H4 <> 0);
end;
{$endif}
function QRPHeaderSize(const Stream : TStream ) : integer;
var
  OldPosition : Integer;
  Buf : array[0..3] of Char;
  FoundSize : boolean;
begin
  // Assert parameters
  Assert(Assigned(Stream));

  // Check for the EMF header.  In versions previous to Delphi 5, the
  // string EMF will be found at $AD.
  OldPosition := Stream.Position;
  try
    Stream.Position := $ad;
    Stream.ReadBuffer(Buf, 4);
    FoundSize := (Buf = 'EMF');
    result := 124;

    if not FoundSize then begin
      result := 128;
      Stream.Position := $B1;
      Stream.ReadBuffer( Buf, 4 );
      FoundSize := (Buf = 'EMF');
    end;
    if not FoundSize then
      Result := SizeOf(TQRFileHeader);
  finally
    Stream.Position := OldPosition;
  end;
end;

function GetFileHeaderSize( const Stream: TStream ): Integer;
begin
  // Assert parameters
  Assert( Assigned( Stream ) );
  // Determine size of header
  result := QRPHeaderSize(Stream);
end; // function GetFileHeaderSize

procedure FixupFileHeader( const Stream: TStream; var aFileHeader: TQRFileHeader );
type
  TQRD4FileHeader = packed record           // Packed to have full control over alignment
    FormatVersion : word;                   { File format version }
    QRVersion : word;                       { QR version }
    PageSize : TQRPaperSize;
    Reserved1 : array[ 0..2 ] of Byte;      // Fixup to match delphi 4 record alignment
    PageCount : integer;
    CreateDateTime : TDateTime;
    Portrait : boolean;                     { field added in header version 2 }
    Compression : byte;                     { 0 - no compression, 1 - splay }
    EmptySpace : array[0..100] of byte;
  end;
var
  D4FileHeader  : TQRD4FileHeader;
  FileSize: integer;
begin
  // Assert parameters
  Assert( Assigned( Stream ) );
  FileSize := GetFileHeaderSize(Stream);

  // Now do the fixup, if necessary
  if FileSize = 124 then begin
    Move( aFileHeader, D4FileHeader, 124 ); // Move record into old format record

    // Now copy values field by field
    aFileHeader.FormatVersion := D4FileHeader.FormatVersion;
    aFileHeader.QRVersion := D4FileHeader.QRVersion;
    aFileHeader.PageSize := D4FileHeader.PageSize;
    aFileHeader.PageCount := D4FileHeader.PageCount;
    aFileHeader.CreateDateTime := D4FileHeader.CreateDateTime;
    aFileHeader.Portrait := D4FileHeader.Portrait;
    aFileHeader.Compression := D4FileHeader.Compression;
    Move( D4FileHeader.EmptySpace, aFileHeader.EmptySpace, 101 );
  end;
end; // procedure FixupFileHeader


function AnsiPos(Substr: string; S: string): integer;
begin
  result := Pos(Substr,S);
end;

function QRPaperName(Size : TQRPaperSize) : string;
const
  Names : array[Default..Custom] of string = (
   SqrPaperSize0, SqrPaperSize1, SqrPaperSize2, SqrPaperSize3,
   SqrPaperSize4, SqrPaperSize5, SqrPaperSize6, SqrPaperSize7,
   SqrPaperSize8, SqrPaperSize9, SqrPaperSize10, SqrPaperSize11,
   SqrPaperSize12, SqrPaperSize13, SqrPaperSize14, SqrPaperSize15,
   SqrPaperSize16, SqrPaperSize17, SqrPaperSize18, SqrPaperSize19,
   SqrPaperSize20, SqrPaperSize21, SqrPaperSize22, SqrPaperSize23,
   SqrPaperSize24, SqrPaperSize25, SqrPaperSize26, SqrPaperSize27);

begin
  Result := Names[Size];
end;

function TempFilename : string;
var
  AName,
  ADir : array[0..MAX_PATH] of char;
begin
  GetTempPath(MAX_PATH, adir);
  GetTempFilename(aDir, PChar('QRP'), 0, aName);
  result := StrPas(aName);
end;

{ TQRStream }
constructor TQRStream.Create(pMemoryLimit : longint);
begin
  inherited Create;
  FInMemory := true;
  MemoryStream := TMemoryStream.Create;
  FMemoryLimit := pMemoryLimit;
  InitializeCriticalSection(FLock);
end;

constructor TQRStream.CreateFromFile(Filename : string);
begin
  inherited Create;
  FInMemory := false;
  FileStream := TFileStream.Create(Filename, fmOpenRead + fmShareDenyNone);
  FMemoryLimit := 0;
  InitializeCriticalSection(FLock);
end;

destructor TQRStream.Destroy;
begin
  LockStream;
  try
    if InMemory then
      MemoryStream.Free
    else
    begin
      FileStream.Free;
      DeleteFile(FFilename);
    end;
  finally
    UnlockStream;
    DeleteCriticalSection(FLock);
  end;
  inherited Destroy;
end;

procedure TQRStream.LockStream;
begin
  EnterCriticalSection(FLock);
end;

procedure TQRStream.UnlockStream;
begin
  LeaveCriticalSection(FLock);
end;

function TQRStream.Write(const Buffer; Count: Longint): Longint;
begin
  LockStream;
  if InMemory then
  begin
    result := MemoryStream.Write(Buffer,Count);
    if MemoryStream.Size > FMemoryLimit then {...this could be optimized somewhat }
    begin
      FFilename := TempFilename;
      FileStream := TFileStream.Create(FFilename, fmCreate or fmOpenReadWrite);
      MemoryStream.SaveToStream(FileStream);
      MemoryStream.Free;
      FInMemory := false;
    end
  end else
    result := FileStream.Write(Buffer,Count);
  UnlockStream;
end;

function TQRStream.Read(var Buffer; Count: Longint): Longint;
begin
  LockStream;
  if InMemory then
    result := MemoryStream.Read(Buffer,Count)
  else