qexport3rtf.pas

DELPHI开发VCL

var
  AlignStr, FontStr, ColorStr, AttrStr,
  BackgroundStr, HighlightStr, FormatStr: string;
  i: integer;
  Style: TrtfStyle;
  ColAlign: TQExportColAlign;
begin
  Result := inherited GetColCaption(Index);

  case FOptions.CaptionStyle.Alignment of
    talCenter: ColAlign := ecaCenter;
    talRight: ColAlign := ecaRight;
    else ColAlign := ecaLeft;
  end;
  if FOptions.CaptionAligns.Count > 0 then begin
    i := FOptions.CaptionAligns.IndexOfName(Columns[Index].Name);
    if (i > -1) and
       (Length(FOptions.CaptionAligns.Values[Columns[Index].Name]) > 0) then begin
      case AnsiUpperCase(FOptions.CaptionAligns.Values[Columns[Index].Name])[1] of
        'C': ColAlign := ecaCenter;
        'R': ColAlign := ecaRight;
        else ColAlign := ecaLeft;
      end;
    end;
  end;

  Style := TrtfStyle.Create(nil);
  try
    Style.Assign(FOptions.CaptionStyle);
    if Assigned(FOnGetCaptionStyle) then
      FOnGetCaptionStyle(Self, Index, Style);

    StyleToStrs(Style, AlignStr, FontStr, ColorStr, AttrStr,
      BackgroundStr, HighlightStr);
  finally
    Style.Free;
  end;

  AlignStr := GetWriter.AlignToStr(ColAlign);

  FormatStr := FontStr + ColorStr + AttrStr;
  if FormatStr <> EmptyStr then FormatStr := FormatStr + ' ';

  Result := '\pard\intbl\li30\ri30' + BackgroundStr + 
    AlignStr + '{' + HighlightStr + FormatStr + Result + '}\cell';
end;

procedure TQExport3RTF.WriteCaptionRow;
var
  FontStr: string;
begin
  GetWriter.SetFont(FOptions.CaptionStyle.Font, true, FontStr);
  GetWriter.WriteLn(GetCaptionRow + '\row');
end;

function TQExport3RTF.GetColData(ExportCol: TQExportCol): string;
var
  AlignStr, FontStr, ColorStr, AttrStr,
  BackgroundStr, HighLightStr, FormatStr: string;
  Style: TrtfStyle;
  Index, i: integer;
  ColAlign: TQExportColAlign;
begin
  Result := inherited GetColData(ExportCol);
  Index := ExportCol.ColumnIndex;

  Result := Replace(Result, #13#10, ' \par ');

  ColAlign := Columns[Index].ColAlign;

  Style := TrtfStyle.Create(nil);
  try
    if (FOptions.StripType <> stNone) and
       (FOptions.StripStyles.Count > 0) then begin
      if FOptions.StripType = stCol
        then i := Index mod FOptions.StripStyles.Count
        else i := RecordCounter mod FOptions.StripStyles.Count;
      Style.Assign(FOptions.StripStyles[i]);
    end
    else Style.Assign(FOptions.DataStyle);

    if Assigned(FOnGetDataStyle) then
      FOnGetDataStyle(Self, SkipRecCount + RecordCounter, Index, Style);

    StyleToStrs(Style, AlignStr, FontStr, ColorStr, AttrStr,
      BackgroundStr, HighlightStr);
  finally
    Style.Free;
  end;
  AlignStr := GetWriter.AlignToStr(ColAlign);

  FormatStr := FontStr + ColorStr + AttrStr;
  if FormatStr <> EmptyStr then FormatStr := FormatStr + ' ';

  Result := '\pard\intbl\li30\ri30' +  BackgroundStr + HighlightStr +
            AlignStr +'{' + FormatStr + Result + '}\cell';
end;

procedure TQExport3RTF.WriteDataRow;
begin
  GetWriter.WriteLn(GetDataRow(true) + '\row');
end;

procedure TQExport3RTF.EndExport;
var
  i: integer;
  Style: TrtfStyle;
  AlignStr, FontStr, ColorStr, AttrStr,
  BackgroundStr, HighlightStr, FormatStr: string;
begin
  with GetWriter do begin
    WriteLn('\pard');

    Style := TrtfStyle.Create(nil);
    try
      Style.Assign(FOptions.FooterStyle);
      if Assigned(FOnGetFooterStyle) then FOnGetFooterStyle(Self, Style);

      StyleToStrs(Style, AlignStr, FontStr, ColorStr, AttrStr,
        BackgroundStr, HighlightStr);
    finally
      Style.Free;
    end;

    if BackgroundStr <> EmptyStr then
      BackgroundStr := BackgroundStr + ' ';

    if Self.Footer.Count > 0 then begin
      WritePara;
      WriteLn('{' + AlignStr + BackgroundStr);
      try
        for i := 0 to Self.Footer.Count - 1 do begin
          FormatStr := FontStr + ColorStr + AttrStr;
          if FormatStr <> EmptyStr then
            FormatStr := FormatStr + ' ';
          WriteLn('{' + HighlightStr + FormatStr + Self.Footer[i] + '}');
          WritePara;
        end;
      finally
        WriteLn('}');
      end;
    end;
    WriteEOF;
  end;
  inherited;
end;

function TQExport3RTF.NormalString(const S: string): string;
var
  i: Integer;
begin
  Result := EmptyStr;
  for i := 1 to Length(S) do
    if S[i] = '\' then Result := Result + '\\'
    else Result := Result + S[i];
end;

function TQExport3RTF.GetWriter: TQRTFWriter;
begin
  Result := TQRTFWriter(inherited GetWriter);
end;

function TQExport3RTF.GetWriterClass: TQExportWriterClass;
begin
  Result := TQRTFWriter;
end;

procedure TQExport3RTF.StyleToStrs(Style: TrtfStyle; var AlignStr, FontStr,
  ColorStr, AttrStr, BackgroundStr, HighlightStr: string);
var
  Writer: TQRTFWriter;
begin
  case Style.Alignment of
    talRight: AlignStr := '\qr';
    talCenter: AlignStr := '\qc';
    talFill: AlignStr := '\qj';
    else AlignStr := '\ql';
  end;

  Writer := GetWriter;
  Writer.SetFont(Style.Font, false, FontStr);
  ColorStr := Writer.GetColorText(Style.Font.Color, ctText);
  AttrStr := EmptyStr;

  if fsBold in Style.Font.Style then
    AttrStr := AttrStr + '\b';
  if fsItalic in Style.Font.Style then
    AttrStr := AttrStr + '\i';
  if fsUnderline in Style.Font.Style then
    AttrStr := AttrStr + '\ul';
  if fsStrikeOut in Style.Font.Style then
    AttrStr := AttrStr + '\strike';

  if Style.AllowBackground then
    BackgroundStr := Writer.GetColorText(Style.BackgroundColor, ctBackground)
  else
    BackgroundStr := EmptyStr;
 
  if Style.AllowHighlight then
    HighlightStr := Writer.GetColorText(Style.HighlightColor, ctHighlight)
  else
    HighlightStr := EmptyStr;
end;

procedure TQExport3RTF.SetOptions(const Value: TRTFOptions);
begin
  FOptions.Assign(Value);
end;

{ TrtfStyle }

constructor TrtfStyle.Create(Collection: TCollection);
begin
  inherited;
  FFont := TFont.Create;
  SetDefault;
  {FFont.Name := 'Arial';
  FFont.Size := 10;
  FBackgroundColor := clWhite;
  FHighlightColor := clWhite;
  FAllowHighlight := false;
  FAllowBackground := true;}
end;

destructor TrtfStyle.Destroy;
begin
  FFont.Free;
  inherited;
end;

procedure TrtfStyle.Assign(Source: TPersistent);
begin
  if Source is TrtfStyle then begin
    Font := (Source as TrtfStyle).Font;
    BackgroundColor := (Source as TrtfStyle).BackgroundColor;
    HighlightColor := (Source as TrtfStyle).HighlightColor;
    AllowHighlight := (Source as TrtfStyle).AllowHighlight;
    AllowBackground := (Source as TrtfStyle).AllowBackground;
    Alignment := (Source as TrtfStyle).Alignment;
    Exit;
  end;
  inherited;
end;

procedure TrtfStyle.SetDefault;
begin
  FFont.Name := 'Arial';
  FFont.Size := 10;
  FFont.Style := [];
  FFont.Color := clBlack;
  FBackgroundColor := clWhite;
  FHighlightColor := clWhite;
  FAllowHighlight := false;
  FAllowBackground := true;
  FAlignment := talLeft;
end;

procedure TrtfStyle.SaveToIniFile(IniFile: TIniFile; const Section: string);
begin
  with IniFile do begin
    WriteString(Section, S_RTF_FontName, FFont.Name);
    WriteInteger(Section, S_RTF_FontSize, FFont.Size);
    WriteInteger(Section, S_RTF_FontColor, FFont.Color);
    WriteBool(Section, S_RTF_FontBold, fsBold in FFont.Style);
    WriteBool(Section, S_RTF_FontItalic, fsItalic in FFont.Style);
    WriteBool(Section, S_RTF_FontUnderline, fsUnderline in FFont.Style);
    WriteBool(Section, S_RTF_FontStrikeOut, fsStrikeOut in FFont.Style);
    WriteInteger(Section, S_RTF_BackgroundColor, FBackgroundColor);
    WriteInteger(Section, S_RTF_HighlightColor, FHighlightColor);
    WriteBool(Section, S_RTF_AllowHighlight, FAllowHighlight);
    WriteBool(Section, S_RTF_AllowBackground, FAllowBackground);
    WriteInteger(Section, S_RTF_Alignment, Integer(FAlignment));
  end;
end;

procedure TrtfStyle.LoadFromIniFile(IniFile: TIniFile; const Section: string);
begin
  SetDefault;
  with IniFile do begin
    FFont.Name := ReadString(Section, S_RTF_FontName, FFont.Name);
    FFont.Size := ReadInteger(Section, S_RTF_FontSize, FFont.Size);
    FFont.Color := ReadInteger(Section, S_RTF_FontColor, FFont.Color);
    if ReadBool(Section, S_RTF_FontBold, fsBold in FFont.Style)
      then FFont.Style := FFont.Style + [fsBold]
      else FFont.Style := FFont.Style - [fsBold];
    if ReadBool(Section, S_RTF_FontItalic, fsItalic in FFont.Style)
      then FFont.Style := FFont.Style + [fsItalic]
      else FFont.Style := FFont.Style - [fsItalic];
    if ReadBool(Section, S_RTF_FontUnderline, fsUnderline in FFont.Style)
      then FFont.Style := FFont.Style + [fsUnderline]
      else FFont.Style := FFont.Style - [fsUnderline];
    if ReadBool(Section, S_RTF_FontStrikeOut, fsStrikeOut in FFont.Style)
      then FFont.Style := FFont.Style + [fsStrikeOut]
      else FFont.Style := FFont.Style - [fsStrikeOut];
    FBackgroundColor :=
      ReadInteger(Section, S_RTF_BackgroundColor, FBackgroundColor);
    FHighlightColor :=
      ReadInteger(Section, S_RTF_HighlightColor, FHighlightColor);
    FAllowHighlight :=
      ReadBool(Section, S_RTF_AllowHighlight, FAllowHighlight);
    FAllowBackground :=
      ReadBool(Section, S_RTF_AllowBackground, FAllowBackground);
    FAlignment :=
      TrtfTextAlignment(ReadInteger(Section, S_RTF_Alignment,
        Integer(FAlignment)));
  end;
end;

procedure TrtfStyle.SetFont(const Value: TFont);
begin
  FFont.Assign(Value);
end;

{ TrtfStyles }

constructor TrtfStyles.Create(Holder: TPersistent);
begin
  inherited Create(TrtfStyle);
  FHolder := Holder;
end;

function TrtfStyles.Add: TrtfStyle;
begin
  Result := inherited Add as TrtfStyle;
end;

procedure TrtfStyles.SaveToIniFile(IniFile: TIniFile;
  const SectionPrefix: string);
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    Items[i].SaveToIniFile(IniFile, SectionPrefix + IntToStr(i)); 
end;

procedure TrtfStyles.LoadFromIniFile(IniFile: TIniFile;
  const SectionPrefix: string);
var
  List: TStringList;
  i: integer;
  Str: string;
begin
  BeginUpdate;
  try
    Clear;
    List := TStringList.Create;
    try
      IniFile.ReadSections(List);
      for i := 0 to List.Count - 1 do begin
        Str := Copy(List[i], 1, Length(SectionPrefix));
        if AnsiCompareText(Str, SectionPrefix) = 0 then
          Add.LoadFromIniFile(IniFile, List[i]);
      end;
    finally
      List.Free;
    end;
  finally
    EndUpdate;
  end;
end;

function TrtfStyles.GetOwner: TPersistent;
begin
  Result := FHolder;
end;

function TrtfStyles.GetItem(Index: integer): TrtfStyle;
begin
  Result := inherited GetItem(Index) as TrtfStyle;
end;

procedure TrtfStyles.SetItem(Index: integer; Value: TrtfStyle);
begin
  inherited SetItem(Index, Value);
end;

end.