cxhtmlxmltxtexport.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,750 行 · 第 1/4 页

  ABuffer := ABuffer + '<xsl:apply-templates select="IMAGE" />'#13#10;
  ABuffer := ABuffer + '</xsl:when>'#13#10;

  ABuffer := ABuffer + '<xsl:otherwise>'#13#10;
  ABuffer := ABuffer + '<xsl:value-of select="." />'#13#10;
  ABuffer := ABuffer + '</xsl:otherwise>'#13#10;
  ABuffer := ABuffer + '</xsl:choose>'#13#10;
  ABuffer := ABuffer + '</td>'#13#10;
  ABuffer := ABuffer + '</xsl:template>'#13#10#13#10;

  ABuffer := ABuffer + '<xsl:template match="IMAGE">'#13#10;
  ABuffer := ABuffer + '<img>'#13#10;
  ABuffer := ABuffer + '<xsl:attribute name="src"><xsl:value-of select="@Src" /></xsl:attribute>'#13#10;
  ABuffer := ABuffer + '</img>'#13#10;
  ABuffer := ABuffer + '</xsl:template>'#13#10#13#10;

  ABuffer := ABuffer + '</xsl:stylesheet>'#13#10;
  AStream.WriteBuffer(ABuffer[1], Length(ABuffer));
end;

function TcxXMLExportProvider.ConvertTextToXML(const AText: string; ACol, ARow: Integer): string;
var
  I: Integer;
  W: WideString;
begin
  Result := '';
  if not cxStrUnicodeNeeded(AText, True) then
    Result := AText
  else
  begin
    W := cxStrToUnicode(AText, GetCellStyle(ACol, ARow)^.FontCharset);
    for I := 1 to Length(W) do
      Result := Result + '&#' + IntToStr(Integer(W[I])) + ';';
  end;
end;

function TcxXMLExportProvider.GetBorderStyle(AStyle: TcxCacheCellStyle): string;

  function GetBorderStyle(AIndex: Integer): string;
  begin
    with AStyle.Borders[AIndex] do
    begin
      Result := '';
      if IsDefault then
        Result := Result + ' IsDefault="True"'
      else
        Result := Result + ' IsDefault="False"';
      Result := Result + ' Width="' + IntToStr(Width) + '"';
      Result := Result + ' Color="' + GetHTMLColor(Color) + '"';
    end;
  end;

begin
  Result := '<BORDER_LEFT' + GetBorderStyle(0) + '/>'#13#10;
  Result := Result + '<BORDER_UP' + GetBorderStyle(1) + '/>'#13#10;
  Result := Result + '<BORDER_RIGHT' + GetBorderStyle(2) + '/>'#13#10;
  Result := Result + '<BORDER_DOWN' + GetBorderStyle(3) + '/>'#13#10;
end;

function TcxXMLExportProvider.GetCellParams(ACol, ARow: Integer): string;
var
  ACellWidth: Integer;
  ACellStyle: PcxCacheCellStyle;
begin
  Result := '';

  with Cache[ACol, ARow] do
  begin
    ACellWidth := CellWidth[ACol, ARow];
    if ACellWidth > 0 then
      Result := Result + ' Width="' + IntToStr(ACellWidth) + '"';
    ACellStyle := GetCellStyle(ACol, ARow);
    Result := Result + ' Align="';
    case ACellStyle^.AlignText of
      catLeft:
        Result := Result + 'left"';
      catCenter:
        Result := Result + 'center"';
      catRight:
        Result := Result + 'right"';
    end;
    if IsUnion then
    begin
      if Width > 1 then
        Result := Result + ' ColSpan="' + IntToStr(Width) + '"';
      if Height > 1 then
        Result := Result + ' RowSpan="' + IntToStr(Height) + '"';
    end;
    Result := Result + ' StyleClass="' + IntToStr(StyleIndex) + '"';
  end;
end;

function TcxXMLExportProvider.GetData(ACol, ARow: Integer): string;
var
  AStringValue: string;
  AWideStringValue: WideString;
  ADoubleValue: Double;
  AIntegerValue: Integer;
begin
  if Cache[ACol, ARow].InternalCache.Cache <> nil then
    Result := ''
  else
  begin
    if Cache[ACol, ARow].DataType = cxDataTypeGraphic then
    begin
      Result := cxXMLEmptyChar;
    end
    else if Cache[ACol, ARow].DataType = cxDataTypeString then
    begin
      if Cache[ACol, ARow].DataSize > 0 then
      begin
        SetLength(AStringValue, Cache[ACol, ARow].DataSize);
        if GetCellData(ACol, ARow, AStringValue[1]) then
          Result := AStringValue
        else
          Result := cxXMLEmptyChar;
      end
      else
        Result := cxXMLEmptyChar;
    end
    else if Cache[ACol, ARow].DataType = cxDataTypeWideString then
    begin
      if Cache[ACol, ARow].DataSize > 0 then
      begin
        SetLength(AWideStringValue, Cache[ACol, ARow].DataSize shr 1);
        if GetCellData(ACol, ARow, AWideStringValue[1]) then
          Result := AWideStringValue
        else
          Result := cxXMLEmptyChar;
      end
      else
        Result := cxXMLEmptyChar;
    end
    else if Cache[ACol, ARow].DataType = cxDataTypeDouble then
    begin
      if GetCellData(ACol, ARow, ADoubleValue) then
        Result := FloatToStr(ADoubleValue)
      else
        Result := cxXMLEmptyChar;
    end
    else if Cache[ACol, ARow].DataType = cxDataTypeInteger then
    begin
      if GetCellData(ACol, ARow, AIntegerValue) then
        Result := IntToStr(AIntegerValue)
      else
        Result := cxXMLEmptyChar;
    end
    else
      Result := cxXMLEmptyChar;
  end;
end;

function TcxXMLExportProvider.GetStyle(AStyle: TcxCacheCellStyle): string;
  function GetAlignText(AAlign: TcxAlignText): string;
  begin
    case AAlign of
      catLeft:
        Result := 'Left';
      catCenter:
        Result := 'Center';
      catRight:
        Result := 'Right';
    end;
  end;

  function GetFontStyles(AStyles: TcxFontStyles): string;
  begin
    Result := '';

    if cfsBold in AStyles then
      Result := Result + ' Bold="True"'
    else
      Result := Result + ' Bold="False"';

    if cfsItalic in AStyles then
      Result := Result + ' Italic="True"'
    else
      Result := Result + ' Italic="False"';

    if cfsUnderline in AStyles then
      Result := Result + ' Underline="True"'
    else
      Result := Result + ' Underline="False"';

    if cfsStrikeOut in AStyles then
      Result := Result + ' StrikeOut="True"'
    else
      Result := Result + ' StrikeOut="False"';
  end;

  function GetBrushStyle(AStyle: TcxBrushStyle): string;
  begin
    case AStyle of
      cbsSolid:
        Result := 'Solid';
      cbsClear:
        Result := 'Clear';
    end;
  end;

begin
  with AStyle do
  begin
    Result := 'AlignText="' + GetAlignText(AlignText) + '"';
    if FontSize = 1 then
      Result := Result + ' CellPadding="0px"'
    else
      Result := Result + ' CellPadding=" 3"';
    Result := Result + ' FontName="' + CheckedUnicodeString(FontName, AStyle.FontCharset) + '"';
    Result := Result + ' FontCharset="' + IntToStr(FontCharset) + '"';
    Result := Result + GetFontStyles(FontStyle);
    Result := Result + ' FontColor="' + GetHTMLColor(FontColor) + '"';
    Result := Result + ' FontSize="' + IntToStr(FontSize) + '"';
    Result := Result + ' BrushStyle="' + GetBrushStyle(BrushStyle) + '"';
    Result := Result + ' BrushBkColor="' + GetHTMLColor(BrushBkColor) + '"';
    Result := Result + ' BrushFgColor="' + GetHTMLColor(BrushFgColor) + '"';
  end;
end;

procedure TcxXMLExportProvider.HideDots;
var
  I, J: Integer;
  AData: string;
  AStyle: TcxCacheCellStyle;
begin
  for J := 0 to RowCount - 1 do
  begin
    for I := 0 to ColCount - 1 do
    begin
      if Cache[I, J].InternalCache.Cache <> nil then
        Cache[I, J].InternalCache.Cache.CommitCache(nil, nil)
      else
      begin
        AData := GetData(I, J);
        if AData = cxXMLEmptyChar then
        begin
          AStyle := GetCellStyle(I, J)^;
          AStyle.FontColor := AStyle.BrushBkColor;
          SetCellStyle(I, J, AStyle);
        end;
      end;
    end;
  end;
end;

function TcxXMLExportProvider.GetScaleLine: string;
var
  J: Integer; 
begin
  Result :=  '<LINE>'#13#10;
  for J := 0 to ColCount - 1 do
  begin
    Result := Result + '<CELL Width="' + IntToStr(Columns[J]) + '"';
    Result := Result + ' Height="0"';
    Result := Result + '>'#13#10;
    Result := Result + '</CELL>'#13#10;
  end;
  Result := Result + '</LINE>'#13#10;
end;

{ TcxTXTExportProvider }

constructor TcxTXTExportProvider.Create(const AFileName: string);
begin
  inherited Create(AFileName);
  FSeparator := '';
  FBeginString := '';
  FEndString := '';
  FIndex := 0;
end;

procedure TcxTXTExportProvider.CommitCache(AStream: TStream; AParam: Pointer);
var
  I, J, K: Integer;
  ABuffer: string;
  ASpace: string;
  AData: string;
begin
  SetLength(FColMaxWidth, ColCount);

  CalculateColMaxWidth;
  for J := 0 to RowCount - 1 do
  begin
    ABuffer := '';
    for I := 0 to ColCount - 1 do
    begin
      AData := GetData(I, J);
      ASpace := '  ';
      for K := 1 to FColMaxWidth[I] - Length(AData) do
        ASpace := ASpace + ' ';
      if FSeparator <> '' then
        ASpace := '';
{      if AData = '' then
        ABuffer := ABuffer + ASpace
      else
      begin}
      if I < (ColCount - 1) then
        ABuffer := ABuffer + FBeginString + AData + FEndString + FSeparator + ASpace
      else
        ABuffer := ABuffer + FBeginString + AData + FEndString + ASpace;
//      end;
    end;
    ABuffer := ABuffer + #13#10;
    AStream.WriteBuffer(ABuffer[1], Length(ABuffer));
  end;

  SetLength(FColMaxWidth, 0);
end;

function TcxTXTExportProvider.SupportGraphic: Boolean;
begin
  Result := False; 
end;

procedure TcxTXTExportProvider.AddSeparator(const ASeparator: string);
begin
  case FIndex of
    0:
      FSeparator := ASeparator;
    1:
      FBeginString := ASeparator;
    2:
      FEndString := ASeparator;
  end;
  Inc(FIndex);
end;

class function TcxTXTExportProvider.ExportType: Integer;
begin
  Result := cxExportToText;
end;

class function TcxTXTExportProvider.ExportName: string;
begin
  Result := cxGetResString(@scxExportToText);
end;

procedure TcxTXTExportProvider.Commit;
var
  AStream: TFileStream;
begin
  AStream := cxFileStreamClass.Create(cxUnicodeToStr(FileName), fmCreate);
  try
    CommitCache(AStream, Pointer(0));
  finally
    AStream.Free;
  end;
end;

procedure TcxTXTExportProvider.CalculateColMaxWidth;
var
  I, J, K: Integer;
  AMaxWidth: Integer;
  ACurrentWidth: Integer;
begin
  for I := 0 to ColCount - 1 do
  begin
    AMaxWidth := 0;
    for J := 0 to RowCount - 1 do
      if Cache[I, J].IsUnion then
      begin
        ACurrentWidth := Length(GetData(I, J)) div Cache[I, J].Width;
        for K := 1 to Cache[I, J].Width - 1 do
          FColMaxWidth[I + K] := Max(FColMaxWidth[I + K], ACurrentWidth);
        AMaxWidth := Max(AMaxWidth, ACurrentWidth);
      end
      else
        AMaxWidth := Max(AMaxWidth, Length(GetData(I, J)));

    FColMaxWidth[I] := AMaxWidth;
  end;
end;

function TcxTXTExportProvider.GetData(ACol, ARow: Integer): string;
var
  AStringValue: string;
  AWideStringValue: WideString;
  ADoubleValue: Double;
  AIntegerValue: Integer;
begin
  if Cache[ACol, ARow].InternalCache.Cache <> nil then
    Result := ''
  else
  begin
    if Cache[ACol, ARow].DataType = cxDataTypeString then
    begin
      if Cache[ACol, ARow].DataSize > 0 then
      begin
        SetLength(AStringValue, Cache[ACol, ARow].DataSize);
        if GetCellData(ACol, ARow, AStringValue[1]) then
          Result := AStringValue
        else
          Result := '';
      end
      else
        Result := ''; 
    end
    else if Cache[ACol, ARow].DataType = cxDataTypeWideString then
    begin
      if Cache[ACol, ARow].DataSize > 0 then
      begin
        SetLength(AWideStringValue, Cache[ACol, ARow].DataSize shr 1);
        if GetCellData(ACol, ARow, AWideStringValue[1]) then
          Result := AWideStringValue
        else
          Result := '';
      end
      else
        Result := '';
    end
    else if Cache[ACol, ARow].DataType = cxDataTypeDouble then
    begin
      if GetCellData(ACol, ARow, ADoubleValue) then
        Result := FloatToStr(ADoubleValue)
      else
        Result := '';
    end
    else if Cache[ACol, ARow].DataType = cxDataTypeInteger then
    begin
      if GetCellData(ACol, ARow, AIntegerValue) then
        Result := IntToStr(AIntegerValue)
      else
        Result := '';
    end
    else
      Result := '';
  end;
end;

initialization
  TcxExport.RegisterProviderClass(TcxHTMLExportProvider);
  TcxExport.RegisterProviderClass(TcxTXTExportProvider);
  TcxExport.RegisterProviderClass(TcxXMLExportProvider);

end.