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

BaliBali
отредактировано 09:44 Раздел: FastReport 3.0
Уважаемые разработчики спасибо что добавли в экспорт в 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

Комментарии

  • aenemy1aenemy1
    отредактировано 09:44
    Спасибо за исправления, очень помогли
    особенно был ошарашен выводом чисел в эксел при формате %2.0n - все числа заканчиваются запятой ;)
  • BaliBali
    отредактировано 09:44
    В виде 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;


  • BaliBali
    отредактировано 09:44
    В текущей конфигурации в 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;

    ************
  • МайкМайк
    отредактировано 09:44
    А ограничение в 65536 строк не преодолел случайно?
    Это когда в отчете строк больше, то экспорт затыкается.
  • BaliBali
    отредактировано 09:44
    Нет, у меня пользователи большие отчеты в Excel не экспортируют, хотя
    проблема решаема.

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


  • МайкМайк
    отредактировано 09:44
    Bali написал:
    Нет, у меня пользователи большие отчеты в Excel не экспортируют, хотя
    проблема решаема.
    .........
    понятно что решаемая.....
    просто разработчики пока не хотят видимо ее решать, а самому не хочется вот как ты, с каждым релизом просить вставить изменения и отслеживать что изменилось.... ;)
  • paskopasko
    отредактировано 09:44
    Я бы еще предложил добавить возможность экспорта каждого листа на отдельный Sheet. Смотрите, мне помогает
  • BaliBali
    отредактировано 09:44
    3.23.10 проблемы с форматами в Excel остались ( при разделении тысяч не воспринимается Ecxel как число)

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

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

Многофункциональный текстовый редактор. Чтобы отредактировать стиль параграфа, нажмите TAB, чтобы перейти к меню абзаца. Там вы можете выбрать стиль. По умолчанию не выбран ни один стиль. Когда вы выберете текст, появится встроенное меню форматирования. Нажмите TAB, чтобы войти в него. Некоторые элементы, такие как многофункциональные вставки ссылок, картинок, индикаторов загрузки и сообщений об ошибок могут быть вставлены в редактор. Вы можете перемещаться по ним, используя стрелки внутри редактора и удалять с помощью клавиш delete или backspace.

Начало • FastReport 3.0Комментировать как ...

© Vanilla Keystone Theme 2024