wwexport.pas

胜天进销存源码,国产优秀的进销存

unit wwexport;
{
//
// Components : TwwExportOptions
//
// Copyright (c) 1995-2001 by Woll2Woll Software
//
// Revisions:
// 5/18/2001 - PYW - Should check grid's options to see if dgShowFooter in Options as well.
// 6/3/2001 - PYW - Strip Trailing Spaces for HTML files.
// 12/12/2001 - PYW - change HTML tag &nbsp to  
// 2/1/2002 - PYW - Added code to handle special controls in grid.
// 2/15/2002 - PYW - Changed Exporting of HTML so Outlook Express and other programs can paste after saving to the clipboard.
//                   Set new property UseOldClipboardSaving to True for old behavior.
// 2/15/2002-PYW-Need to add space for footer cell if recordno is visible.
// 3/13/2002-PYW-Add new property to allow use of A1 reference in Excel vs R1C1.
// 3/13/2002-PYW-Make sure the SYLK format is stored with decimals.  Important for Intl settings.
// 10/15/2004 - Support BCD
}
{
NOTES:
1) Need to add Option to not Replace #13#10 with <br> for html in TMemoFields or TRichEdits or String?
   Currently it is doing so blindly.
2) Events to Add:
   OnAddHTMLTag : Need to add formatting event
              (Pass if this is a summary, title, datacell or datarow) Return string to add.
   OnExportHTMLText : Pass string to display, fieldname, and get changed text.
3) Summary Title and Footer info not showing in certain export types.
4) Should we support grid's bidi mode (RTL or LTF?) with other formats besides HTML?
5) Need to call GroupEvents for custom group coloring and font settings.
6) Need to handle special html characters that are used in text.  Probably provide option for
   replacing at the cell level as in some cases it is nice to insert HTML text into HTML cells.
      '<' -> '&lt;';
      '>' -> '&gt;';
   Or allow the end-user to change this with the event above.
}

interface
{$R-,T-,H+,X+}
  uses windows, classes, forms, graphics, SysUtils, controls;

  type
  //wwgetXML not implemented yet.
  TwwGridExportType = (wwgetTxt, wwgetHTML, wwgetSYLK, wwgetXML);
  //esoShowFooter not implemented yet.
  TwwExportSaveOption = (esoShowHeader, esoShowFooter, esoDynamicColors, esoShowTitle,
                         esoDblQuoteFields, esoSaveSelectedOnly, esoAddControls, esoBestColFit,
                         esoShowRecordNo, esoEmbedURL, esoShowAlternating, esoTransparentGrid, esoClipboard);
  TwwExportSaveOptions = set of TwwExportSaveOption;

  TwwExportOptions = class(TPersistent)
  private
     FFileName: string;
     FExportType: TwwGridExportType;
     FDelimiter: string;
     FOptions : TwwExportSaveOptions;
     FTitleName: string;
     FOutputWidthinTwips: integer;
     FHTMLBorderWidth : integer;
     FUseOldClipboardSaving : boolean;
     FUseA1SYLKReference : boolean; // 3/13/2002-PYW-Add new property to allow use of A1 reference in Excel vs R1C1.
     function GetFileName : string;
     procedure SetFileName(val: string);
     function GetDelimiter : string;
     procedure SetDelimiter(val: string);
     function IsDelimiterStored: boolean;
  protected
     function AddQuotes(s:string):string; virtual;
     Function XRecNoOffset: integer;
     Function QuotesPad: integer;
  public
     Owner: TComponent;
     procedure Save; virtual;
  //   procedure SaveToClipboard; virtual;
     procedure ExportToStream(fs:TStream);
     constructor Create(AOwner: TComponent); virtual;
     property UseOldClipboardSaving: boolean read FUseOldClipboardSaving write FUseOldClipboardSaving default False;
     property UseA1SYLKReference: boolean read FUseA1SYLKReference write FUseA1SYLKReference default False;
  published
     property Delimiter: string read GetDelimiter write SetDelimiter stored IsDelimiterStored;
     property ExportType: TwwGridExportType read FExportType write FExportType default wwgetTxt;
     property FileName: string read GetFileName write SetFileName;
     property HTMLBorderWidth : integer read FHTMLBorderWidth write FHTMLBorderWidth default 1;
     property Options : TwwexportSaveOptions read FOptions write FOptions default [esoShowHeader, esoShowTitle, esoDblQuoteFields, esoShowAlternating];
     property OutputWidthinTwips : integer read FOutputWidthinTwips write FOutputWidthinTwips default 0;
     property TitleName : string read FTitleName write FTitleName;
  end;

implementation

uses wwstr, db, wwDBComb, wwRadioGroup, wwCheckbox, wwDBGrid, wwDBiGrd, wwcommon, wwmemo, Dialogs, clipbrd;

const wwCRLF = #13#10;

//dbcol not public so calculate grid data column.
function getdbcol(Grid:TwwDBGrid; col:integer):integer;
begin
   result:= col;
   if wwdbigrd.dgIndicator in Grid.Options then result:= col - 1;
end;

Function ReplaceStrWithStr(str: string; removestr: string;replaceStr: string): string;
var i: integer;
begin
   Result := '';
   i:=1;
   while i<=length(str) do begin
      if (strlcomp(PChar(Copy(str,i,length(removestr))), PChar(removestr),
          length(removestr))<>0) then
      begin
         Result := Result + str[i];
         i:=i+1;
      end
      else begin
        Result:= Result + replaceStr;
        i:=i+length(removeStr);
      end;
   end;
end;

{*************************
 * HTML string functions *
 *************************}

//Get Color String in Hex Format for HTML Colors
function ColorToHexString(aColor:TColor):String;
var dummy,R,G,B:Byte;
  procedure ColorToByteValues(AColor: TColor; var Reserved, Blue, Green, Red: Byte);
    var WinColor: COLORREF;
  begin
    WinColor := ColorToRGB(AColor);
    Reserved := ($FF000000 and WinColor) Shr 24;
    Blue := ($00FF0000 and WinColor) Shr 16;
    Green := ($0000FF00 and WinColor) Shr 8;
    Red := ($000000FF and WinColor);
  end;
begin
  ColorToByteValues(aColor,dummy,R,G,B);
  result := Format('%2.2x%2.2x%2.2x',[B,G,R]);
end;

//Set HTML Background Color.
function SetBkGrndColor(aColor:TColor):string;
begin
   result := 'BGCOLOR=#'+ColorToHexString(AColor);
end;

//Get HTML Alignment string.
function getalignstr(value:TAlignment):string;
begin
  result := '';
  case value of
    taCenter:result := 'center';
    taLeftJustify:result := 'left';
    tarightJustify:result := 'right';
  end;
end;

//Place Font Style Format HTML tag/identifiers around passed in string.
function SetFormatStyle(const s:string;aFont:TFont):string;
begin
   result := s;
   if fsItalic in aFont.Style then
      result := '<I>'+result+'</I>';
   if fsBold in aFont.Style then
      result := '<B>'+result+'</B>';
   if fsUnderline in aFont.Style then
      result := '<U>'+result+'</U>';
   if fsStrikeOut in aFont.Style then
      result := '<STRIKE>'+result+'</STRIKE>';
end;

//Build HTML Inline Style string based on Font properties.  Leave out Style as it is
//handled by SetFormatStyle.
function SetFontstr(aFont:TFont):string;
begin
   result := 'STYLE="font-family: ' + aFont.Name+ ';'+
             'font-size: ' + IntToStr(aFont.Size) +' pt;'+
             'color:#'+ ColorToHexString(aFont.Color)+';'+
             '"';
end;

function SwapHTMLSymbols(const s: string): string;
var
  i: Integer;
  ch: Char;
  replacestr: string;
begin
  Result := '';
  for i := 1 to Length(s) do
  begin
    ch := s[i];
    case ch of
      '<': replacestr := '&lt;';
      '>': replacestr := '&gt;';
    else
      replacestr := ch
    end;
    Result := Result + replacestr
  end
end;

{*******************************
 * SYLK/Excel string functions *
 *******************************}

function GetSYLKAlignment(value:TAlignment):string;
begin
   result := '';
   case value of
      taleftjustify:result := 'L';
      tarightjustify:result := 'R';
      taCenter: result := 'C';
   end;
end;

//This function adds the given font to the FontList if it is a unique font for the
//given style properties.  It will return the Font Count Number as this is used when
//building the tags for the SYLK format.
function AddToSYLKFontList(aFont:TFont;fontlist:TStrings):string;
var fontstr:string;
    boldflag:boolean;
    italicflag:boolean;
    underlineflag:boolean;
    fontcount:integer;
begin
   result := '';
   if fontlist = nil then fontlist := TStringList.Create;
   boldflag := false;
   italicflag := false;
   underlineflag:=false;
   Fontstr := 'P;F'+aFont.Name+';M'+inttostr(aFont.Size*20);
   if fsBold in aFont.style then begin
     Fontstr := Fontstr+';SB';
     boldflag := True;
   end;
   if fsItalic in aFont.Style then begin
     if boldflag then Fontstr := Fontstr + 'I'
     else Fontstr := Fontstr+';SI';
     italicflag := True;
   end;
   if fsUnderline in aFont.Style then begin
     if (not boldflag) and (not italicflag) then
        Fontstr := Fontstr+';SU'
     else Fontstr := Fontstr + 'U';
     underlineflag := True;
   end;
   if fsStrikeOut in aFont.Style then begin
     if (not boldflag) and (not italicflag) and (not underlineflag) then
        Fontstr := Fontstr+';SS'
     else Fontstr := Fontstr + 'U';
   end;
   if (FontList.IndexOfName(fontstr)>-1) then
   begin
      result := FontList.Values[fontstr];
      exit;
   end;
   fontcount := FontList.Count;
   FontList.Add(Fontstr+'='+inttostr(fontcount));
   result := inttostr(fontcount);
end;

{********************
 * TwwExportOptions *
 ********************}
constructor TwwExportOptions.Create(AOwner: TComponent);
begin
   inherited Create;
   FileName := '';
   FOptions := [esoShowHeader,esoShowTitle,esoDblQuoteFields,esoShowAlternating];
   FExportType:=wwgetTxt;
   FDelimiter := ',';
   FOutputWidthinTwips := 0;
   FHTMLBorderWidth := 1;
   FUseA1SYLKReference := False;
   Owner := AOwner;
end;

function TwwExportOptions.AddQuotes(s:string):string;
begin
  if (esoDblQuoteFields in Options) then
  begin
    if (s<>'') or
       ((FDelimiter ='') and (exporttype = wwgetTxt) and (s='')) then
       result := '"'+s+'"'