untactreport.pas

飞思科技的书不错

unit UntActReport;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ComCtrls, QuickRpt, QRExtra, QRExport,
  Db, DBTables, Math, QRPrntr,
  Qrctrls, Grids, DBGrids, Printers;

const
  c_edt_str_width = 80;         // 串编辑-宽度
  c_edt_str_height = 20;        // 串编辑-高度
  c_edt_dat_width = 40;         // 数据编辑-宽度
  c_edt_dat_height = 20;        // 数据编辑-高度
  c_chk_width = 45;             // 检查框-宽度
  c_chk_height = 17;            // 检查框-高度
  c_cmb_width = 32;             // 组合框-宽度
  c_cmb_height = 20;            // 组合框-高度

  c_char_height = 12;           // 标签-高席
  c_width_per_char = 6;         // 标签-每个字符宽度
  c_grp_hdr = 8;                // 组合框的头高
  c_margin = 4;                 // 元素内列距和单元内行距
  c_ele_gap = 8;                // 元素间列距
  c_unit_gap = 8;               // 单元间行距
  c_column_gap = 24;            // 栏间距

  c_band_width = 25;            // 报表项-宽度
  c_band_height = 5;            // 报表项-高度
  c_band_margin = 1.5;          // 报表内线与数据的距离

  c_page_hor_margin = 10;       // 页边距-横向
  c_page_vert_margin = 10;      // 页边距-纵向

  c_page_width = 210;           // 页-宽度
  c_page_height = 297;          // 页-高度
  c_pixel_per_mm = 23;          // 每毫米象素数
  c_segbar_width = 1;           // 分隔线粗细

  c_report_title = 'none';      // 报表标题
  c_file_id = 'pjYan report';   // 文件标志
  c_file_name = 'report0';      // 文件名
  c_file_ext = '.ypj';          // 文件后缀名

type
  TIndexList = array of Integer;
  TIntegerList = array of Integer;
  TCurrencyList = array of Currency;
  TBooleanList = array of Boolean;
  TAlign = (a_left, a_center, a_right);
  TAlignList = array of TAlign;

  TEditList = array of TEdit;
  TCheckBoxList = array of TCheckBox;
  TComboBoxList = array of TComboBox;

  TActReport = class(TForm)
    grpFieldParaList: TGroupBox;
    btnPreview: TButton;
    btnMake: TButton;
    grpGlobalParaList: TGroupBox;
    btnClose: TButton;
    chkFrameLine: TCheckBox;
    chkSummary: TCheckBox;
    grpTitleParaList: TGroupBox;
    Label2: TLabel;
    edtTitle: TEdit;
    dlgFont: TFontDialog;
    btnTitleFont: TButton;
    grpHeaderParaList: TGroupBox;
    btnHeaderFont: TButton;
    grpHeaderAlign: TRadioGroup;
    grpDetailParaList: TGroupBox;
    btnDetailFont: TButton;
    Label3: TLabel;
    edtHeaderHeight: TEdit;
    Label4: TLabel;
    edtTitleHeight: TEdit;
    Label5: TLabel;
    edtDetailHeight: TEdit;
    sclContainer: TScrollBar;
    Label1: TLabel;
    edtDetailMargin: TEdit;
    btnPrint: TButton;
    Label6: TLabel;
    Label7: TLabel;
    edtPageVertMargin: TEdit;
    edtPageHorMargin: TEdit;
    Label8: TLabel;
    cmbReportAlign: TComboBox;
    Label9: TLabel;
    edtPaperWidth: TEdit;
    Label10: TLabel;
    edtPaperHeight: TEdit;
    btnSetup: TButton;
    dlgOpen: TOpenDialog;
    dlgSave: TSaveDialog;
    btnLoad: TButton;
    btnSave: TButton;
    Label11: TLabel;
    cmbPageOrientation: TComboBox;
    procedure btnPreviewClick(Sender: TObject);
    procedure btnMakeClick(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure sclContainerChange(Sender: TObject);
    procedure OnSelectFont(Sender: TObject);
    procedure btnSetupClick(Sender: TObject);
    procedure btnPrintClick(Sender: TObject);
    procedure btnLoadClick(Sender: TObject);
    procedure btnSaveClick(Sender: TObject);
    procedure cmbPageOrientationChange(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);

  private
    // class states
    m_bInitialized: Boolean;
    m_bPrepared: Boolean;
    m_bReportReady: Boolean;

    // page/report sizes and positions
    m_nPageWidth, m_nPageHeight: Integer;
    m_oriPage: TPrinterOrientation;
    m_dPageHorMargin, m_dPageVertMargin: Currency;
    m_alnReport: TAlign;

    // report states
    m_bHasFrameLine: Boolean;
    m_bHasSummary: Boolean;

    // title parameters
    m_strTitle: string;
    m_dTitleHeight: Currency;
    m_fntTitle: TFont;

    // header parameters
    m_alnHeader: TAlign;
    m_dHeaderHeight: Currency;
    m_fntHeader: TFont;

    // detail parameters
    m_dDetailHeight: Currency;
    m_dDetailMargin: Currency;
    m_fntDetail: TFont;

    // fields parameters
    m_nFieldCount: Integer;
    m_blstDisplay: TBooleanList;
    m_strlstFieldNames: TStringList;
    m_dlstFieldWidths: TCurrencyList;
    m_strlstDispNames: TStringList;
    m_alnlstFields: TAlignList;
    m_blstSummary: TBooleanList;

    m_grpGlobalContainer: TGroupBox;
    m_grpFieldContainer: TGroupBox;

    // controls
    m_edtlstFieldNames: TEditList;
    m_edtlstDispNames: TEditList;
    m_chklstDisplay: TCheckBoxList;
    m_edtlstWidths: TEditList;
    m_cmblstAlign: TComboBoxList;
    m_chklstSummary: TCheckBoxList;

    // file/dataset/report
    m_strFileName: string;
    m_dstActive: TDBDataSet;
    m_rptActive: TCustomQuickRep;
    m_prvActive: TQRPreview;

  private
    // for all dynamically created width-edits to be
    //  auto-selected when clicked
    procedure OnEditClick(Sender: TObject);
    procedure OnPreview(Sender: TObject);

    procedure CreateRep;
    procedure ResetRep;
    procedure PrepareCtrls(nAryLen: Integer);

    function FillInCtrls : Boolean;
    procedure SetScrollBarParams(grp: TGroupBox; xTotal: Integer);
    procedure ShowCtrls(grp: TGroupBox; bMove: Boolean = True);

    // parameters default
    procedure GlobalParamsDefault;
    procedure FieldParamsDefault;
    procedure ParamsDefault;
    // parameters from report
    procedure GlobalParamsFromReport;
    procedure FieldParamsFromReport;
    procedure ParamsFromReport;
    // parameters from form
    procedure GlobalParamsFromForm;
    procedure FieldParamsFromForm;
    procedure ParamsFromForm;
    // parameters to form
    procedure GlobalParamsToForm;
    procedure FieldParamsToForm;
    procedure ParamsToForm;
    // parameters from file
    procedure GlobalParamsFromFile(stream: TFileStream);
    procedure FieldParamsFromFile(stream: TFileStream);
    procedure ParamsFromFile(strFileName: string);
    // parameters to file
    procedure GlobalParamsToFile(stream: TFileStream);
    procedure FieldParamsToFile(stream: TFileStream);
    procedure ParamsToFile(strFileName: string);

    function BuildRep(strTitle: String;
                      bHasFrameLine: Boolean;
                      bHasSummary: Boolean;
                      nPageWidth, nPageHeight: Integer;
                      oriPage: TPrinterOrientation;
                      alnHeader: TAlign;
                      dHeightTitle, dHeightHeader, dHeightDetail: Currency;
                      dDetailMargin: Currency;
                      nSegbarWidth: Integer;
                      dPageHorMargin, dPageVertMargin: Currency;
                      fntTitle, fntHeader, fntDetail: TFont;
                      dftPageWidth, dftPageHeight: Integer;
                      dftWidth, dftHeight, dftMargin: Currency;
                      dftPageHorMargin, dftPageVertMargin: Currency;
                      lstIdxs: TIndexList;
                      lstDispNames: TStringList;
                      lstWidths: TCurrencyList;
                      lstAlign: TAlignList;
                      lstSummary: TBooleanList;
                      alnReport: TAlign)
                      : Boolean; overload;

    procedure PrepareMemory(nAryLen: Integer);
    procedure ReleaseMemory;

    function Initialize : Boolean; overload;
    function BeginSession(dst: TDBDataSet;
                          strTitle: string = '';
                          strlstDispNames: TStringList = nil
                          ) : Boolean;
    function BuildRep : Boolean; overload;
    procedure TerminateSession;
    procedure Clear;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Initialize(dst: TDBDataSet;
                         strTitle: string = '';
                         strlstDispNames: TStringList = nil
                         ); overload;
    function Make : Boolean;
    function PreviewRep : Boolean; overload;
    function PreviewRep(prv: TQRPreview) : Boolean; overload;
    function PrintRep(callback: TQRAfterPrintEvent = nil): Boolean;
    function LoadRep: Boolean;
    function SaveRep: Boolean;
    function GetFileName : string;
    procedure SetFileName(strFileName: string);
    function ShowModal : Integer; override;
    procedure Free; overload;
  end;

implementation

{$R *.DFM}

//===== local functions/procedures go from here =====

procedure StripFieldName(var str: string; bStrip: Boolean = True);
begin
  if bStrip and (Length(str) > 1) then
    str := Copy(str, 2, Length(str) - 2)
  else
    str := '[' + str + ']';
end;

procedure CurrToInt(const curr: Currency; var int: Integer);
var
  temp: Variant;
begin
  temp := curr;
  int := temp;
end;

procedure ReadString(stream: TFileStream; var str: string);
var
  len: Integer;
begin
  if not Assigned(stream) then
    Exit;
  try
    stream.Read(len, SizeOf(Integer));
    SetLength(str, len);
    stream.Read(PChar(str)^, len);
  except
    str := 'read error';
  end;
end;

procedure WriteString(stream: TFileStream; str: string);
var
  len: Integer;
begin
  if not Assigned(stream) then
    Exit;
  len := Length(str);
  try
    stream.Write(len, SizeOf(Integer));
    stream.Write(PChar(str)^, len);
  except
  end;
end;

procedure ReadFont(stream: TFileStream; var fnt: TFont);
var
  t_Charset: TFontCharset;
  t_Color: TColor;
  t_Height: Integer;
  t_Name: string;
  t_Pitch: TFontPitch;
  t_Size: Integer;
  t_Style: TFontStyles;
begin
  if not Assigned(stream) then
    Exit;
  with fnt do
    try
      stream.Read(t_Charset, SizeOf(t_CharSet));
      stream.Read(t_Color, SizeOf(t_Color));
      stream.Read(t_Height, SizeOf(t_Height));
      ReadString(stream, t_Name);
      stream.Read(t_Pitch, SizeOf(t_Pitch));
      stream.Read(t_Size, SizeOf(t_Size));
      { Warning : maybe errors here!!!!!
               caus t_Style is a SET }
      stream.Read(t_Style, SizeOf(t_Style));
      Charset := t_Charset;
      Color := t_Color;
      Height := t_Height;
      Name := t_Name;
      Pitch := t_Pitch;
      Size := t_Size;
      Style := t_Style;
    except
    end;
end;

procedure WriteFont(stream: TFileStream; fnt: TFont);
var
  t_Charset: TFontCharset;
  t_Color: TColor;
  t_Height: Integer;
  t_Name: string;
  t_Pitch: TFontPitch;
  t_Size: Integer;
  t_Style: TFontStyles;
begin
  if not Assigned(stream) then
    Exit;
  with fnt do
    try
      t_Charset := Charset;
      t_Color := Color;
      t_Height := Height;
      t_Name := Name;
      t_Pitch := Pitch;
      t_Size := Size;
      t_Style := Style;
      stream.Write(t_Charset, SizeOf(t_CharSet));
      stream.Write(t_Color, SizeOf(t_Color));
      stream.Write(t_Height, SizeOf(t_Height));
      WriteString(stream, t_Name);
      stream.Write(t_Pitch, SizeOf(t_Pitch));
      stream.Write(t_Size, SizeOf(t_Size));
      { Warning : maybe errors here!!!!!
               caus t_Style is a SET }
      stream.Write(t_Style, SizeOf(t_Style));
    except
    end;
end;

procedure DefaultIfZero(var owner: Integer; dft: Integer); overload;
begin
  if owner =  0 then
    owner := dft;
end;

procedure DefaultIfZero(var owner: Currency; dft: Currency); overload;
begin
  if owner = 0 then
    owner := dft;
end;

function CustomToStandardAlign(aln: TAlign) : TAlignment;
begin
  case aln of
    a_left: Result := taLeftJustify;
    a_center: Result := taCenter;
    a_right: Result := taRightJustify;
    else
      Result := taCenter;
  end;
end;

{ Warning : must set autosize to false before calling me! }
procedure SetPosition(var pos: TQRPrintableSize;
                      bleft, bwidth, bheight: Currency;
                      aln: TAlign; margin: Currency);
begin
  with pos do begin
    Width := Max(0, Min(Width, bWidth - margin*2));
    case aln of
      a_left: Left := bleft + margin;
      a_center: Left := bleft + (bwidth - Width) / 2;
      a_right: Left := bleft + bwidth - Width - margin;
    end;
    Top := (bheight - Height) / 2;
  end;
end;

procedure FindIndex(strlst: TStringList; str: string; var idx: Integer);
var
  i: Integer;
begin
  for i := idx + 1 to strlst.Count - 1 do
    if strlst.Strings[i] = str then begin
      idx := i;
      Exit;
    end;
  idx := -1;
end;

procedure GetEditValue(edt: TEdit; var data: Integer); overload;
begin
  try
    data := StrToInt(edt.Text);
  except