rm_e_htm.pas

进销存·完整的·有数据库的·非常完整·只得参考

  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 SingleFile then
    FImagesStream := TMemoryStream.Create
  else
    FImagesStream := nil;

  FRepFileNames.Add(FileName);
  if SeparateFilePerPage or (CurReport.EMFPages.Count <> 1) then
  begin
    for K := 1 to (CurReport.EMFPages.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 := RMReplaceString(RMAppendTrailingBackslash(FImageEncodeDir), '\', '/');
    SetCurrentDir(TempDir);
  end;
end;

procedure TRMHTMExport.OnEndDoc;
var
  lStream: TMemoryStream;
begin
  if FCreateMHTFile and (Stream.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);

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

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

      lStream.Clear;
      if FImagesStream.Size > 0 then
      begin
        FImagesStream.Position := 0;
        Stream.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>' + CurReport.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(Stream, S);
end;

procedure TRMHTMExport.WriteFooter;
var
  S: string;

  function GetNavHTML: string;
  const
    ATextFormat = '<A %sTITLE="%s">%s</A>';
    AImageFormat = '<A %sTITLE="%s"><IMG SRC="%s" ALT="%s"></A>';
  var
    FirstPage, LastPage: Boolean;
    FirstLnk, PrevLnk, NextLnk, LastLnk: string;
  begin
    FirstLnk := '';
    PrevLnk := '';
    NextLnk := '';
    LastLnk := '';
    Result := '';
    FirstPage := (FPageNo = 0);
    LastPage := (FPageNo = CurReport.EMFPages.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[CurReport.EMFPages.Count - 1]) + '" ';
      NextLnk := 'HREF="' + ExtractFileName(FRepFileNames[FPageNo + 1]) + '" ';
    end;

    if FUseTextLinks then
      Result := Format(ATextFormat,
        [FirstLnk, FLinkTextFirst {STitleTextFirst}, 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 PageEndLines and (FPageNo < CurReport.EMFPages.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(Stream, S);
  end
  else if (not SeparateFilePerPage) and PageEndLines 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(Stream, S);
  end
  else if (not SingleFile) and SeparateFilePerPage and ShowNavigator and (CurReport.EMFPages.Count > 1) then
  begin
    S := '<DIV STYLE="' +
      'position: absolute; ' +
      'top: ' + IntToStr(Round(FPageHeight)) + 'px; ' +
      'left: ' + IntToStr(Round(CurReport.EMFPages[0].pgMargins.Left)) + 'px; ' +
      'font: ' + IntToStr(FLinkFont.Size) + 'pt ' + FLinkFont.Name +
      '; color: ' + RMColorBGRToRGB(FLinkFont.Color) + '; ' +
      'background: ' + RMColorBGRToRGB(FLinkBackColor) + '">' +
      GetNavHTML + '</DIV>' + CRLF;
    WriteToStream(Stream, S);
  end;

  if (not SingleFile) and (SeparateFilePerPage or (FPageNo = (CurReport.EMFpages.Count - 1))) then
  begin
    S := CRLF + '</BODY>' + CRLF + '</HTML>' + CRLF;
    WriteToStream(Stream, S);
  end;
end;

procedure TRMHTMExport.OnEndPage;
var
  ReuseImageIndex: Integer;
  AFileName: string;

  procedure SetReuseImageIndex(AViewName: string; AViewIndex: Integer);
  var
    UniqueImage: Boolean;
  begin
    UniqueImage := True;
    ReuseImageIndex := -1;
    FAltText := ExtractFileName(AFileName);
    if Assigned(FBeforeSaveGraphic) then
      FBeforeSaveGraphic(Self, AViewName, UniqueImage, ReuseImageIndex, FAltText);

    if not UniqueImage then
    begin
      if ReuseImageIndex >= FDataList.Count then
        ReuseImageIndex := -1
      else if (ReuseImageIndex = -1) then
        ReuseImageIndex := FImgFileNames.IndexOfObject(TObject(AViewIndex));
    end
    else
      ReuseImageIndex := -1;
  end;

  procedure Encodedata;
  var
    I, K: Integer;
    DataRec: PRMEFDataRec;
    AImageSource, ABackGroundInfo, ABorderInfo, S: string;
    liFlag: Boolean;

    function GetBorderInfo: string;
    var
      Attrib: string;
      DrawTop, DrawBottom, DrawRight, DrawLeft: Boolean;
    begin
      Result := '';
      if not ExportFrames then Exit;

   // border width and color
      Attrib := IntToStr(Round(DataRec^.FrameInfo.FrameWidth)) + 'px solid ' +
        '#' + RMColorBGRToRGB(DataRec^.FrameInfo.FrameColor);

   // Right Frame
      DrawRight := DataRec^.FrameInfo.FrameTyp in [efftRight, efftRightBottom,
        efftLeftRight, efftLeftRightBottom, efftRightTop, efftRightTopBottom,
        efftLeftRightTop, efftAll];

   // Left Frame
      DrawLeft := DataRec^.FrameInfo.FrameTyp in [efftLeft, efftLeftRight,
        efftLeftBottom, efftLeftRightBottom, efftLeftTop, efftLeftRightTop,
        efftLeftTopBottom, efftAll];

   // Top Frame
      DrawTop := DataRec^.FrameInfo.FrameTyp in [efftTop, efftRightTop,
        efftTopBottom, efftRightTopBottom, efftLeftTop, efftLeftRightTop,
        efftLeftTopBottom, efftAll];

   // Bottom Frame
      DrawBottom := DataRec^.FrameInfo.FrameTyp in [efftBottom, efftRightBottom,
        efftLeftBottom, efftLeftRightBottom, efftTopBottom, efftRightTopBottom,
        efftLeftTopBottom, efftAll];

      if DrawTop then
        Result := '; border-top: ' + Attrib;
      if DrawRight then
        Result := Result + '; border-right: ' + Attrib;
      if DrawBottom then
        Result := Result + '; border-bottom: ' + Attrib;
      if DrawLeft then
        Result := Result + '; border-Left: ' + Attrib;
    end;

  begin
    for I := 0 to FDataList.Count - 1 do
    begin
      Application.ProcessMessages;
      DataRec := PRMEFDataRec(FDataList[I]);
      DataRec^.Y := DataRec^.Y + GetOffsetFromTop;
      AImageSource := '';
      ABorderInfo := '';
      ABackGroundInfo := '';
      if ExportImages then
      begin
        liFlag := (DataRec^.ViewClassName = TRMMemoView.ClassName) or (DataRec^.ViewClassName = TRMCalcMemoView.ClassName);
        if (not liFlag or DataRec^.VerticalText) and (DataRec^.ViewClassName <> TRMLineView.ClassName) then
        begin
          SetReuseImageIndex(DataRec^.ViewName, DataRec^.ViewIndex);
          if (ReuseImageIndex <> -1) and (ReuseImageIndex < FImgFileNames.Count) then
          begin
            AFileName := FImgFileNames[ReuseImageIndex];
            K := ReuseImageIndex;
          end
          else
          begin
            AFileName := FImageCreateDir + RMMakeImgFileName(ExtractFileName(FileName), 'bmp', ImgFileCount + 1);
            AFileName := SaveBitmapAs(DataRec^.Bitmap,
              ExportImageFormat{$IFDEF JPEG}, JPEGQuality{$ENDIF}, ChangeFileExt(AFileName, ''));
            K := FImgFileNames.AddObject(AFileName, TObject(Datarec^.ViewIndex));
          end;
          AFileName := FImageEncodeDir + ExtractFileName(AFileName);
          DataRec^.Bitmap.Free;
          if Assigned(FAfterSaveGraphic) then
            FAfterSaveGraphic(Self, DataRec^.ViewName, K);
          AImageSource := '<IMG SRC="' + AFileName + '" ALT="' + FAltText + '">';
        end;
      end;

      S := '';
      if ExportFrames and (DataRec^.FrameInfo.FillColor <> clNone) then
        ABackGroundInfo := '; background-color: #' + RMColorBGRToRGB(DataRec^.FrameInfo.FillColor);
   // Setting font to 0pt allows box and frame-area height
   // to be lesser than default minimum, which is height
   // of 10pt font + padding
      S := '<DIV STYLE="font: 0pt' + ABackGroundInfo + '; ' +
        'position: absolute; ' +
        'top: ' + IntToStr(DataRec^.Y) + 'px; ' +
        'left: ' + IntToStr(DataRec^.X) + 'px; ' +
        'width: ' + IntToStr(DataRec^.dx) + 'px; ' +
        'height: ' + IntToStr(DataRec^.dy + 1) + 'px';

      if ExportFrames and ((DataRec^.ViewClassName = TRMMemoView.ClassName) or
        (DataRec^.ViewClassName = TRMCalcMemoView.ClassName) or
        (DataRec^.ViewClassName = TRMLineView.ClassName)) then
      begin
        ABorderInfo := GetBorderInfo;
        S := S + ABorderInfo + ';">';
      end
      else
        S := S + ';">';
      S := S + AImageSource + '</DIV>' + CRLF;

      if (ABackGroundInfo <> '') or (ABorderInfo <> '') or (AImageSource <> '') then
        WriteToStream(Stream, S);
    end;
  end;

  procedure EncodeText;
  var
    I: Integer;
    TextRec: PRMEFTextRec;
    EncodedText: string;

  // encode underline & strikeout
    function TextDecor: string;
    begin
      Result := '';
      if ((TextRec^.FontInfo.Style - [fsBold, fsItalic]) <> []) then
      begin
        Result := '; text-decoration:';
        if fsUnderline in TextRec^.FontInfo.Style then
          Result := Result + ' underline';
        if fsStrikeOut in TextRec^.FontInfo.Style then
          Result := Result + ' line-through';
      end;
    end;

  begin
    for I := 0 to FTextList.Count - 1 do
    begin
      Application.ProcessMessages;
      TextRec := PRMEFTextRec(FTextList[I]);
      TextRec^.Y := TextRec^.Y + GetOffsetFromTop;

   // The real content: object text
      EncodedText := '<DIV STYLE="' +
        'position: absolute; ' +
        'top: ' + IntToStr(TextRec^.Y) + 'px; ' +
        'left: ' + IntToStr(TextRec^.X) + 'px; ' +
        'width: ' + IntToStr(Round(TextRec^.TextWidth * 2.5)) + 'px; ' +
    // Setting text width prevents text, containing hyphens (-),
    // from breaking to the next line.
    // "* 2.5" compensation for (browser) printing error, does not
    // alter on-screen rendering.
      'font:' + Italic[fsItalic in (TextRec^.FontInfo.Style)] +
        Bold[fsBold in (TextRec^.FontInfo.Style)] + ' ' +