qexport4rtf.pas

Advanced.Export.Component.v4.01.rar,delphi 第三方控件

    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 + ' ';

  {$IFDEF QE_UNICODE}
  NewResult := '';
  TempStr := Result;
  stlen := 0;
  //finding complete string length
  for i := 1 to Length(TempStr) do
  begin
    Code := Word(TempStr[i]);
    if not (Code in [Word(#13), Word(#10), Word('\')]) then
      stlen := stlen + 3 + Length(IntToStr(Code))
    else
      stlen := stlen + 1;
  end;
  SetLength(NewResult, stlen);
  stlen := 1;
  //Changing to unicode
  for i := 1 to Length(TempStr) do
  begin
    Code := Word(TempStr[i]);
    if not (Code in [Word(#13), Word(#10), Word('\')]) then
    begin
      TempCodeString := IntToStr(Code);
      NewResult[stlen] := '\';
      NewResult[stlen + 1] := 'u';
      for j := 1 to Length(TempCodeString) do
        NewResult[stlen + 1 + j] := TempCodeString[j];
      NewResult[stlen + 2 + Length(TempCodeString)] := '?';
      stlen := stlen + 3 + Length(TempCodeString);
    end
    else
    begin
      NewResult[stlen] := TempStr[i];
      stlen := stlen + 1;
    end;
  end;
  Result := NewResult;
  {NewResult := '';
  TempStr := Result;
  for i := 1 to Length(TempStr) do
  begin
    Code := Word(TempStr[i]);
    NewResult := NewResult + '\u' + IntToStr(Code) + '?';
  end;
  Result := NewResult;}
  {$ENDIF}

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

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

function TQExport4RTF.GetColData(ColValue: QEString;
  Column: TQExportColumn): QEString;
var
  AlignStr, FontStr, ColorStr, AttrStr,
  BackgroundStr, HighLightStr, FormatStr: string;
  Style: TrtfStyle;
  Index, i: integer;
  ColAlign: TQExportColAlign;
  {$IFDEF QE_UNICODE}
  TempStr, NewResult, TempCodeString: WideString;
  Code: Word;
  stlen, j: Integer;
  {$ENDIF}
begin
  Result := inherited GetColData(ColValue, Column);
  Index := Column.Index;

  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 + ' ';


  {$IFDEF QE_UNICODE}
  NewResult := '';
  TempStr := Result;
  stlen := 0;
  //finding complete string length
  for i := 1 to Length(TempStr) do
  begin
    Code := Word(TempStr[i]);
    if not (Code in [Word(#13), Word(#10), Word('\')]) then
      stlen := stlen + 3 + Length(IntToStr(Code))
    else
      stlen := stlen + 1;
  end;
  SetLength(NewResult, stlen);
  stlen := 1;
  //Changing to unicode
  for i := 1 to Length(TempStr) do
  begin
    Code := Word(TempStr[i]);
    if not (Code in [Word(#13), Word(#10), Word('\')]) then
    begin
      TempCodeString := IntToStr(Code);
      NewResult[stlen] := '\';
      NewResult[stlen + 1] := 'u';
      for j := 1 to Length(TempCodeString) do
        NewResult[stlen + 1 + j] := TempCodeString[j];
      NewResult[stlen + 2 + Length(TempCodeString)] := '?';
      stlen := stlen + 3 + Length(TempCodeString);
    end
    else
    begin
      NewResult[stlen] := TempStr[i];
      stlen := stlen + 1;
    end;
  end;
  Result := NewResult;
  {for i := 1 to Length(TempStr) do
  begin
    Code := Word(TempStr[i]);
    if not (Code in [Word(#13), Word(#10), Word('\')]) then
      NewResult := NewResult + '\u' + IntToStr(Code) + '?'
    else
      NewResult := NewResult + TempStr[i];
  end;
  Result := NewResult;}
  {$ENDIF}

  Result := QEStringReplace(Result, #13#10, '\par ', [rfReplaceAll, rfIgnoreCase]);

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

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

procedure TQExport4RTF.EndExport;
var
  i: integer;
  Style: TrtfStyle;
  AlignStr, FontStr, ColorStr, AttrStr,
  BackgroundStr, HighlightStr, FormatStr: string;
  {$IFDEF QE_UNICODE}
  TempStr, NewResult, TempCodeString: WideString;
  Code: Word;
  stlen, j, k: Integer;
  {$ENDIF}
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 + ' ';
          Write('{' + HighlightStr + FormatStr);
          {$IFDEF QE_UNICODE}
            NewResult := '';
            TempStr := NormalString(Footer[i]);
            stlen := 0;
            //finding complete string length
            for j := 1 to Length(TempStr) do
            begin
              Code := Word(TempStr[j]);
              if not (Code in [Word(#13), Word(#10), Word('\')]) then
                stlen := stlen + 3 + Length(IntToStr(Code))
              else
                stlen := stlen + 1;
            end;
            SetLength(NewResult, stlen);
            stlen := 1;
            //Changing to unicode
            for j := 1 to Length(TempStr) do
            begin
              Code := Word(TempStr[j]);
              if not (Code in [Word(#13), Word(#10), Word('\')]) then
              begin
                TempCodeString := IntToStr(Code);
                NewResult[stlen] := '\';
                NewResult[stlen + 1] := 'u';
                for k := 1 to Length(TempCodeString) do
                  NewResult[stlen + 1 + k] := TempCodeString[k];
                NewResult[stlen + 2 + Length(TempCodeString)] := '?';
                stlen := stlen + 3 + Length(TempCodeString);
              end
              else
              begin
                NewResult[stlen] := TempStr[j];
                stlen := stlen + 1;
              end;
            end;
            Write(NewResult);
          {$ELSE}
            Write(NormalString(Self.Footer[i]));
          {$ENDIF}
          Writeln('}');
          WritePara;
        end;
      finally
        WriteLn('}');
      end;
    end;
    WriteEOF;
  end;
  inherited;
end;

function TQExport4RTF.NormalString(const S: QEString): QEString;
var
  p: Integer;
begin
  p := 1;
  Result := s;
  while p > 0 do
  begin
    p := QEPosEx('\', Result, p);
    if p > 0 then
    begin
      QEDelete(Result, p, 1);
      QEInsert('\\', Result, p);
      Inc(p, 2);
    end;
  end;
end;

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

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

procedure TQExport4RTF.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 TQExport4RTF.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: TQIniFile; 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: TQIniFile; 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: TQIniFile;
  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: TQIniFile;
  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.