jvgexportcomponents.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvgExportComponents.PAS, released on 2003-01-15.

The Initial Developer of the Original Code is Andrey V. Chudin,  [chudin att yandex dott ru]
Portions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.
All Rights Reserved.

Contributor(s):
Michael Beck [mbeck att bigfoot dott com].

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvgExportComponents.pas,v 1.39 2005/03/09 14:57:33 marquardt Exp $

unit JvgExportComponents;

{$I jvcl.inc}
{$I windowsonly.inc}

interface

uses
  {$IFDEF USEJVCL}
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  {$ENDIF USEJVCL}
  Windows, Messages, SysUtils, Classes, Graphics,
  {$IFDEF USEJVCL}
  Controls, Forms, Dialogs, DB,
  JvComponent;
  {$ELSE}
  Controls, Forms, Dialogs, DB;
  {$ENDIF USEJVCL}

type
  TJvExportCaptions = (fecDisplayLabels, fecFieldNames, fecNone);
  TJvExportGetValue = procedure(Sender: TObject; const Field: TField; var Caption: string) of object;
  // RDB Added TDataSet to Signature
  TJvExportRecordEvent = procedure(Sender: TObject; const DataSet: TDataSet;
    var AllowExport: Boolean) of object;
  // RDB Added TField to Signature
  TJvExportFieldEvent = procedure(Sender: TObject; const Field: TField; var
    FieldValue: string) of object;

  TJvExportProgressEvent = procedure(Sender: TObject; Min, Max, Position: Integer;
    const Msg: string) of object;

  TJvGetLineFontEvent = procedure(Sender: TObject; LineNo: Integer;
    const Value: string; Font: TFont) of object;

  EJvgExportException = class(Exception);

  {$IFDEF USEJVCL}
  TJvgCommonExport = class(TJvComponent)
  {$ELSE}
  TJvgCommonExport = class(TComponent)
  {$ENDIF USEJVCL}
  private
    FSaveToFileName: string;
    FDataSet: TDataSet;
    FOnExportField: TJvExportFieldEvent;
    FOnExportRecord: TJvExportRecordEvent;
    FOnGetCaption: TJvExportGetValue;
    FCaptions: TJvExportCaptions;
    FTransliterateRusToEng: Boolean;
    FMaxFieldSize: Integer;
    FOnGetTableName: TJvExportGetValue;
    FOnProgress: TJvExportProgressEvent;
    procedure SetCaptions(const Value: TJvExportCaptions);
    procedure SetDataSet(const Value: TDataSet);
    procedure SetSaveToFileName(const Value: string);
    procedure SetMaxFieldSize(const Value: Integer);
    procedure SetTransliterateRusToEng(const Value: Boolean);
  protected
    function GetFieldValue(const Field: TField): string;
    procedure DoGetTableName(var ATableName: string); virtual;
    procedure DoProgress(Min, Max, Position: Integer; const Msg: string); virtual;
  public
    procedure Execute; virtual;
  protected
    property DataSet: TDataSet read FDataSet write SetDataSet;
    property Captions: TJvExportCaptions read FCaptions write SetCaptions;
    property SaveToFileName: string read FSaveToFileName write
      SetSaveToFileName;
    property TransliterateRusToEng: Boolean read FTransliterateRusToEng write
      SetTransliterateRusToEng;
    property MaxFieldSize: Integer read FMaxFieldSize write SetMaxFieldSize;

    property OnGetCaption: TJvExportGetValue read FOnGetCaption write FOnGetCaption;
    property OnExportRecord: TJvExportRecordEvent read FOnExportRecord write FOnExportRecord;
    property OnExportField: TJvExportFieldEvent read FOnExportField write FOnExportField;
    property OnProgress: TJvExportProgressEvent read FOnProgress write FOnProgress;
    property OnGetTableName: TJvExportGetValue read FOnGetTableName write FOnGetTableName;
  end;

  TJvgExportExcel = class(TJvgCommonExport)
  private
    FHeader: TStringList;
    FFooter: TStringList;
    FBackgroundPicture: TFileName;
    FAutoColumnFit: Boolean;
    FExcelVisible: Boolean;
    FCloseExcel: Boolean;
    FOnGetFooterLineFont: TJvGetLineFontEvent;
    FOnGetHeaderLineFont: TJvGetLineFontEvent;
    FSubHeader: TStringList;
    FSubHeaderFont: TFont;
    FHeaderFont: TFont;
    FFooterFont: TFont;
    FForceTextFormat: Boolean;
    FOnGetSubHeaderLineFont: TJvGetLineFontEvent;
    function GetHeader: TStrings;
    function GetFooter: TStrings;
    function GetSubHeader: TStrings;
    procedure SetHeader(const Value: TStrings);
    procedure SetFooter(const Value: TStrings);
    procedure SetBackgroundPicture(const Value: TFileName);
    procedure SetAutoColumnFit(const Value: Boolean);
    procedure SetExcelVisible(const Value: Boolean);
    procedure SetCloseExcel(const Value: Boolean);
    procedure SetSubHeader(const Value: TStrings);
    procedure SetFooterFont(const Value: TFont);
    procedure SetHeaderFont(const Value: TFont);
    procedure SetSubHeaderFont(const Value: TFont);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute; override;
  published
    property DataSet;
    property Captions;
    property SaveToFileName;
    property TransliterateRusToEng;
    property MaxFieldSize;
    property Header: TStrings read GetHeader write SetHeader;
    property SubHeader: TStrings read GetSubHeader write SetSubHeader;
    property Footer: TStrings read GetFooter write SetFooter;
    property HeaderFont: TFont read FHeaderFont write SetHeaderFont;
    property SubHeaderFont: TFont read FSubHeaderFont write SetSubHeaderFont;
    property FooterFont: TFont read FFooterFont write SetFooterFont;
    property AutoColumnFit: Boolean read FAutoColumnFit write SetAutoColumnFit
      default True;
    property BackgroundPicture: TFileName read FBackgroundPicture write
      SetBackgroundPicture;
    property ExcelVisible: Boolean read FExcelVisible write SetExcelVisible;
    property ForceTextFormat: Boolean read FForceTextFormat write FForceTextFormat default False;
    property CloseExcel: Boolean read FCloseExcel write SetCloseExcel;

    property OnGetHeaderLineFont: TJvGetLineFontEvent read FOnGetHeaderLineFont write FOnGetHeaderLineFont;
    property OnGetSubHeaderLineFont: TJvGetLineFontEvent read FOnGetSubHeaderLineFont write FOnGetSubHeaderLineFont;
    property OnGetFooterLineFont: TJvGetLineFontEvent read FOnGetFooterLineFont write FOnGetFooterLineFont;
    property OnGetCaption;
    property OnExportRecord;
    property OnExportField;
  end;

  TJvCreateDataset = procedure(Sender: TObject; var DataSet: TDataSet) of object;

  TJvgExportDataset = class(TJvgCommonExport)
  private
    FOnCreateDest: TJvCreateDataset;
    FOnSaveDest: TJvCreateDataset;
  public
    procedure Execute; override;
  published
    property DataSet;
    property Captions;
    property MaxFieldSize;
    property OnGetCaption;
    property OnExportRecord;
    property OnExportField;
    property OnCreateDest: TJvCreateDataset read FOnCreateDest write FOnCreateDest;
    property OnSaveDest: TJvCreateDataset read FOnSaveDest write FOnSaveDest;
  end;

  TJvgExportHTML = class(TJvgCommonExport)
  private
    FFooter: TStringList;
    FHeader: TStringList;
    FStyles: TStringList;
    function GetFooter: TStrings;
    function GetHeader: TStrings;
    function GetStyles: TStrings;
    procedure SetFooter(const Value: TStrings);
    procedure SetHeader(const Value: TStrings);
    procedure SetStyles(const Value: TStrings);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    //    procedure Execute; override;
  published
    property DataSet;
    property Captions;
    property SaveToFileName;
    property TransliterateRusToEng;
    property MaxFieldSize;
    property OnGetCaption;
    property OnExportRecord;
    property OnExportField;
    property Header: TStrings read GetHeader write SetHeader;
    property Footer: TStrings read GetFooter write SetFooter;
    property Styles: TStrings read GetStyles write SetStyles;
  end;

  {$IFDEF USEJVCL}
  TJvgExportXML = class(TJvgCommonExport)
  public
    procedure Execute; override;
  published
    property DataSet;
    property Captions;
    property SaveToFileName;
    property TransliterateRusToEng;
    property MaxFieldSize;
    property OnGetCaption;
    property OnExportRecord;
    property OnExportField;
    property OnProgress;
  end;
  {$ENDIF USEJVCL}

{$IFDEF USEJVCL}
{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvgExportComponents.pas,v $';
    Revision: '$Revision: 1.39 $';
    Date: '$Date: 2005/03/09 14:57:33 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}
{$ENDIF USEJVCL}

implementation

uses
  ComObj, FileCtrl,
  {$IFDEF USEJVCL}
  JvResources,
  JvConsts, JvSimpleXML,
  {$ENDIF USEJVCL}
  JvgUtils, JvgFileUtils;

{$IFNDEF USEJVCL}
resourcestring
  RsEDataSetIsUnassigned = 'DataSet is unassigned';
{$ENDIF !USEJVCL}

{$IFDEF COMPILER5}
function BoolToStr(Value: Boolean; AsString: Boolean = False): string;
const
  BoolStr: array [Boolean, Boolean] of PChar = (('0', 'False'), ('-1', 'True'));
begin
  Result := BoolStr[Value, AsString];
end;
{$ENDIF COMPILER5}

//=== { TJvgCommonExport } ===================================================

procedure TJvgCommonExport.Execute;
begin
  if not Assigned(DataSet) then
    raise EJvgExportException.CreateRes(@RsEDataSetIsUnassigned);
  DataSet.Active := True;
  if SaveToFileName <> '' then
    ForceDirectories(ExtractFilePath(SaveToFileName));
end;

procedure TJvgCommonExport.SetCaptions(const Value: TJvExportCaptions);
begin
  FCaptions := Value;
end;

procedure TJvgCommonExport.SetDataSet(const Value: TDataSet);
begin
  FDataSet := Value;
end;

procedure TJvgCommonExport.SetMaxFieldSize(const Value: Integer);
begin
  FMaxFieldSize := Value;
end;

procedure TJvgCommonExport.SetSaveToFileName(const Value: string);
begin
  FSaveToFileName := Trim(Value);
end;

procedure TJvgCommonExport.SetTransliterateRusToEng(const Value: Boolean);
begin
  FTransliterateRusToEng := Value;
end;

procedure TJvgCommonExport.DoProgress(Min, Max, Position: Integer; const Msg: string);
begin
  if Assigned(FOnProgress) then
    FOnProgress(Self, Min, Max, Position, Msg);
end;

function TJvgCommonExport.GetFieldValue(const Field: TField): string;
begin
  Result := Field.AsString;
  if Assigned(FOnExportField) then
    FOnExportField(Self, Field, Result);

  if FTransliterateRusToEng then
    Result := Transliterate(Result, True);

  if (FMaxFieldSize > 0) and (Field.DataType in [ftString, ftMemo, ftFmtMemo]) then
    if Length(Result) > FMaxFieldSize then
      Result := Copy(Result, 1, FMaxFieldSize) + '...';
end;

procedure TJvgCommonExport.DoGetTableName(var ATableName: string);
begin
  if Assigned(FOnGetTableName) then
    FOnGetTableName(Self, nil, ATableName);
end;

//=== { TJvgExportExcel } ====================================================

constructor TJvgExportExcel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFooter := TStringList.Create;
  FHeader := TStringList.Create;
  FSubHeader := TStringList.Create;
  FHeaderFont := TFont.Create;
  FSubHeaderFont := TFont.Create;
  FFooterFont := TFont.Create;
  //...defaults
  FHeaderFont.Size := 12;
  FHeaderFont.Style := [fsBold];
  FSubHeaderFont.Size := 10;
  FAutoColumnFit := True;
end;

destructor TJvgExportExcel.Destroy;
begin
  FFooter.Free;
  FHeader.Free;
  FSubHeader.Free;
  FHeaderFont.Free;
  FSubHeaderFont.Free;
  FFooterFont.Free;
  inherited Destroy;
end;

procedure TJvgExportExcel.Execute;
var
  XL: Variant;
  Sheet: Variant;
  AllowExportRecord: Boolean;
  I, RecCount, RecNo, ColNo, OldRecNo: Integer;
  CellFont: TFont;

  procedure InsertStrings(Strings: TStrings; Font: TFont; GetLineFontEvent:
    TJvGetLineFontEvent);
  var
    I: Integer;
  begin
    for I := 0 to Strings.Count - 1 do
    begin
      Sheet.Cells[RecNo, ColNo] := Strings[I];
      CellFont.Assign(Font);
      if Assigned(FOnGetHeaderLineFont) then
        FOnGetHeaderLineFont(Self, I, Strings[I], CellFont);

      Sheet.Cells[RecNo, ColNo].Font.Size := CellFont.Size;
      Sheet.Cells[RecNo, ColNo].Font.Color := CellFont.Color;
      if fsBold in CellFont.Style then
        Sheet.Cells[RecNo, ColNo].Font.Bold := True;
      if fsItalic in CellFont.Style then
        Sheet.Cells[RecNo, ColNo].Font.Italic := True;
      Inc(RecNo);
    end;
  end;

begin
  inherited Execute;

  try
    XL := GetActiveOleObject('Excel.Application');
  except
    XL := CreateOleObject('Excel.Application');
  end;

  XL.Visible := FExcelVisible;
  XL.WorkBooks.Add;
  XL.WorkBooks[XL.WorkBooks.Count].WorkSheets[1].Name := 'Report';
  Sheet := XL.WorkBooks[XL.WorkBooks.Count].WorkSheets['Report'];
  if (BackgroundPicture <> '') and FileExists(BackgroundPicture) then
    // (rom) This is correct Delphi. See "positional parameters" in the Delphi help.
    Sheet.SetBackgroundPicture(FileName := BackgroundPicture);

  CellFont := TFont.Create;
  try
    RecNo := 1;
    ColNo := 1;

    Inc(RecNo, Header.Count + SubHeader.Count);

    if FCaptions <> fecNone then
      for I := 0 to DataSet.FieldCount - 1 do
      begin
        case FCaptions of
          fecDisplayLabels:
            if DataSet.Fields[I].DisplayLabel <> '' then
              Sheet.Cells[RecNo, ColNo + I] :=
                DataSet.Fields[I].DisplayLabel
            else
              Sheet.Cells[RecNo, ColNo + I] :=
                DataSet.Fields[I].FieldName;
          fecFieldNames:
            Sheet.Cells[RecNo, ColNo + I] := DataSet.Fields[I].FieldName;