rm_e_htm.pas

这是一个功能强大

  FImageDir := '';
  FAltText := '';
  FLinkTextFirst := RMLoadStr(rmRes + 1796);
  FLinkTextPrev := RMLoadStr(rmRes + 1795);
  FLinkTextNext := RMLoadStr(rmRes + 1794);
  FLinkTextLast := RMLoadStr(rmRes + 1793);
  FLinkFont := TFont.Create;

  FLinkFont.Size := 18;
  FLinkFont.Color := CLinkForeColor;
  FLinkBackColor := CLinkBackColor;
  FLinkHoverForeColor := CLinkHoverForeColor;
  FLinkHoverBackColor := CLinkHoverBackColor;
  FLinkImgSRCFirst := '';
  FLinkImgSRCNext := '';
  FLinkImgSRCPrev := '';
  FLinkImgSRCLast := '';
  FSeparateFilePerPage := True;
  FShowNavigator := True;
  FUseTextLinks := True;
  FSingleFile := False;

  FCSSClasses := TStringList.Create;
  FOptimizeForIE := True;
end;

destructor TRMHTMExport.Destroy;
begin
  FLinkFont.Free;
  FCssClasses.Free;
  inherited Destroy;
end;

function TRMHTMExport.GetImgFileCount: Integer;
begin
  Result := FImgFileNames.Count;
end;

function TRMHTMExport.GetRepFileCount: Integer;
begin
  Result := FRepFileNames.Count;
end;

procedure TRMHTMExport.SetLinkFont(const Value: TFont);
begin
  FLinkFont.Assign(Value);
end;

procedure TRMHTMExport.OnBeginDoc;
var
  K: Integer;
  TempDir: string;
begin
  inherited;
  FRepFileNames := TStringList.Create;
  FImgFileNames := TStringList.Create;

  SingleFile := SingleFile or FCreateMHTFile;
  if FCreateMHTFile then
    FImagesStream := TMemoryStream.Create
  else
    FImagesStream := nil;

  FRepFileNames.Add(FileName);
  if SeparateFilePerPage or (ParentReport.EndPages.Count <> 1) then
  begin
    for K := 1 to (ParentReport.EndPages.Count - 1) do
      FRepFileNames.Add(ExtractFilePath(FileName) + RMMakeFileName(FileName, 'htm', K + 1));
  end;

  FImageEncodeDir := Trim(ImageDir);
  FImageCreateDir := ExtractFilePath(FileName);
  if FImageEncodeDir <> '' then
  begin
    TempDir := GetCurrentDir;
    SetCurrentDir(FImageCreateDir);
    FImageCreateDir := RMAppendTrailingBackslash(ExpandFileName(FImageEncodeDir));
    if not RMDirectoryExists(FImageCreateDir) then
      RMForceDirectories(FImageCreateDir);
    FImageEncodeDir := StringReplace(RMAppendTrailingBackslash(FImageEncodeDir), '\', '/', [rfReplaceAll]);
    SetCurrentDir(TempDir);
  end;
end;

procedure TRMHTMExport.OnEndDoc;
var
  lStream: TMemoryStream;
begin
  if FCreateMHTFile and (ExportStream.Size > 0) then
  begin
    lStream := TMemoryStream.Create;
    try
{----生成主文档----}
      WriteToStream(lStream, 'Content-Type: multipart/related;' + CRLF);
      WriteToStream(lStream, '	boundary="===Test MHT by Town===";' + CRLF);
      WriteToStream(lStream, '	type="text/html"' + CRLF);
      WriteToStream(lStream, '' + CRLF);
      WriteToStream(lStream, 'This is a mht sample Produced By Town' + CRLF); //您可以在这里写任何东西
      WriteToStream(lStream, 'This is a multi-part message in MIME format.' + CRLF);
      WriteToStream(lStream, '--===Test MHT by Town===' + CRLF);
      WriteToStream(lStream, 'Content-Type: text/html; charset=gb2312' + CRLF);
      WriteToStream(lStream, 'Content-Transfer-Encoding: 8bit' + CRLF);
      WriteToStream(lStream, '' + CRLF);

      ExportStream.Position := 0;
      lStream.CopyFrom(ExportStream, ExportStream.Size);
      ExportStream.Size := 0;

      WriteToStream(lStream, '--===Test MHT by Town===' + CRLF);
      lStream.Position := 0;
      ExportStream.CopyFrom(lStream, lStream.Size);

      lStream.Clear;
      if FImagesStream.Size > 0 then
      begin
        FImagesStream.Position := 0;
        ExportStream.CopyFrom(FImagesStream, FImagesStream.Size);
      end;
    finally
      lStream.Free;
    end;
  end;

  FRepFileNames.Free;
  FImgFileNames.Free;
  FImagesStream.Free;
  inherited OnEndDoc;
end;

const
  Bold: array[Boolean] of string = ('', ' bold');
  Italic: array[Boolean] of string = ('', ' italic');

  ANSICodePageIDs: array[0..13] of record
    ISOCode: string;
    WinCode: Integer;
  end = (
    (ISOCode: 'ISO-8859-11'; WinCode: 874), {Thai}
    (ISOCode: 'Windows-932'; WinCode: 932), {Japanese}
    (ISOCode: 'gb2312-80'; WinCode: 936), {Chinese (PRC, Singapore)}
    (ISOCode: 'Windows-949'; WinCode: 949), {Korean}
    (ISOCode: 'csbig5'; WinCode: 950), {Chinese (Taiwan, Hong Kong)}
    (ISOCode: 'ISO-10646'; WinCode: 1200), {Unicode (BMP of ISO 10646)}
    (ISOCode: 'ISO-8859-2'; WinCode: 1250), {Eastern European}
    (ISOCode: 'ISO-8859-5'; WinCode: 1251), {Latin/Cyrillic}
    (ISOCode: 'ISO-8859-1'; WinCode: 1252), {Latin 1 (US, Western Europe)}
    (ISOCode: 'ISO-8859-7'; WinCode: 1253), {Greek}
    (ISOCode: 'ISO-8859-9'; WinCode: 1254), {Turkish}
    (ISOCode: 'ISO-8859-8'; WinCode: 1255), {Hebrew}
    (ISOCode: 'ISO-8859-6'; WinCode: 1256), {Latin/Arabic}
    (ISOCode: 'ISO-8859-13'; WinCode: 1257) {Baltic}
    );

procedure TRMHTMExport.WriteHeader; // html文件头
var
  S: string;

  function _GetISOCharSet(WinCP: Integer): string;
  var
    I: Integer;
  begin
    Result := '';
    for I := Low(ANSICodePageIDs) to High(ANSICodePageIDs) do
    begin
      if ANSICodePageIDs[I].WinCode = WinCP then
      begin
        Result := ANSICodePageIDs[I].ISOCode;
        Break;
      end;
    end;
  end;

begin
  FCSSClasses.Clear;
  S := '<HTML>' + CRLF + '<HEAD>' + CRLF + '<TITLE>' + ParentReport.ReportInfo.Title + '</TITLE>' + CRLF +
    '<META HTTP-EQUIV="Content-Style-Type" CONTENT="text/css" CHARSET="' +
    _GetISOCharSet(GetACP) + '">' + CRLF;

  if not SingleFile and SeparateFilePerPage and ShowNavigator then
  begin
    S := S + '<STYLE>' + CRLF + '<!--' + CRLF +
      '  A:link {font: ' + IntToStr(FLinkFont.Size) + 'pt ' + FLinkFont.Name +
      '; text-decoration: none; color: ' + RMColorBGRToRGB(FLinkFont.Color) +
      '; background-color: ' + RMColorBGRToRGB(FLinkBackColor) +
      '}' + CRLF +
      '  A:visited {font: ' + IntToStr(FLinkFont.Size) + 'pt ' + FLinkFont.Name +
      '; text-decoration: none; color: ' + RMColorBGRToRGB(FLinkFont.Color) +
      '; background-color: ' + RMColorBGRToRGB(FLinkBackColor) +
      '}' + CRLF +
      '  A:hover {font: ' + IntToStr(FLinkFont.Size) + 'pt ' + FLinkFont.Name +
      '; text-decoration: none; color: ' + RMColorBGRToRGB(FLinkHoverForeColor) +
      '; background-color: ' + RMColorBGRToRGB(FLinkHoverBackColor) +
      '}' + CRLF +
      '-->' + CRLF + '</STYLE>';
  end;

  S := S + CRLF + '</HEAD>' + CRLF + CRLF + '<BODY BGCOLOR = "#FFFFFF">' + CRLF;
  WriteToStream(ExportStream, S);
end;

const
  ATextFormat = '<A %sTITLE="%s">%s</A>';
  AImageFormat = '<A %sTITLE="%s"><IMG SRC="%s" ALT="%s"></A>';

procedure TRMHTMExport.WriteFooter;
var
  S: string;

  function _GetNavHTML: string;
  var
    FirstPage, LastPage: Boolean;
    FirstLnk, PrevLnk, NextLnk, LastLnk: string;
  begin
    FirstLnk := '';
    PrevLnk := '';
    NextLnk := '';
    LastLnk := '';
    Result := '';
    FirstPage := (FPageNo = 0);
    LastPage := (FPageNo = ParentReport.EndPages.Count - 1);
    if not FirstPage then
    begin
      FirstLnk := 'HREF="' + ExtractFileName(FRepFileNames[0]) + '" ';
      PrevLnk := 'HREF="' + ExtractFileName(FRepFileNames[FPageNo - 1]) + '" ';
    end;
    if not LastPage then
    begin
      LastLnk := 'HREF="' + ExtractFileName(FRepFileNames[ParentReport.EndPages.Count - 1]) + '" ';
      NextLnk := 'HREF="' + ExtractFileName(FRepFileNames[FPageNo + 1]) + '" ';
    end;

    if FUseTextLinks then
      Result := Format(ATextFormat,
        [FirstLnk, FLinkTextFirst, FLinkTextFirst]) + '&nbsp;' +
        Format(ATextFormat, [PrevLnk, FLinkTextPrev, FLinkTextPrev]) + '&nbsp;' +
        Format(ATextFormat, [NextLnk, FLinkTextNext, FLinkTextNext]) + '&nbsp;' +
        Format(ATextFormat, [LastLnk, FLinkTextLast, FLinkTextLast])
    else
      Result := Format(AImageFormat, [FirstLnk, FLinkTextFirst, FLinkImgSRCFirst, FLinkTextFirst]) + '&nbsp;' +
        Format(AImageFormat, [PrevLnk, FLinkTextPrev, FLinkImgSRCPrev, FLinkTextPrev]) + '&nbsp;' +
        Format(AImageFormat, [NextLnk, FLinkTextNext, FLinkImgSRCNext, FLinkTextNext]) + '&nbsp;' +
        Format(AImageFormat, [LastLnk, FLinkTextLast, FLinkImgSRCLast, FLinkTextLast]);
  end;

begin
  if SingleFile and (FPageNo < ParentReport.EndPages.Count - 1) then
  begin
    S := '<DIV STYLE="' +
      'position: absolute; ' +
      'top:' + IntToStr(Round((FPageNo + 1) * FPageHeight)) + 'px">' +
      '<HR SIZE= ' + IntToStr(Round(CPageEndLineWidth)) + ' ' +
      'WIDTH= ' + IntToStr(Round(FPageWidth - 10)) + ' ' +
      'NOSHADE></DIV>' + CRLF;
    WriteToStream(ExportStream, S);
  end
  else if not SeparateFilePerPage then
  begin
    S := '<DIV STYLE="' +
      'position: absolute; ' +
      'top: ' + IntToStr(Round((FPageNo + 1) * FPageHeight)) + 'px">' +
      '<HR SIZE= ' + IntToStr(Round(CPageEndLineWidth)) + ' ' +
      'WIDTH= ' + IntToStr(Round(FPageWidth - 10)) + ' ' +
      'NOSHADE></DIV>' + CRLF;
    WriteToStream(ExportStream, S);
  end
  else if (not SingleFile) and SeparateFilePerPage and ShowNavigator and (ParentReport.EndPages.Count > 1) then
  begin
    S := '<DIV STYLE="' +
      'position: absolute; ' +
      'top: ' + IntToStr(Round(FPageHeight)) + 'px; ' +
      'left: ' + IntToStr(Round(ParentReport.EndPages[0].spMarginLeft)) + 'px; ' +
      'font: ' + IntToStr(FLinkFont.Size) + 'pt ' + FLinkFont.Name +
      '; color: ' + RMColorBGRToRGB(FLinkFont.Color) + '; ' +
      'background: ' + RMColorBGRToRGB(FLinkBackColor) + '">' +
      _GetNavHTML + '</DIV>' + CRLF;
    WriteToStream(ExportStream, S);
  end;

  if (not SingleFile) or (FPageNo = ParentReport.EndPages.Count - 1) then
  begin
    S := CRLF + '</BODY>' + CRLF + '</HTML>' + CRLF;
    WriteToStream(ExportStream, S);
  end;
end;

procedure TRMHTMExport.InternalOnePage(aPage: TRMEndPage);
var
  lReuseImageIndex: Integer;
  lFileName: string;

  procedure _SetReuseImageIndex(aViewName: string; aViewIndex: Integer);
  var
    lUniqueImage: Boolean;
  begin
    lUniqueImage := True;
    lReuseImageIndex := -1;
    FAltText := ExtractFileName(lFileName);
    if Assigned(FBeforeSaveGraphic) then
      FBeforeSaveGraphic(Self, aViewName, lUniqueImage, lReuseImageIndex, FAltText);

    if not lUniqueImage then
    begin
      if lReuseImageIndex >= FDataList.Count then
        lReuseImageIndex := -1
      else if lReuseImageIndex = -1 then
        lReuseImageIndex := FImgFileNames.IndexOfObject(TObject(aViewIndex));
    end
    else
      lReuseImageIndex := -1;
  end;

  function _ExportPicture(aDataRec: TRMIEMData): string; // 导出图片
  var
    lImageIndex: Integer;
  begin
    Result := '';
    if (not ExportImages) or (THackRMIEMData(aDataRec).FGraphic = nil) then Exit;

    _SetReuseImageIndex(aDataRec.Obj.Name, aDataRec.ViewIndex);
    if (lReuseImageIndex <> -1) and (lReuseImageIndex < FImgFileNames.Count) then
    begin
      lFileName := FImgFileNames[lReuseImageIndex];
      lImageIndex := lReuseImageIndex;
    end
    else
    begin
      lFileName := FImageCreateDir + RMMakeImgFileName(ExtractFileName(FileName), 'bmp', ImgFileCount + 1);
      lFileName := SaveBitmapAs(TBitmap(aDataRec.Graphic),
        ExportImageFormat{$IFDEF JPEG}, JPEGQuality{$ENDIF}, ChangeFileExt(lFileName, ''));
      lImageIndex := FImgFileNames.AddObject(lFileName, TObject(aDataRec.ViewIndex));
    end;
    FreeAndNil(THackRMIEMData(aDataRec).FGraphic);

    if Assigned(FAfterSaveGraphic) then
      FAfterSaveGraphic(Self, aDataRec.Obj.Name, lImageIndex);

    Result := '<IMG SRC="' + lFileName + '" ALT="' + FAltText + '">';
  end;

  procedure _ExportText(aDataRec: TRMIEMData);
  var
    i, lCount: Integer;
    t: TRMCustomMemoView;
    lOutputStr: string;
    lTextRec: pRMEFTextRec;

    function _TextDecor: string;
    begin
      Result := '';
      if ((t.Font.Style - [fsBold, fsItalic]) <> []) then
      begin
        Result := '; text-decoration:';
        if fsUnderline in t.Font.Style then
          Result := Result + ' underline';
        if fsStrikeOut in t.Font.Style then
          Result := Result + ' line-through';
      end;
    end;

  begin
    lCount := aDataRec.TextListCount;
    t := TRMCustoMMemoView(aDataRec.Obj);
    for i := 0 to lCount - 1 do
    begin
      lTextRec := aDataRec.TextList[i];
      lTextRec.Left := lTextRec.Left + aPage.spMarginLeft;
      lTextRec.Top := lTextRec.Top + aPage.spMarginTop + GetOffsetFromTop;
      lOutputStr := '<DIV STYLE="' +
        'position: absolute; ' +
        'top: ' + IntToStr(lTextRec.Top) + 'px; ' +
        'left: ' + IntToStr(lTextRec.Left) + 'px; ' +
        'width: ' + IntToStr(Round(lTextRec.TextWidth * 2.5)) + 'px; ' +
        'font:' + Italic[fsItalic in (t.Font.Style)] + Bold[fsBold in (t.Font.Style)] + ' ' +
        IntToStr(t.Font.Size) + 'pt ' + t.Font.Name + _TextDecor + '; ' +
        'color: #' + RMColorBGRToRGB(t.Font.Color) + '">';

      lOutputStr := lOutputStr + GetNativeText(lTextRec.Text) + '</DIV>' + CRLF;
      WriteToStream(ExportStream, lOutputStr);
    end;
  end;

  procedure _Encodedata;
  var
    i: Integer;
    lDataRec: TRMIEMData;
    lImageSource, lBackGroundInfo, lBorderInfo, S: string;

    function _GetBorderInfo: string;
    var
      Attrib: string;
    begin
      Result := '';
      if not ExportFrames then Exit;

      Attrib := IntToStr(Round(lDataRec.Obj.TopFrame.spWidth)) + 'px solid ' +
        '#' + RMColorBGRToRGB(lDataRec.Obj.TopFrame.Color);

      if lDataRec.Obj.TopFrame.Visible then
        Result := '; border-top: ' + Attrib;
      if lDataRec.Obj.RightFrame.Visible then
        Result := Result + '; border-right: ' + Attrib;
      if lDataRec.Obj.BottomFrame.Visible then
        Result := Result + '; border-bottom: ' + Attrib;
      if lDataRec.Obj.LeftFrame.Visible then
        Result := Result + '; border-Left: ' + Attrib;
    end;

  begin
    for i := 0 to FDataList.Count - 1 do
    begin
      Application.ProcessMessages;
      lDataRec := FDataList[I];
      lDataRec.Left := lDataRec.Left + aPage.spMarginLeft;
      lDataRec.Top := lDataRec.Top + aPage.spMarginTop + GetOffsetFromTop;
      lImageSource := '';