Экспорт в Excel (XLS)

Bali · May 2006

Уважаемые разработчики спасибо что добавли в экспорт в Excel изменения,
но в XLS экспорт необходимо еще внести изменения для
совместимости со всеми версиями Excel
и все будет работать, включая денежный формат

1.

function ConvertFormat(const fstr: string): string;
var
i, err, p : integer;
s: string;
begin
result := '';
if length(fstr)>0 then
begin
p := pos('.', fstr);
if p > 0 then
begin
s := Copy(fstr, p+1, length(fstr)-p-1);
val(s, p ,err);
SetLength(s, p);
FillChar(s[1], p, '0');
if p>0 then
begin
FillChar(s[1], p, '0');
s:=','+s;
end;
end;
case fstr[length(fstr)] of
'n': result := '# ##0'+s;
'f': result := '0'+s;
'g': result := '0,##';
'm': result := '# ##0,00"р"';
else result := '# ##0,00';
end;
end;
end;

2.

со строки 748

было

if not FAsText then
if (Obj.DisplayFormat.Kind=fkNumeric) then
begin
if length(s) > 0 then
begin
s := StringReplace(s, ThousandSeparator, '', [rfReplaceAll]);
s := StringReplace(s, ',', ',', [rfReplaceAll]);
if (Obj.DisplayFormat.FormatStr <> '') then
vCellFormats.Add(ConVertFormat(Obj.DisplayFormat.FormatStr)+'='+FExcel.IntToCoord(x, y))
end
end

надо сделать

var
vs: string;
vers, err: integer;

*******

if not FAsText then
if (Obj.DisplayFormat.Kind=fkNumeric) then
begin
if length(s) > 0 then
begin
s := StringReplace(s, ThousandSeparator, '', [rfReplaceAll]);
s := StringReplace(s, 'р.', '', [rfReplaceAll]);
s := StringReplace(s, ',', ',', [rfReplaceAll]);
s := Trim(s);
vs := FExcel.Excel.Version;
val(vs, vers, err);
if vers > 10 then
s := StringReplace(s, ',', '.', [rfReplaceAll]);
if (Obj.DisplayFormat.FormatStr <> '') then
vCellFormats.Add(ConVertFormat(Obj.DisplayFormat.FormatStr)+'='+FExcel.IntToCoord(x, y))
end
end

aenemy1 · June 2006

Спасибо за исправления, очень помогли
особенно был ошарашен выводом чисел в эксел при формате %2.0n - все числа заканчиваются запятой

Bali · June 2006

В виде 123, выводится только для формата %g (покрайней мере для Excel2003 со стандартными настройками),
я этот формат для экспорта в Excel не использую т.к. если выделить группу ячеек, то точность суммы по выделенным ячейкам (внизу окна) определяется по точности первой выделенной ячейке.
Чтобы число "123," было в виде "123" перед определением формата нужно проанализировать значение десятичной части ячейки после "," и если ="0", то установить формат для целого числа.

Изменения экспорта в XML
в XML экспорте также поправлена ошибка, были перепутаны X и Y
в цикле по x и Y.

procedure TfrxXMLExport.ExportPage(Stream: TStream);

******
function ConvertFormat(const fstr: string): string;
var
err, p : integer;
s: string;
begin
result := '';
s := '';
if length(fstr)>0 then
begin
p := pos('.', fstr);
if p > 0 then
begin
s := Copy(fstr, p+1, length(fstr)-p-1);
val(s, p ,err);
SetLength(s, p);
if p>0 then
begin
FillChar(s[1], p, '0');
s:='.'+s;
end;
end;
case fstr[length(fstr)] of
'n': result := '#,##0'+s;
'f': result := '0'+s;
'g': result := '0.##0';
'm': result := '#,##0.00"р."';
<span style='color:blue'>'d': result := '0';</span>
else result := '#,##0.00';
end;
end;
end;

<span style='color:blue'>var
dFormat: string;

Function GetDFormat: string;
var
p, err: integer;
s: string;
begin
result := Obj.DisplayFormat.FormatStr;
if length(result)=0 then exit;
if result[Length(result)]='g' then
begin
s := StringReplace(TruncReturns(Obj.Memo.Text), ThousandSeparator, '', [rfReplaceAll]);
s := StringReplace(s, 'р.', '', [rfReplaceAll]);
s := StringReplace(s, ',', '.', [rfReplaceAll]);
p := pos('.', s);
if p>0 then
begin
s := copy(s, p+1, length(s)-p);
val(s, p ,err);
end;
if p=0 then result:='%d';
end;
end;</span>
*******

begin
PageBreak := TStringList.Create;
FormatList := TStringList.Create;

*********

nn := FMatrix.StylesCount;

{!!!!!здесь был перепутан цикл X с Y!!!!!}

for y := 0 to FMatrix.Height - 2 do
for x := 0 to FMatrix.Width - 1 do
begin
m := FMatrix.GetCell(x, y);
if (m <> -1) then
begin
Obj := FMatrix.GetObjectById(m);
if (Obj.DisplayFormat.Kind = fkNumeric) and
(Obj.DisplayFormat.FormatStr <> '') and
(Obj.DisplayFormat.FormatStr <> '%2.2n') then
begin
<span style='color:blue'>dFormat := GetdFormat;</span>
<span style='color:blue'>if (FormatList.IndexOfName(DFormat) < 0) then</span>
begin
s := 's' + IntToStr(nn);
WriteExpLn('<Style ss:ID="' + s + '">');
<span style='color:blue'>WriteExpLn('<NumberFormat ss:Format="' + UTF8Encode
(ConVertFormat(dFormat)) + '"/>');</span>
WriteExpLn('</Style>');
<span style='color:blue'>FormatList.Add(dFormat+'=' + s);</span>
inc(nn);
end;
end;
end;
end;
*******

s := 'Page 1';
WriteExpLn('<Worksheet ss:Name="' + UTF8Encode(s) + '">');
WriteExpLn('<Table ss:ExpandedColumnCount="' + IntToStr(FMatrix.Width) + '"' +
' ss:ExpandedRowCount="' + IntToStr(FMatrix.Height) + '" x:FullColumns="1" x:FullRows="1">');
for x := 1 to FMatrix.Width - 1 do
begin
dcol := (FMatrix.GetXPosById(x) - FMatrix.GetXPosById(x - 1)) / Xdivider;
WriteExpLn('<Column ss:AutoFitWidth="0" ss:Width="' +
frFloat2Str(dcol, 2) + '"/>');
end;
st := '';
Page := 0;

for y := 0 to FMatrix.Height - 2 do
begin
drow := (FMatrix.GetYPosById(y + 1) - FMatrix.GetYPosById(y)) / Ydivider;
WriteExpLn('<Row ss:Height="' + frFloat2Str(drow, 2) + '">');
if FMatrix.PagesCount > Page then
if FMatrix.GetYPosById(y) >= FMatrix.GetPageBreak(Page) then
begin
Inc(Page);
PageBreak.Add(IntToStr(y + 1));
if FShowProgress then
begin
FProgress.Tick;
if FProgress.Terminated then
break;
end;
end;
for x := 0 to FMatrix.Width - 1 do
begin
if FShowProgress then
if FProgress.Terminated then
break;
si := ' ss:Index="' + IntToStr(x + 1) + '" ';
i := FMatrix.GetCell(x, y);
if (i <> -1) then
begin
Obj := FMatrix.GetObjectById(i);
if Obj.Counter = 0 then
begin
FMatrix.GetObjectPos(i, fx, fy, dx, dy);
Obj.Counter := 1;
if Obj.IsText then
begin
if dx > 1 then
begin
s := 'ss:MergeAcross="' + IntToStr(dx - 1) + '" ';
Inc(dx);
end
else
s := '';
if dy > 1 then
sb := 'ss:MergeDown="' + IntToStr(dy - 1) + '" '
else
sb := '';
if FExportStyles then
begin
if (Obj.DisplayFormat.Kind = fkNumeric) and
(Obj.DisplayFormat.FormatStr <> '') and
(Obj.DisplayFormat.FormatStr <> '%2.2n') then
begin
<span style='color:blue'> fs := FormatList.Values[GetdFormat]; </span>
if fs <> '' then
st := 'ss:StyleID="' + fs + '" '
else
st := 'ss:StyleID="' + 's' + IntToStr(Obj.StyleIndex) + '" '
end
else
st := 'ss:StyleID="' + 's' + IntToStr(Obj.StyleIndex) + '" '
end
else
st := '';
WriteExpLn('<Cell' + si + s + sb + st + '>');

s := TruncReturns(Obj.Memo.Text);
if (Obj.DisplayFormat.Kind = fkNumeric) and IsDigits(s) then
begin
s := StringReplace(s, ThousandSeparator, '', [rfReplaceAll]);
s := StringReplace(s, 'р.', '', [rfReplaceAll]);
s := StringReplace(s, ',', '.', [rfReplaceAll]);
s := Trim(s);
si := ' ss:Type="Number"';
WriteExpLn('<Data' + si + '>' + UTF8Encode(s) + '</Data>');
end
else
begin
si := ' ss:Type="String"';
s := ChangeReturns(s);
WriteExpLn('<Data' + si + '>' + UTF8Encode(s) + '</Data>');
end;

WriteExpLn('</Cell>');
end;
end
end
else
WriteExpLn('<Cell' + si + '/>');
end;
WriteExpLn('</Row>');
end;
***********

end;

Изменения экспорта в XLS

*****************

function ConvertFormat(const fstr, <span style='color:blue'>valStr</span>: string): string;
var
d, i, err, p : integer;
s: string;
begin
result := '';
if length(fstr)>0 then
begin
p := pos('.', fstr);
if p > 0 then
begin
s := Copy(fstr, p+1, length(fstr)-p-1);
val(s, p ,err);
SetLength(s, p);
FillChar(s[1], p, '0');
if p>0 then
begin
FillChar(s[1], p, '0');
s:=','+s;
end;
end;
case fstr[length(fstr)] of
'n': result := '# ##0'+s;
'f': result := '0'+s;
'g': <span style='color:blue'>begin
p := pos('.', valstr);
if p>0 then
begin
s := copy(valstr, p+1, length(ValStr)-p);
val(s, p ,err);
end;
if p = 0 then result := '#'
else result := '#,##0';
end;</span>
'd': result := '#';
'm': result := '# ##0,00"р"';
else result := '# ##0,00';
end;
end;
end;

***********

if not FAsText then
if (Obj.DisplayFormat.Kind=fkNumeric) then
begin
if length(s) > 0 then
begin
s := StringReplace(s, ThousandSeparator, '', [rfReplaceAll]);
s := StringReplace(s, 'р.', '', [rfReplaceAll]);
s := StringReplace(s, ',', ',', [rfReplaceAll]);
s := Trim(s);
vs := FExcel.Excel.Version;
val(vs, vers, err);
if vers > 10 then
s := StringReplace(s, ',', '.', [rfReplaceAll]);
<span style='color:blue'>if (Obj.DisplayFormat.FormatStr <> '') then
vCellFormats.Add(ConVertFormat(Obj.DisplayFormat.FormatStr, s)+'='+FExcel.IntToCoord(x, y))</span>
end
end
else
if (Obj.DisplayFormat.Kind=fkText) then
s := '''' + s;

Bali · June 2006

В текущей конфигурации в XML экспорте при задании формата отличного от
стандартного, нарушается стиль ячеек.
Для сохранения стилей ячеек в XML экспорте необходимо в модуле
frxExportMatrix добавить в класс TfrxIEMStyle свойство NumberFormat
устанвливать его при формировании стилей, а в модулях XML и XLS экспорта
убрать формирование NumberFormat, все стили ячеек будут сохранены и
скорость формирования отчета увеличиться.

unit frxExportMatrix;
******
TfrxIEMStyle = class(TObject)
public
Font: TFont;
LineSpacing: Extended;
VAlign: TfrxVAlign;
HAlign: TfrxHAlign;
FrameTyp: TfrxFrameTypes;
FrameWidth: Single;
FrameColor: TColor;
FrameStyle: TfrxFrameStyle;
Color: TColor;
Rotation: Integer;
BrushStyle: TBrushStyle;
ParagraphGap: Extended;
GapX: Extended;
GapY: Extended;
CharSpacing: Extended;
WordBreak: Boolean;
Charset: Integer;
{!!!!!!!}
NumberFormat: string;
{!!!!!!!}
constructor Create;
destructor Destroy; override;
procedure Assign(Style: TfrxIEMStyle);
end;

*******

function TfrxIEMatrix.AddStyle(Obj: TfrxView): integer;
var
Style: TfrxIEMStyle;

function ConvertFormat(const fstr, valStr: string): string;
var
err, p : integer;
s: string;
begin
result := '';
if length(fstr)>0 then
begin
p := pos('.', fstr);
if p > 0 then
begin
s := Copy(fstr, p+1, length(fstr)-p-1);
val(s, p ,err);
SetLength(s, p);
FillChar(s[1], p, '0');
if p>0 then
begin
FillChar(s[1], p, '0');
s:=','+s;
end;
end;
case fstr[length(fstr)] of
'n': result := '# ##0'+s;
'f': result := '0'+s;
'g': begin
p := pos('.', valstr);
if p>0 then
begin
s := copy(valstr, p+1, length(ValStr)-p);
val(s, p ,err);
end;
if p = 0 then result := '#'
else result := '#,##0';
end;
'd': result := '#';
'm': result := '# ##0,00"р"';
else result := '# ##0,00';
end;
end;
end;

*********

begin
Style := TfrxIEMStyle.Create;
if IsMemo(Obj) then
begin
if TfrxCustomMemoView(Obj).Highlight.Active and
Assigned(TfrxCustomMemoView(Obj).Highlight.Font) then
begin
Style.Font.Assign(TfrxCustomMemoView(Obj).Highlight.Font);
Style.Color := TfrxCustomMemoView(Obj).Highlight.Color;
end else
begin
Style.Font.Assign(TfrxCustomMemoView(Obj).Font);
Style.Color := TfrxCustomMemoView(Obj).Color;
end;
Style.HAlign := TfrxCustomMemoView(Obj).HAlign;
Style.VAlign := TfrxCustomMemoView(Obj).VAlign;
Style.LineSpacing := TfrxCustomMemoView(Obj).LineSpacing;
Style.GapX := TfrxCustomMemoView(Obj).GapX;
Style.GapY := TfrxCustomMemoView(Obj).GapY;
if TfrxCustomMemoView(Obj).Font.Charset = 1 then
Style.Charset := GetFontCharset(TfrxCustomMemoView(Obj).Font)
else
Style.Charset := TfrxCustomMemoView(Obj).Font.Charset;
Style.CharSpacing := TfrxCustomMemoView(Obj).CharSpacing;
Style.ParagraphGap := TfrxCustomMemoView(Obj).ParagraphGap;
Style.WordBreak := TfrxCustomMemoView(Obj).WordBreak;
Style.FrameTyp := TfrxCustomMemoView(Obj).Frame.Typ;
Style.FrameWidth := TfrxCustomMemoView(Obj).Frame.Width;
Style.FrameColor := TfrxCustomMemoView(Obj).Frame.Color;
Style.FrameStyle := TfrxCustomMemoView(Obj).Frame.Style;
Style.Rotation := TfrxCustomMemoView(Obj).Rotation;
if (TfrxCustomMemoView(Obj).DisplayFormat.Kind = fkNumeric) and
(TfrxCustomMemoView(Obj).DisplayFormat.FormatStr <> '') then
Style.NumberFormat := ConvertFormat(TfrxCustomMemoViewObj).DisplayFormat.FormatStr,
TfrxCustomMemoView(Obj).Memo.Text); end
else if IsLine(Obj) then
begin
Style.Color := Obj.Color;
if Obj.Width = 0 then
Style.FrameTyp := [ftLeft]
else if Obj.Height = 0 then
Style.FrameTyp := [ftTop]
else Style.FrameTyp := [];
Style.FrameWidth := Obj.Frame.Width;
Style.FrameColor := Obj.Frame.Color;
Style.FrameStyle := Obj.Frame.Style;
Style.Font.Name := 'Arial';
Style.Font.Size := 1;
end
else if IsRect(Obj) then
begin
Style.Free;
Result := -1;
Exit;
end
else begin
Style.Font.Assign(Obj.Font);
Style.FrameTyp := [];
Style.Color := Obj.Color;
Style.FrameWidth := Obj.Frame.Width;
Style.FrameColor := Obj.Frame.Color;
Style.FrameStyle := Obj.Frame.Style;
Style.FrameTyp := Obj.Frame.Typ;
end;
Result := AddStyleInternal(Style);
end;

function TfrxIEMatrix.AddStyleInternal(Style: TfrxIEMStyle): integer;
var
i: integer;
Style2: TfrxIEMStyle;
begin
Result := -1;
for i := 0 to FIEMStyleList.Count - 1 do
begin
Style2 := TfrxIEMStyle(FIEMStyleList);
if (Style.Font.Color = Style2.Font.Color) and
(Style.Font.Name = Style2.Font.Name) and
(Style.Font.Size = Style2.Font.Size) and
(Style.Font.Style = Style2.Font.Style) and
(Style.LineSpacing = Style2.LineSpacing) and
(Style.GapX = Style2.GapX) and
(Style.GapY = Style2.GapY) and
(Style.ParagraphGap = Style2.ParagraphGap) and
(Style.CharSpacing = Style2.CharSpacing) and
(Style.Charset = Style2.Charset) and
(Style.WordBreak = Style2.WordBreak) and
(Style.HAlign = Style2.HAlign) and
(Style.VAlign = Style2.VAlign) and
(Style.FrameTyp = Style2.FrameTyp) and
(Style.FrameWidth = Style2.FrameWidth) and
(Style.FrameColor = Style2.FrameColor) and
(Style.FrameStyle = Style2.FrameStyle) and
(Style.Rotation = Style2.Rotation) and
(Style.Color = Style2.Color) and
(Style.NumberFormat = Style2.NumberFormat)
then
begin
Result := i;
break;
end;
end;
if Result = -1 then
begin
FIEMStyleList.Add(Style);
Result := FIEMStyleList.Count - 1;
end else
Style.Free;
end;

изменения XLS экспорт
убрать vCellFormats
убрать procedure ApplyFormats(aRanges: TStringlist; aProgress: TfrxProgress);
убрать procedure ApplyFormat(const RangeCoord, aFormat: String);

****

procedure TfrxXLSExport.ExportPage_Fast;
var
i, fx, fy, x, y, dx, dy: Integer;
dcol, drow: Extended;
s: OLEVariant;
Vert, Horiz: Integer;
ExlArray: Variant;

obj: TfrxIEMObject;
EStyle: TfrxIEMStyle;
XStyle: Variant;
Pic: TPicture;
PicFormat: Word;
PicData: Cardinal;
PicPalette: HPALETTE;
PicCount: Integer;
PBreakCounter: Integer;
RowSizes: array of Currency;
RowSizesCount: array of Integer;
imc: Integer;
ArrData: PArrData;
j: Integer;
FixRow: String;
CurRowSize: Integer;
CurRangeCoord: String;
vRowsToSizes: TStrings;
vCellStyles: TStrings;
vCellFrames: TStrings;
vCellMerges: TStrings;
vs: string;
vers, err: integer;

procedure AlignFR2AlignExcel(HAlign: TfrxHAlign; VAlign: TfrxVAlign; var AlignH, AlignV: integer);
begin
if HAlign = haLeft then
AlignH := xlLeft
else if HAlign = haRight then
AlignH := xlRight
else if HAlign = haCenter then
AlignH := xlCenter
else if HAlign = haBlock then
AlignH := xlJustify
else
AlignH := xlLeft;

if VAlign = vaTop then
AlignV := xlTop
else if VAlign = vaBottom then
AlignV := xlBottom
else if VAlign = vaCenter then
AlignV := xlCenter
else
AlignV := xlTop;
end;

function RoundSizeY(const Value: Extended; xlSizeYRound: Currency): Currency;
begin
Result := Round(Value / xlSizeYRound) * xlSizeYRound
end;

function GetSizeIndex(const aSize: Currency): integer;
var
i: integer;
c: integer;
begin
c := Length(RowSizes);
for i := 0 to c - 1 do
begin
if RowSizes = aSize then
begin
Result := i;
RowSizesCount := RowSizesCount + 1;
Exit
end;
end;
SetLength(RowSizes, c + 1);
SetLength(RowSizesCount,c + 1);
RowSizes[c] := aSize;
RowSizesCount[c] := 1;
Result := c
end;

begin
PicCount := 0;
FExcel.SetPageMargin(FPageLeft, FPageRight, FPageTop, FPageBottom, FPageOrientation);

if ShowProgress then
begin
FProgress := TfrxProgress.Create(self);
FProgress.Execute(FMatrix.Height - 1, frxResources.Get('ProgressRows') + ' - 1', True, True);
end;

PBreakCounter := 0;

FixRow := 'A1';
CurRowSize := 0;
vRowsToSizes := TStringList.Create;
try
vRowsToSizes.Capacity := FMatrix.Height;
imc := 0;
for y := 1 to FMatrix.Height - 1 do
begin
if ShowProgress then
begin
if FProgress.Terminated then
break;
FProgress.Tick;
end;

if (FMatrix.GetCellYPos(y) >= FMatrix.GetPageBreak(PBreakCounter)) and FpageBreaks then
begin
FExcel.WorkSheet.Rows[y + 2].PageBreak := xlPageBreakManual;
Inc(PBreakCounter);
end;

drow := (FMatrix.GetYPosById(y) - FMatrix.GetYPosById(y - 1)) / Ydivider;
j := GetSizeIndex(RoundSizeY(drow, xlSizeYRound));
if RowSizesCount[j] > RowSizesCount[imc] then
imc := j;
if y > 1 then
begin
if j <> CurRowSize then
begin
if FixRow <> 'A' + IntToStr(y - 1) then
CurRangeCoord := FixRow + ':A' + IntToStr(y - 1)
else
CurRangeCoord := FixRow;
i := GetNewIndex(vRowsToSizes, CurRowSize);
vRowsToSizes.InsertObject(i, CurRangeCoord, TObject(CurRowSize));
FixRow := 'A' + IntToStr(y);
CurRowSize := j;
end;
end;
if y = FMatrix.Height - 1 then
begin
CurRangeCoord := FixRow + ':A' + IntToStr(y);
i := GetNewIndex(vRowsToSizes, j);
vRowsToSizes.InsertObject(i, CurRangeCoord, TObject(j));
end;
end;
FExcel.SetRowsSize(vRowsToSizes, RowSizes, imc, FMatrix.Height, FProgress)
finally
vRowsToSizes.Free;
end;

if ShowProgress then
if not FProgress.Terminated then
FProgress.Execute(FMatrix.Width - 1, frxResources.Get('ProgressColumns'), True, True);

for x := 1 to FMatrix.Width - 1 do
begin
if ShowProgress then
begin
if FProgress.Terminated then
break;
FProgress.Tick;
end;
dcol := (FMatrix.GetXPosById(x) - FMatrix.GetXPosById(x - 1)) / Xdivider;
FExcel.SetColSize(x, dcol);
end;

if ShowProgress then
if not FProgress.Terminated then
FProgress.Execute(FMatrix.StylesCount - 1, frxResources.Get('ProgressStyles'), True, True);

for x := 0 to FMatrix.StylesCount - 1 do
begin
if ShowProgress then
begin
if FProgress.Terminated then break;
FProgress.Tick;
end;
EStyle := FMatrix.GetStyleById(x);
s := 'S' + IntToStr(x);
XStyle := FExcel.Excel.ActiveWorkbook.Styles.Add(s);
XStyle.Font.Bold := fsBold in EStyle.Font.Style;
XStyle.Font.Italic := fsItalic in EStyle.Font.Style;
XStyle.Font.Underline := fsUnderline in EStyle.Font.Style;;
XStyle.Font.Name := EStyle.Font.Name;
XStyle.Font.Size := EStyle.Font.Size;
XStyle.Font.Color:= EStyle.Font.Color;
XStyle.Interior.Color := EStyle.Color;
if (EStyle.Rotation > 0) and (EStyle.Rotation <= 90) then
XStyle.Orientation := EStyle.Rotation
else
if (EStyle.Rotation < 360) and (EStyle.Rotation >= 270) then
XStyle.Orientation := EStyle.Rotation - 360;

AlignFR2AlignExcel(EStyle.HAlign, EStyle.VAlign, Horiz, Vert);
XStyle.VerticalAlignment := Vert;
XStyle.HorizontalAlignment := Horiz;
{!!!!!!!}
XStyle.NumberFormat := EStyle.NumberFormat;
{!!!!!!!}
Application.ProcessMessages;
end;
ExlArray := VarArrayCreate([1, FMatrix.Height , 1, FMatrix.Width ], varVariant);
if ShowProgress then
if not FProgress.Terminated then
FProgress.Execute(FMatrix.Height, frxResources.Get('ProgressObjects'), True, True);
ArrData := VarArrayLock(ExlArray) ;
vCellStyles := TStringList.Create;
vCellFrames := TStringList.Create;
vCellMerges := TStringList.Create;
try
for y := 1 to FMatrix.Height do
begin
if ShowProgress then
begin
if FProgress.Terminated then
Break;
FProgress.Tick;
end;
for x := 1 to FMatrix.Width do
begin
i := FMatrix.GetCell(x - 1, y - 1);
if i <> -1 then
begin
Obj := FMatrix.GetObjectById(i);
if Obj.Counter = 0 then
begin
Obj.Counter := 1;
FMatrix.GetObjectPos(i, fx, fy, dx, dy);
with FExcel do
if (dx > 1) or (dy > 1) then
CurRangeCoord := IntToCoord(x, y)+ ':' +
IntToCoord(x + dx - 1, y + dy - 1)
else
CurRangeCoord := IntToCoord(x, y);
if FExportStyles then
begin
j := GetNewIndex(vCellStyles, Obj.StyleIndex);
vCellStyles.InsertObject(j, CurRangeCoord, TObject(Obj.StyleIndex));
end;

if FMergeCells then
if (dx > 1) or (dy > 1) then
vCellMerges.Add(CurRangeCoord);
if FExportStyles then
begin
i := FrameTypesToByte(obj.Style.FrameTyp);
if i <> 0 then
begin
j := GetNewIndex(vCellFrames, i);
vCellFrames.InsertObject(j, CurRangeCoord, TObject(i));
end;
end;

s := CleanReturns(Obj.Memo.Text);
if Length(s) > XLMaxChars then
s := Copy(s, 1, XLMaxChars);
if not FAsText then
if (Obj.DisplayFormat.Kind=fkNumeric) then
begin
if length(s) > 0 then
begin
s := StringReplace(s, ThousandSeparator, '', [rfReplaceAll]);
s := StringReplace(s, 'р.', '', [rfReplaceAll]);
s := StringReplace(s, ',', ',', [rfReplaceAll]);
s := Trim(s);
vs := FExcel.Excel.Version;
val(vs, vers, err);
if vers > 10 then
s := StringReplace(s, ',', '.', [rfReplaceAll]);
end
end
else
if (Obj.DisplayFormat.Kind=fkText) then
s := '''' + s;

if FAsText then
s := '''' + s;
ArrData^[y + FMatrix.Height * (x - 1)] := s;
if not Obj.IsText then
begin
FExcel.SetRange(x, y, dx, dy);
Inc(PicCount);
Pic := TPicture.Create;
Pic.Bitmap.Assign(Obj.Image);
Pic.SaveToClipboardFormat(PicFormat, PicData, PicPalette);
Clipboard.SetAsHandle(PicFormat,THandle(PicData));
FExcel.Range.PasteSpecial(EmptyParam, EmptyParam, EmptyParam, EmptyParam);
FExcel.WorkSheet.Pictures[PicCount].Left := FExcel.WorkSheet.Pictures[PicCount].Left + 1;
FExcel.WorkSheet.Pictures[PicCount].Top := FExcel.WorkSheet.Pictures[PicCount].Top + 1;
FExcel.WorkSheet.Pictures[PicCount].Width := Pic.Width / 1.38;
FExcel.WorkSheet.Pictures[PicCount].Height := Pic.Height/ 1.38;
Pic.Free;
end;
end;
end;
end;
end;

if FExportStyles then
begin
FExcel.ApplyStyles(vCellStyles, 0, FProgress);
FExcel.ApplyStyles(vCellFrames, 1, FProgress);
end;
if FMergeCells then
FExcel.ApplyStyles(vCellMerges, 2, FProgress);
finally
VarArrayUnlock(ExlArray);
vCellStyles.Free;
vCellFrames.Free;
vCellMerges.Free;
end;
FExcel.SetRange(1, 1, FMatrix.Width , FMatrix.Height);
FExcel.Range.Value := ExlArray;
FExcel.WorkSheet.Cells.WrapText := True;
if ShowProgress then
FProgress.Free;
end;
******

XML экспорт

*************

procedure TfrxXMLExport.ExportPage(Stream: TStream);
var
i, x, y, dx, dy, fx, fy, Page: Integer;
dcol, drow: Extended;
s, sb, si, su: String;
Vert, Horiz: String;
obj: TfrxIEMObject;
EStyle: TfrxIEMStyle;
St: String;
PageBreak: TStringList;

function IsDigits(const Str: String): Boolean;
var
i: Integer;
begin
Result := True;
for i := 1 to Length(Str) do
if not((AnsiChar(Str) in ) or (Ord(Str) = 160)) then
begin
Result := False;
break;
end;
end;

procedure WriteExpLn(const str: String);
begin
if Length(str) > 0 then
Stream.Write(str[1], Length(str));
Stream.Write(#13#10, 2);
end;

procedure AlignFR2AlignExcel(HAlign: TfrxHAlign; VAlign: TfrxVAlign;
var AlignH, AlignV: String);
begin
if HAlign = haLeft then
AlignH := 'Left'
else if HAlign = haRight then
AlignH := 'Right'
else if HAlign = haCenter then
AlignH := 'Center'
else if HAlign = haBlock then
AlignH := 'Justify'
else
AlignH := '';
if VAlign = vaTop then
AlignV := 'Top'
else if VAlign = vaBottom then
AlignV := 'Bottom'
else if VAlign = vaCenter then
AlignV := 'Center'
else
AlignV := '';
end;

begin
PageBreak := TStringList.Create;
try
if FShowProgress then
begin
FProgress := TfrxProgress.Create(nil);
FProgress.Execute(FMatrix.PagesCount, 'Exporting pages', True, True);
end;
WriteExpLn('<?xml version="1.0"?>');
WriteExpLn('<?mso-application progid="Excel.Sheet"?>');
WriteExpLn('<?fr-application created="' + UTF8Encode(FCreator) + '"?>');
WriteExpLn('<?fr-application homesite="http://www.fast-report.com"?>');
WriteExpLn('<Workbook xmlns="urn:schemas-microsoft-com:office:spreadsheet"');
WriteExpLn(' xmlns:o="urn:schemas-microsoft-com:office:office"');
WriteExpLn(' xmlns:x="urn:schemas-microsoft-com:office:excel"');
WriteExpLn(' xmlns:ss="urn:schemas-microsoft-com:office:spreadsheet"');
WriteExpLn(' xmlns:html="http://www.w3.org/TR/REC-html40">');
WriteExpLn('<DocumentProperties xmlns="urn:schemas-microsoft-com:office:office">');
WriteExpLn('<Title>' + UTF8Encode(Report.ReportOptions.Name) + '</Title>');
WriteExpLn('<Author>' + UTF8Encode(Report.ReportOptions.Author) + '</Author>');
WriteExpLn('<Created>' + DateToStr(Date) + 'T' + TimeToStr(Time) + 'Z</Created>');
WriteExpLn('<Version>' + UTF8Encode(Report.ReportOptions.VersionMajor) + '.' +
UTF8Encode(Report.ReportOptions.VersionMinor) + '.' +
UTF8Encode(Report.ReportOptions.VersionRelease) + '.' +
UTF8Encode(Report.ReportOptions.VersionBuild) + '</Version>');
WriteExpLn('</DocumentProperties>');
WriteExpLn('<ExcelWorkbook xmlns="urn:schemas-microsoft-com:office:excel">');
WriteExpLn('<ProtectStructure>False</ProtectStructure>');
WriteExpLn('<ProtectWindows>False</ProtectWindows>');
WriteExpLn('</ExcelWorkbook>');

if FExportStyles then
begin
WriteExpLn('<Styles>');
for x := 0 to FMatrix.StylesCount - 1 do
begin
EStyle := FMatrix.GetStyleById(x);
s := 's' + IntToStr(x);
WriteExpLn('<Style ss:ID="'+s+'">');
if fsBold in EStyle.Font.Style then
sb := ' ss:Bold="1"'
else
sb := '';
if fsItalic in EStyle.Font.Style then
si := ' ss:Italic="1"'
else
si := '';
if fsUnderline in EStyle.Font.Style then
su := ' ss:Underline="Single"'
else
su := '';
WriteExpLn('<Font '+
'ss:FontName="' + EStyle.Font.Name + '" '+
'ss:Size="' + IntToStr(EStyle.Font.Size) + '" ' +
'ss:Color="' + HTMLRGBColor(EStyle.Font.Color) + '"' + sb + si + su + '/>');
WriteExpLn('<Interior ss:Color="' + HTMLRGBColor(EStyle.Color) +
'" ss:Pattern="Solid"/>');
AlignFR2AlignExcel(EStyle.HAlign, EStyle.VAlign, Horiz, Vert);
if (EStyle.Rotation > 0) and (EStyle.Rotation <= 90) then
s := 'ss:Rotate="' + IntToStr(EStyle.Rotation) + '"'
else if (EStyle.Rotation < 360) and (EStyle.Rotation >= 270) then
s := 'ss:Rotate="' + IntToStr(EStyle.Rotation - 360) + '"'
else
s := '';
si := '" ss:WrapText="1" ';
WriteExpLn('<Alignment ss:Horizontal="' + Horiz + '" ss:Vertical="' + Vert + si + s +'/>');

WriteExpLn('<Borders>');
if EStyle.FrameWidth > 1 then
i := 3
else
i := 1;
s := 'ss:Weight="' + IntToStr(i) + '" ';
si := 'ss:Color="' + HTMLRGBColor(EStyle.FrameColor) + '" ';
if (ftLeft in EStyle.FrameTyp) then
WriteExpLn('<Border ss:Position="Left" ss:LineStyle="Continuous" ' + s + si + '/>');
if (ftRight in EStyle.FrameTyp) then
WriteExpLn('<Border ss:Position="Right" ss:LineStyle="Continuous" ' + s + si + '/>');
if (ftTop in EStyle.FrameTyp) then
WriteExpLn('<Border ss:Position="Top" ss:LineStyle="Continuous" ' + s + si + '/>');
if (ftBottom in EStyle.FrameTyp) then
WriteExpLn('<Border ss:Position="Bottom" ss:LineStyle="Continuous" ' + s + si + '/>');
WriteExpLn('</Borders>');

{!!!!!!!!}
s := StringReplace(eStyle.NumberFormat, ',', '.', [rfReplaceAll]);
s := StringReplace(s, ' ', ',', [rfReplaceAll]);
s := StringReplace(s, '"р"', '"р."', [rfReplaceAll]);
WriteExpLn('<NumberFormat ss:Format="'+UTF8Encode(s)+'"/>');
{!!!!!!!!}

WriteExpLn('</Style>');
end;
WriteExpLn('</Styles>');
end;

s := 'Page 1';
WriteExpLn('<Worksheet ss:Name="' + UTF8Encode(s) + '">');
WriteExpLn('<Table ss:ExpandedColumnCount="' + IntToStr(FMatrix.Width) + '"' +
' ss:ExpandedRowCount="' + IntToStr(FMatrix.Height) + '" x:FullColumns="1" x:FullRows="1">');
for x := 1 to FMatrix.Width - 1 do
begin
dcol := (FMatrix.GetXPosById(x) - FMatrix.GetXPosById(x - 1)) / Xdivider;
WriteExpLn('<Column ss:AutoFitWidth="0" ss:Width="' +
frFloat2Str(dcol, 2) + '"/>');
end;
st := '';
Page := 0;

for y := 0 to FMatrix.Height - 2 do
begin
drow := (FMatrix.GetYPosById(y + 1) - FMatrix.GetYPosById(y)) / Ydivider;
WriteExpLn('<Row ss:Height="' + frFloat2Str(drow, 2) + '">');
if FMatrix.PagesCount > Page then
if FMatrix.GetYPosById(y) >= FMatrix.GetPageBreak(Page) then
begin
Inc(Page);
PageBreak.Add(IntToStr(y + 1));
if FShowProgress then
begin
FProgress.Tick;
if FProgress.Terminated then
break;
end;
end;
for x := 0 to FMatrix.Width - 1 do
begin
if FShowProgress then
if FProgress.Terminated then
break;
si := ' ss:Index="' + IntToStr(x + 1) + '" ';
i := FMatrix.GetCell(x, y);
if (i <> -1) then
begin
Obj := FMatrix.GetObjectById(i);
if Obj.Counter = 0 then
begin
FMatrix.GetObjectPos(i, fx, fy, dx, dy);
Obj.Counter := 1;
if Obj.IsText then
begin
if dx > 1 then
begin
s := 'ss:MergeAcross="' + IntToStr(dx - 1) + '" ';
Inc(dx);
end
else
s := '';
if dy > 1 then
sb := 'ss:MergeDown="' + IntToStr(dy - 1) + '" '
else
sb := '';
if FExportStyles then
st := 'ss:StyleID="' + 's' + IntToStr(Obj.StyleIndex) + '" '
else
st := '';
WriteExpLn('<Cell' + si + s + sb + st + '>');

s := TruncReturns(Obj.Memo.Text);
if (Obj.DisplayFormat.Kind = fkNumeric) and IsDigits(s) then
begin
s := StringReplace(s, ThousandSeparator, '', [rfReplaceAll]);
s := StringReplace(s, 'р.', '', [rfReplaceAll]);
s := StringReplace(s, ',', '.', [rfReplaceAll]);
s := Trim(s);
si := ' ss:Type="Number"';
WriteExpLn('<Data' + si + '>' + UTF8Encode(s) + '</Data>');
end
else
begin
si := ' ss:Type="String"';
s := ChangeReturns(s);
WriteExpLn('<Data' + si + '>' + UTF8Encode(s) + '</Data>');
end;

WriteExpLn('</Cell>');
end;
end
end
else
WriteExpLn('<Cell' + si + '/>');
end;
WriteExpLn('</Row>');
end;

WriteExpLn('</Table>');
WriteExpLn('<WorksheetOptions xmlns="urn:schemas-microsoft-com:office:excel">');
WriteExpLn('<PageSetup>');
if FPageOrientation = poLandscape then
WriteExpLn('<Layout x:Orientation="Landscape"/>');
WriteExpLn('<PageMargins x:Bottom="' + frFloat2Str(FPageBottom / MargDiv, 2) +
'" x:Left="' + frFloat2Str(FPageLeft / MargDiv, 2) +
'" x:Right="' + frFloat2Str(FPageRight / MargDiv, 2) +
'" x:Top="' + frFloat2Str(FPageTop / MargDiv, 2) + '"/>');
WriteExpLn('</PageSetup>');
WriteExpLn('</WorksheetOptions>');

if FExportPageBreaks then
begin
WriteExpLn('<PageBreaks xmlns="urn:schemas-microsoft-com:office:excel">');
WriteExpLn('<RowBreaks>');
for i := 0 to FMatrix.PagesCount - 2 do
begin
WriteExpLn('<RowBreak>');
WriteExpLn('<Row>' + PageBreak + '</Row>');
WriteExpLn('</RowBreak>');
end;
WriteExpLn('</RowBreaks>');
WriteExpLn('</PageBreaks>');
end;
WriteExpLn('</Worksheet>');
WriteExpLn('</Workbook>');
finally
PageBreak.Free;
end;
if FShowProgress then
FProgress.Free;
end;

************

Майк · June 2006

А ограничение в 65536 строк не преодолел случайно?
Это когда в отчете строк больше, то экспорт затыкается.

Bali · June 2006

Нет, у меня пользователи большие отчеты в Excel не экспортируют, хотя
проблема решаема.

Опять возвращаюсь к экспорту,
NumberFormat нужно формировать в frxExportMatrix, а не в frxExportXML,
и frxExportXLS. В этом случае в XML экспорте сохраняются все форматы ячеек,
и ускоряется экспорт в XLS.
Большая просьба к разработчикам включить изменения в следующий релиз.
В архиве файлы с учетом изменений 03.22.12.

Майк · June 2006

Bali написал:

Нет, у меня пользователи большие отчеты в Excel не экспортируют, хотя
проблема решаема.
.........

понятно что решаемая.....
просто разработчики пока не хотят видимо ее решать, а самому не хочется вот как ты, с каждым релизом просить вставить изменения и отслеживать что изменилось....

pasko · June 2006

Я бы еще предложил добавить возможность экспорта каждого листа на отдельный Sheet. Смотрите, мне помогает

Bali · August 2006

3.23.10 проблемы с форматами в Excel остались ( при разделении тысяч не воспринимается Ecxel как число)

в архиве изменения для 3.23.10

Экспорт в Excel (XLS)

Комментарии

Оставить комментарий