repselectfrm.pas

来自「群星医药系统源码」· PAS 代码 · 共 338 行

unit RepSelectFrm;

interface

{$define Use_xFrDll}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, Menus, ImgList, ActnList, IniFiles, RzButton, RzListVw,
  xBaseFrm, uGlobal, {$ifndef Use_xFrDll}xFrPnt, {$endif}ComCtrls, DB;

type
  TFmRepSelect = class(TxBaseForm)
    BtnRepFiles: TRzMenuButton;
    PopMenu1: TPopupMenu;
    pM_Add: TMenuItem;
    pM_Copy: TMenuItem;
    pM_Edit: TMenuItem;
    pM_Del: TMenuItem;
    BitBtn1: TRzBitBtn;
    ActionList1: TActionList;
    ActAddRepFile: TAction;
    ActCpyRepFile: TAction;
    ActEdtRepFile: TAction;
    ActDelRepFile: TAction;
    ActRepPreview: TAction;
    ActRepDesign: TAction;
    ActRepPrint: TAction;
    ImageList1: TImageList;
    RzBitBtn1: TRzBitBtn;
    RzBitBtn2: TRzBitBtn;
    RzBitBtn3: TRzBitBtn;
    lvReports: TRzListView;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ActAddRepFileExecute(Sender: TObject);
    procedure ActDelRepFileExecute(Sender: TObject);
    procedure ActRepPreviewExecute(Sender: TObject);
    procedure lvReportsDblClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure lvReportsKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    IniReport: TIniFile;
    sRepList: TStrings;
    LineMoved: Boolean;
		procedure PrintRep(sRepFile:String; PrintMode: Integer);
  public
    RepSection: String;
    DataSets : Array of TDataSet;
    DataNames, VarsList: TStrings;
  end;

{$ifdef Use_xFrDll}
type
	frPrint = Procedure(sRepFile:PChar; DataSets:array of TDataSet; sDBNames, sVars:TStrings;
		bDisabCtrl:Boolean; nPrintMode : integer);stdcall;
{$endif}

var
  RepPath: string;
  FmRepSelect: TFmRepSelect;

procedure PrintReport(sRepFile:String; vDataSets: array of TDataSet; cDataNames: String;
  sVars: TStrings=nil; PrintMode: Integer=2);
procedure SelRepPrint(sRepSection:String; vDataSets: array of TDataSet; vDataNames: String;
  CanDesign: Boolean=true; sVars: TStrings=nil);

implementation

uses RepFileEdFrm;

{$R *.DFM}

procedure PrintReport(sRepFile:String; vDataSets: array of TDataSet; cDataNames: String;
  sVars: TStrings=nil; PrintMode: Integer=2);
var DataNames: TStrings;
{$ifdef Use_xFrDll}
    PFunc: TFarProc;
    Moudle: THandle;
{$endif}
begin
  if sRepFile='' then raise Exception.Create('请指定报表文件名称！');
  {$ifdef Use_xFrDll}
  Moudle := 0;
  if FileExists('xFrPrint_Ado.dll') then
    Moudle := Loadlibrary('xFrPrint_Ado.DLL');
  if Moudle<32 then
  	Moudle := Loadlibrary('xFrPrint.DLL');
  if Moudle > 32 then begin
    Pfunc := GetProcAddress(Moudle,'xFRepPrint');
    if Pfunc<>nil then begin
      DataNames := TStringList.Create;
      DataNames.Text := cDataNames;
      frPrint(Pfunc)(PChar(sRepFile), vDataSets, DataNames, sVars, false, PrintMode);
      DataNames.Free;
    end else
      Application.MessageBox('无法找到指定功能块在指定的动态链接库！', '错误', MB_OK + MB_ICONERROR);
  end else
    Application.MessageBox('无法装载指定的动态链接库！', '错误', MB_OK + MB_ICONERROR);
  Freelibrary(Moudle);
  {$else}
  xFRepPrint(PChar(sRepFile), DataSets, DataNames, VarsList, false, PrintMode);
  {$endif}
end;

procedure SelRepPrint(sRepSection:String; vDataSets: array of TDataSet; vDataNames: String;
  CanDesign: Boolean; sVars: TStrings);
var n, k : integer;
begin
	k := Length(vDataSets);
  for n:=0 to k-1 do begin
  	if not vDataSets[n].Active then begin
    	Application.MessageBox('尚有数据集未打开，请先获取数据再试一次！', '错误', MB_OK+MB_ICONERROR);
      Exit;
    end;
  end;
  Application.CreateForm(TFmRepSelect, FmRepSelect);
  with FmRepSelect do begin
    try
      ActRepDesign.Enabled := CanDesign;
    	RepSection := sRepSection;
      if sVars<>nil then
	      VarsList.Assign(sVars);
      xStrSplit(vDataNames, [',', ';'], DataNames);
      SetLength(DataSets, k);
      for n:=0 to k-1 do begin
      	DataSets[n] := vDataSets[n];
    	end;
      ShowModal;
    finally
      Free;
    end;
  end;
end;

procedure TFmRepSelect.FormCreate(Sender: TObject);
var str: String;
begin
  str := ExtractFilePath(ParamStr(0));
  if RepPath='' then RepPath := str+'Reports\';
  IniReport := TIniFile.Create(str+'Reports.INI');
  DataNames := TStringList.Create;
  VarsList	:= TStringList.Create;
  sRepList  := TStringList.Create;
end;

procedure TFmRepSelect.FormShow(Sender: TObject);
var str, sRepFile: String;
    vItem: TListItem;
    i, n: integer;
begin
  LineMoved := false;
  BtnRepFiles.Enabled := ActRepDesign.Enabled;
  if IniReport.SectionExists(RepSection) then begin
    IniReport.ReadSection(RepSection, sRepList);
    for i:=0 to sRepList.Count-1 do begin
      str := IniReport.ReadString(RepSection, sRepList[i], '');
      if str='' then continue;
      n := AnsiPos(';', str);
      if n=0 then begin
        sRepFile := str;
        str := '';
      end else begin
        sRepFile := copy(str, 1, n-1);
        delete(str, 1, n);
      end;
      vItem := lvReports.Items.Add;
      vItem.ImageIndex := 7;
      vItem.Caption := sRepList[i];
      vItem.SubItems.Add(sRepFile);
      vItem.SubItems.Add(str);
    end;
  end;
end;

procedure TFmRepSelect.FormClose(Sender: TObject;
  var Action: TCloseAction);
var i, k: integer;
    sRepName, sRepFile, sRemark: String;
begin
  if LineMoved then
  begin
    //重写INI文件
    IniReport.EraseSection(RepSection);
    k := lvReports.Items.Count;
    for i:=0 to k-1 do
    begin
      sRepName := lvReports.Items[i].Caption;
      sRepFile := lvReports.Items[i].SubItems[0];
      sRemark  := lvReports.Items[i].SubItems[1];
      IniReport.WriteString(RepSection, sRepName, sRepFile+';'+sRemark);
    end;
  end;
end;

procedure TFmRepSelect.FormDestroy(Sender: TObject);
begin
  sRepList.Free;
  DataNames.Free;
  VarsList.Free;
  DataSets := nil;
end;

procedure TFmRepSelect.PrintRep(sRepFile:String; PrintMode: Integer);
var str : String;
begin
  if sRepFile='' then raise Exception.Create('请指定报表文件名称！');
  if not DirectoryExists(RepPath) then
  	ForceDirectories(RepPath);
	sRepFile := RepPath+sRepFile;
  str := UpperCase(ExtractFileExt(sRepFile));
  if str<>'.FRF' then	sRepFile := sRepFile+'.FRF';
  if not FileExists(sRepFile) and ActRepDesign.Enabled then
		PrintMode := 1;//如果报表文件不存在，且允许用户设计报表时转设计模式
  PrintReport(sRepFile, DataSets, DataNames.Text, VarsList, PrintMode);
end;

procedure TFmRepSelect.ActAddRepFileExecute(Sender: TObject);
var sRepName, sRepFile, sRemark: String;
    iType: Integer;//1：新增，2：复制，3：修改
    vItem: TListItem;
begin
  iType := TComponent(Sender).Tag;
	with TRepFileEdForm.Create(Self) do begin
    if iType>1 then begin
      vItem := lvReports.Selected;
      if vItem=nil then Exit;
      edRepName.ReadOnly := iType=3;
      edRepName.Text := vItem.Caption;
      edRepFile.Text := vItem.SubItems[0];
      edRemark.Text  := vItem.SubItems[1];
    end;
  	if ShowModal=mrOk then begin
      sRepName := edRepName.Text;
      while (iType<3)and(sRepList.IndexOf(sRepName)>=0) do begin
        Application.MessageBox('该报表名称已存在，请重新指定报表名称！', '消息', MB_ICONWARNING);
        if ShowModal=mrCancel then begin
          Free;
          Exit;
        end;
        sRepName := edRepName.Text;
      end;
      sRepFile := edRepFile.Text;
      sRemark  := edRemark.Text;
      if iType=3 then begin
        vItem.SubItems[0] := sRepFile;
        vItem.SubItems[1] := sRemark;
      end else begin
        if (iType=2)and FileExists(RepPath+vItem.SubItems[0]) then
          CopyFile(PChar(RepPath+vItem.SubItems[0]), Pchar(RepPath+sRepFile), true);//如果文件已存在则不复制
        sRepList.Add(sRepName);
        vItem := lvReports.Items.Add;
        vItem.ImageIndex := 7;
        vItem.Caption := sRepName;
        vItem.SubItems.Add(sRepFile);
        vItem.SubItems.Add(sRemark);
      end;
      IniReport.WriteString(RepSection, sRepName, sRepFile+';'+sRemark);
    end;
    Free;
  end;
end;

procedure TFmRepSelect.ActDelRepFileExecute(Sender: TObject);
var str : String;
    vItem: TListItem;
begin
  vItem := lvReports.Selected;
  if vItem=nil then Exit;
  if Application.MessageBox(PChar(vItem.Caption+' 报表将被删除，你确认吗？'), '删除报表', MB_OKCANCEL+MB_ICONQUESTION)=IDOK then begin
    IniReport.DeleteKey(RepSection, vItem.Caption);
  	str := RepPath+vItem.SubItems[0];
    if Application.MessageBox('同时删除磁盘上的报表文件吗？', '删除报表', MB_YESNO+MB_ICONQUESTION+MB_DEFBUTTON2)=IDYES then
    	DeleteFile(str);
  end;
end;

procedure TFmRepSelect.ActRepPreviewExecute(Sender: TObject);
var str : String;
begin
  if lvReports.Selected=nil then Exit;
	str := lvReports.Selected.SubItems[0];
  if str='' then
  	Application.MessageBox('请先指定报表文件名称!', '', MB_ICONWARNING)
  else
		PrintRep(str, (Sender As TComponent).Tag);
end;

procedure TFmRepSelect.lvReportsDblClick(Sender: TObject);
begin
	ActRepPreview.Execute;
end;

procedure TFmRepSelect.lvReportsKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var i, j: Integer;
    vItem: TListItem;
    s1, s2, s3: String;
begin
  if ([ssCtrl]=Shift) then
  begin
    j := -1;
    if Key=VK_DOWN then
    begin
      //下移
      i := lvReports.ItemIndex;
      if (i<0) or (i=lvReports.Items.Count-1) then
        Exit;
      j := i+1;
    end
    else if Key=VK_UP then
    begin
      //上移
      i := lvReports.ItemIndex;
      if i<=0 then
        Exit;
      j := i-1;
    end;
    if j>=0 then
    begin
      vItem := lvReports.Items[i];
      s1 := vItem.Caption;
      s2 := vItem.SubItems[0];
      s3 := vItem.SubItems[1];
      vItem.Delete;
      vItem := lvReports.Items.Insert(j);
      vItem.Caption := s1;
      vItem.SubItems.Add(s2);
      vItem.SubItems.Add(s3);
      LineMoved := true;
    end;
  end;
end;

end.