cxhtmlxmltxtexport.pas

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

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellStyle(const ACol, ARow, AStyleIndex: Integer);
begin
  TestIndex(ACol, ARow);
  TestStyleIndex(AStyleIndex);

  FCache[ACol, ARow].StyleIndex := AStyleIndex;
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellStyle(const ACol, ARow, AExampleCol,
  AExampleRow: Integer);
begin
  TestIndex(ACol, ARow);
  TestIndex(AExampleCol, AExampleRow);

  FCache[ACol, ARow].StyleIndex := FCache[AExampleCol, AExampleRow].StyleIndex;
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellStyle(const ACol, ARow: Integer;
  const AStyle: TcxCacheCellStyle);
begin
  TestIndex(ACol, ARow);

  FCache[ACol, ARow].StyleIndex := RegisterStyle(AStyle);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellStyleEx(
  const ACol, ARow, H, W: Integer; const AStyleIndex: Integer);
begin
  SetCellStyle(ACol, ARow, AStyleIndex);
  SetCellUnion(ACol, ARow, H, W);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellUnion(const ACol, ARow: Integer;
  H, W: Integer);
var
  I, J: Integer;
begin
  TestIndex(ACol, ARow);
  W := Min(W, Length(FCache) - ACol);
  if W < 1 then
    W := 1;
  H := Min(H, Length(FCache[ACol]) - ARow);
  if H < 1 then
    H := 1;
  with FCache[ACol, ARow] do
  begin
    IsUnion := True;
    Height := H;
    Width := W;
    for I := ACol to ACol + Width - 1 do
      for J := ARow to ARow + Height - 1 do
        FCache[I, J].IsHidden := not ((I = ACol) and (J = ARow));
  end;
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellValue(const ACol,
  ARow: Integer; const AValue: Variant);
var
{$IFDEF DELPHI6}
  {$IFNDEF NONDB}
  ACurr: Currency;
  {$ENDIF}
{$ENDIF}
  AText: string;
begin
  if VarIsNull(AValue) then
    AText := ''
  else
    if TVarData(AValue).VType = varCurrency then
      AText := FormatFloat(cxExportCurrencyFormat, Currency(AValue))
    else
{$IFDEF DELPHI6}
  {$IFNDEF NONDB}
    if TVarData(AValue).VType = VarSQLTimeStamp then
      AText := DateTimeToStr(AValue)
    else
      if TVarData(AValue).VType = VarFMTBcd then
      begin
        if BcdToCurr(VarToBcd(AValue), ACurr) then
          AText := FormatFloat(cxExportCurrencyFormat, ACurr)
        else
          AText := FloatToStr(Double(BcdToDouble(VarToBcd(AValue))));
      end
      else
  {$ENDIF}
{$ENDIF}
  AText := AValue;
  SetCellDataString(ACol, ARow, AText);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetColumnWidth(const ACol, AWidth: Integer);
begin
  TestCol(ACol);
  if AWidth < 0 then
    raise EcxExportData.Create(cxGetResString(@scxIllegalWidth));
  FColumns[ACol] := Abs(AWidth);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetDefaultStyle(const AStyle: TcxCacheCellStyle);
begin
  FDefaultStyle := AStyle;
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetData(const ACol, ARow, ADataSize,
    ADataType: Integer; const AData);
begin
  TestIndex(ACol, ARow);

  with FCache[ACol, ARow] do
  begin
    ReallocMem(Data, ADataSize);
    Move(AData, Data^, ADataSize);
    DataSize := ADataSize;
    DataType := ADataType;
  end;
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetEmptyData(const ACol, ARow, ADataType: Integer);
begin
  TestIndex(ACol, ARow);

  with FCache[ACol, ARow] do
  begin
    ReallocMem(Data, 0);
    Data := nil;
    DataSize := 0;
    DataType := ADataType;
  end;
end;

procedure TcxCustomHtmlXmlTXTExportProvider.Commit;
begin
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetRange(const AColCount, ARowCount: Integer;
    IsVisible: Boolean);
var
  I, J, K: Integer;
  ABorderWidth: Integer;
begin
  if (AColCount <= 0) or (ARowCount <= 0) then
    raise EcxExportData.Create(cxGetResString(@scxInvalidColumnRowCount));

  SetLength(FCache, AColCount, ARowCount);
  SetLength(FColumns, AColCount);
  SetLength(FRows, ARowCount);
  for I := 0 to ColCount - 1 do
  begin
    FColumns[I] := 0;
    for J := 0 to RowCount - 1 do
    begin
      with FCache[I, J] do
      begin
        IsHidden := False;
        IsUnion := False;
        Height := 1;
        Width := 1;
        Data := nil;
        InternalCache.Cache := nil;
        InternalCache.Index := -1;
        SetCellStyle(I, J, -1);
      end;
    end;
  end;
  if IsVisible then
    ABorderWidth := 1
  else
    ABorderWidth := 0;
  for K := 0 to 3 do
    FDefaultStyle.Borders[K].Width := ABorderWidth;
  for I := 0 to RowCount - 1 do
    FRows[I] := 0;
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetRowHeight(const ARow, AHeight: Integer);
begin
  TestRow(ARow);
  if AHeight < 0 then
    raise EcxExportData.Create(cxGetResString(@scxIllegalHeight));

  FRows[ARow] := AHeight;
end;

procedure TcxCustomHtmlXmlTXTExportProvider.SetCellDataGraphic(
  const ACol, ARow: Integer; var AGraphic: TGraphic);
var
  AGraphicText: string;
begin
  GetGraphicAsText(cxUnicodeToStr(FileName), AGraphic, AGraphicText);
  SetData(ACol, ARow, Length(AGraphicText), cxDataTypeGraphic, AGraphicText[1]);
end;

function TcxCustomHtmlXmlTXTExportProvider.SupportGraphic: Boolean;
begin
  Result := True;
end;

function TcxCustomHtmlXmlTXTExportProvider.GetCacheItem(ACol, ARow: Integer): TcxCacheItem;
begin
  TestIndex(ACol, ARow);

  Result := FCache[ACol, ARow];
end;

function TcxCustomHtmlXmlTXTExportProvider.GetCellHeight(ACol, ARow: Integer): Integer;
var
  I: Integer;
begin
  TestIndex(ACol, ARow);

  if FCache[ACol, ARow].IsUnion then
  begin
    Result := 0;
    for I := 0 to FCache[ACol, ARow].Height - 1 do
      Inc(Result, Rows[ARow + I]);
  end
  else
    Result := Rows[ARow];
end;

function TcxCustomHtmlXmlTXTExportProvider.GetCellWidth(ACol, ARow: Integer): Integer;
var
  I: Integer;
begin
  TestIndex(ACol, ARow);

  if FCache[ACol, ARow].IsUnion then
  begin
    Result := 0;
    for I := 0 to FCache[ACol, ARow].Width - 1 do
      Inc(Result, Columns[ACol + I]);
  end
  else
    Result := Columns[ACol];
end;

function TcxCustomHtmlXmlTXTExportProvider.GetColumns(ACol: Integer): Integer;
begin
  TestCol(ACol);

  Result := FColumns[ACol];
end;

function TcxCustomHtmlXmlTXTExportProvider.GetDefaultStyle: PcxCacheCellStyle;
begin
  Result := @FDefaultStyle;
end;

function TcxCustomHtmlXmlTXTExportProvider.GetHeight: Integer;
begin
  Result := Length(FRows);
end;

function TcxCustomHtmlXmlTXTExportProvider.GetInternalCacheCount: Integer;
begin
  Result := FInternalCacheList.Count;
end;

function TcxCustomHtmlXmlTXTExportProvider.GetInternalCacheItems(
  AIndex: Integer): IcxCellInternalCache;
begin
  Result := FInternalCacheList[AIndex] as IcxCellInternalCache;
end;

function TcxCustomHtmlXmlTXTExportProvider.GetRows(ARow: Integer): Integer;
begin
  TestRow(ARow);

  Result := FRows[ARow];
end;

function TcxCustomHtmlXmlTXTExportProvider.GetStyle(AStyleIndex: Integer): PcxCacheCellStyle;
begin
  TestStyleIndex(AStyleIndex);
  if AStyleIndex < 0 then
    Result := @FDefaultStyle
  else
    Result := FStyleManager.GetStyle(AStyleIndex);
end;

function TcxCustomHtmlXmlTXTExportProvider.GetWidth: Integer;
begin
  Result := Length(FColumns);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.TestIndex(ACol, ARow: Integer);
begin
  TestCol(ACol);
  TestRow(ARow);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.TestCol(ACol: Integer);
begin
  if (ACol < 0) or (ACol >= Length(FCache)) then
    raise EcxExportData.CreateFmt(cxGetResString(@scxInvalidColumnIndex), [ACol]);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.TestRow(ARow: Integer);
begin
  if (ARow < 0) or (ARow >= Length(FCache[0])) then
    raise EcxExportData.CreateFmt(cxGetResString(@scxInvalidRowIndex), [ARow]);
end;

procedure TcxCustomHtmlXmlTXTExportProvider.TestStyleIndex(AStyleIndex: Integer);
begin
  if AStyleIndex >= FStyleManager.Count then
    raise EcxExportData.CreateFmt(cxGetResString(@scxInvalidStyleIndex), [AStyleIndex]);
end;

function TcxCustomHtmlXmlTXTExportProvider.GetStyleCount: Integer;
begin
  Result := FStyleManager.Count;
end;

{ TcxCustomExportProviderSupportedCellInternalChache }

procedure TcxCustomExportProviderSupportedCellInternalChache.CommitCache(
  AStream: TStream; AParam: Pointer);
begin
  SetEmptyCellsStyle;
end;

procedure TcxCustomExportProviderSupportedCellInternalChache.CommitStyle(
  AStream: TStream; AParam: Pointer);
begin
end;

procedure TcxCustomExportProviderSupportedCellInternalChache.DeleteCacheFromCell(
  const ACol, ARow: Integer);
begin
  SetCacheIntoCell(ACol, ARow, nil);
end;

procedure TcxCustomExportProviderSupportedCellInternalChache.SetCacheIntoCell(
  const ACol, ARow: Integer; ACache: IcxCellInternalCache);
begin
  TestIndex(ACol, ARow);
  if ACache <> nil then
  begin
    if FCache[ACol, ARow].InternalCache.Cache <> nil then
      SetCacheIntoCell(ACol, ARow, nil);
    FCache[ACol, ARow].InternalCache.Cache := ACache;
    FCache[ACol, ARow].InternalCache.Index := FInternalCacheList.Add(ACache);
  end
  else
  begin
    if FCache[ACol, ARow].InternalCache.Cache <> nil then
    begin
      FCache[ACol, ARow].InternalCache.Cache := nil;
      FInternalCacheList.Delete(FCache[ACol, ARow].InternalCache.Index);
      FCache[ACol, ARow].InternalCache.Index := -1;
    end;
  end;
end;

procedure TcxCustomExportProviderSupportedCellInternalChache.SetEmptyCellsStyle;
var
  I, J: Integer;
  ACell: TcxCacheItem;
  ANewStyle: TcxCacheCellStyle;
begin
  for I := 0 to RowCount - 1 do
    for J := 0 to ColCount - 1 do
    begin
      ACell := Cache[J, I];
      if not (ACell.DataType in [0,1]) or (ACell.DataSize <> 0) or (GetCellStyle(J, I) = nil) then Continue;
      begin
        ANewStyle := GetCellStyle(J, I)^;
        ANewStyle.FontSize := 1;
        SetCellStyle(J, I, ANewStyle);
      end;
    end;
end;

{ TcxHTMLExportProvider }
procedure TcxHTMLExportProvider.Commit;
var
  AStream: TFileStream;
begin
  AStream := cxFileStreamClass.Create(cxUnicodeToStr(FileName), fmCreate);
  try
    CommitHTML(AStream);
  finally
    AStream.Free;
  end;
end;

class function TcxHTMLExportProvider.ExportType: Integer;
begin
  Result := cxExportToHTML;
end;

class function TcxHTMLExportProvider.ExportName: string;
begin
  Result := cxGetResString(@scxExportToHTML);
end;

procedure TcxHTMLExportProvider.CommitCache(AStream: TStream; AParam: Pointer);
var
  ABuffer: string;
  ADisplayValue: string;
  AStringValue: string;
  AWideStringValue: WideString;
  ADoubleValue: Double;
  AIntegerValue: Integer;
  I, J: Integer;
  ACellStyle: PcxCacheCellStyle;
begin
  inherited CommitCache(AStream, AParam);
  ABuffer := ABuffer + Format('<TABLE BORDER=0 CELLSPACING=0 WIDTH=%d>'#13#10, [GetContentWidth]);
  ABuffer := ABuffer + GetScaleRow + #13#10;
  for I := 0 to RowCount - 1 do
  begin
    ABuffer := ABuffer + '<TR>'#13#10;
    for J := 0 to ColCount - 1 do
    begin
      ACellStyle := GetCellStyle(J, I);
      ADisplayValue := '';
      with Cache[J, I] do
      begin
        if IsHidden then
          Continue;

        if IsUnion then
        begin
          ABuffer := ABuffer + '<TD';
          if Width > 1 then
            ABuffer := ABuffer + ' COLSPAN=' + IntToStr(Width);
          if Height > 1 then
            ABuffer := ABuffer + ' ROWSPAN=' + IntToStr(Height);
        end
        else
          ABuffer := ABuffer + '<TD';
      end;
      ABuffer := ABuffer + ' NOWRAP';

      with ACellStyle^ do