rm_e_tiff.pas

这是一个功能强大

          end;
        end
        else
        begin
          { Flip Image }
          for I := 1 to Height do
          begin
            {$IFNDEF WINDOWS}
            BitsPtr := Bits + (Height - I) * BmpWidth;
            Stream.Write(BitsPtr^, DataWidth);
            {$ELSE}
            MemStream.Position := (Height - I) * BmpWidth;
            Stream.CopyFrom(MemStream, DataWidth);
            {$ENDIF}
          end;
        end;

        { Set Adresses into Directory }
        DirectoryCOL[6]._Value := OffsetStrip; { StripOffset  }
        DirectoryCOL[10]._Value := OffsetXRes; { X-Resolution }
        DirectoryCOL[11]._Value := OffsetYRes; { Y-Resolution }
        DirectoryCOL[13]._Value := OffsetSoftware; { Software     }

        { Write Directory }
        OffsetDir := Stream.Position;
        Stream.Write(NoOfDirs, sizeof(NoOfDirs));
        Stream.Write(DirectoryCOL, sizeof(DirectoryCOL));
        Stream.Write(NullString, sizeof(NullString));

        { Update Start of Directory }
        Stream.Seek(4, soFromBeginning);
        Stream.Write(OffsetDir, sizeof(OffsetDir));
      end;

      if BitCount in [24, 32] then
      begin

        { ========================================================================== }
        { 24, 32 - Bit - Image with with RGB-Values }
        { ========================================================================== }
        DirectoryRGB[1]._Value := LongInt(Width); { Image Width }
        DirectoryRGB[2]._Value := LongInt(Height); { Image Height }
        DirectoryRGB[8]._Value := LongInt(Height); { Image Height }
        DirectoryRGB[9]._Value := LongInt(3 * Width * Height); { Strip Byte Counts }

        { Write TIFF - File for Image with RGB-Values }
        { ------------------------------------------- }
        { Write Header }
        Stream.Write(TifHeader, sizeof(TifHeader));

        OffsetXRes := Stream.Position;
        Stream.Write(X_Res_Value, sizeof(X_Res_Value));

        OffsetYRes := Stream.Position;
        Stream.Write(Y_Res_Value, sizeof(Y_Res_Value));

        OffsetBitsPerSample := Stream.Position;
        Stream.Write(BitsPerSample, sizeof(BitsPerSample));

        OffsetSoftware := Stream.Position;
        Stream.Write(Software, sizeof(Software));

        OffsetStrip := Stream.Position;

        { Exchange Red and Blue Color-Bits }
        for I := 0 to Height - 1 do
        begin
          {$IFNDEF WINDOWS}
          BitsPtr := Bits + I * BmpWidth;
          {$ELSE}
          MemStream.Position := I * BmpWidth;
          {$ENDIF}
          for K := 0 to Width - 1 do
          begin
            {$IFNDEF WINDOWS}
            Blue := (BitsPtr)^;
            Red := (BitsPtr + 2)^;
            (BitsPtr)^ := Red;
            (BitsPtr + 2)^ := Blue;
            if BitCount = 24 then BitsPtr := BitsPtr + 3 // 24 - Bit Images
            else BitsPtr := BitsPtr + 4; // 32 - Bit images
            {$ELSE}
            MemStream.Read(RGBArr, SizeOf(RGBArr));
            MemStream.Seek(-SizeOf(RGBArr), soFromCurrent);
            Blue := RGBArr[0];
            Red := RGBArr[2];
            RGBArr[0] := Red;
            RGBArr[2] := Blue;
            MemStream.Write(RGBArr, SizeOf(RGBArr));
            if BitCount = 32 then
              MemStream.Seek(1, soFromCurrent);
            {$ENDIF}
          end;
        end;

        // If we have 32-Bit Image: skip every 4-th pixel
        if BitCount = 32 then
        begin
          for I := 0 to Height - 1 do
          begin
            {$IFNDEF WINDOWS}
            BitsPtr := Bits + I * BmpWidth;
            TmpBitsPtr := BitsPtr;
            {$ELSE}
            MemStream.Position := I * BmpWidth;
            ActPos := MemStream.Position;
            TmpPos := ActPos;
            {$ENDIF}
            for k := 0 to Width - 1 do
            begin
              {$IFNDEF WINDOWS}
              (TmpBitsPtr)^ := (BitsPtr)^;
              (TmpBitsPtr + 1)^ := (BitsPtr + 1)^;
              (TmpBitsPtr + 2)^ := (BitsPtr + 2)^;
              TmpBitsPtr := TmpBitsPtr + 3;
              BitsPtr := BitsPtr + 4;
              {$ELSE}
              MemStream.Seek(ActPos, soFromBeginning);
              MemStream.Read(RGBArr, SizeOf(RGBArr));
              MemStream.Seek(TmpPos, soFromBeginning);
              MemStream.Write(RGBArr, SizeOf(RGBArr));
              TmpPos := TmpPos + 3;
              ActPos := ActPos + 4;
              {$ENDIF}
            end;
          end;
        end;

        { Write Image Data }
        if Height < 0 then
        begin
          BmpWidth := Trunc(BitsSize / Height);
          for I := 0 to Height - 1 do
          begin
            {$IFNDEF WINDOWS}
            BitsPtr := Bits + I * BmpWidth;
            Stream.Write(BitsPtr^, Width * 3);
            {$ELSE}
            MemStream.Position := I * BmpWidth;
            Stream.CopyFrom(MemStream, Width * 3);
            {$ENDIF}
          end;
        end
        else
        begin
          { Write Image Data and Flip Image horizontally }
          BmpWidth := Trunc(BitsSize / Height);
          for I := 1 to Height do
          begin
            {$IFNDEF WINDOWS}
            BitsPtr := Bits + (Height - I) * BmpWidth;
            Stream.Write(BitsPtr^, Width * 3);
            {$ELSE}
            MemStream.Position := (Height - I) * BmpWidth;
            Stream.CopyFrom(MemStream, Width * 3);
            {$ENDIF}
          end;
        end;

        { Set Offset - Adresses into Directory }
        DirectoryRGB[3]._Value := OffsetBitsPerSample; { BitsPerSample }
        DirectoryRGB[6]._Value := OffsetStrip; { StripOffset   }
        DirectoryRGB[10]._Value := OffsetXRes; { X-Resolution  }
        DirectoryRGB[11]._Value := OffsetYRes; { Y-Resolution  }
        DirectoryRGB[14]._Value := OffsetSoftware; { Software      }

        { Write Directory }
        OffsetDir := Stream.Position;
        Stream.Write(NoOfDirs, sizeof(NoOfDirs));
        Stream.Write(DirectoryRGB, sizeof(DirectoryRGB));
        Stream.Write(NullString, sizeof(NullString));

        { Update Start of Directory }
        Stream.Seek(4, soFromBeginning);
        Stream.Write(OffsetDir, sizeof(OffsetDir));
      end;
    end;
  finally
    {$IFDEF WINDOWS}
    GlobalUnlock(MemHandle);
    GlobalFree(MemHandle);
    MemStream.Free;
    {$ELSE}
    FreeMem(Header);
    {$ENDIF}
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMTiffExport}

constructor TRMTiffExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMonochrome := False;
  FPixelFormat := pf24bit;
  FFileExtension := 'tif';

  {$IFDEF USE_IMAGEEN}
  FImageEnIO := TImageEnIO.Create(nil);
  FImageEnIO.Params.TIFF_Compression := ioTIFF_LZW;
  DefTIFF_LZWDECOMPFUNC := TIFFLZWDecompress;
  DefTIFF_LZWCOMPFUNC := TIFFLZWCompress;
  {$ENDIF}

  RMRegisterExportFilter(Self, 'Tiff Picture' + ' (*.tif)', '*.tif');
end;

destructor TRMTiffExport.Destroy;
begin
  {$IFDEF USE_IMAGEEN}
  FreeAndNil(FImageEnIO);
  {$ENDIF}

  inherited;
end;

function TRMTiffExport.ShowModal: Word;
var
  tmp: TRMTiffExportForm;
begin
  if not ShowDialog then
    Result := mrOk
  else
  begin
    tmp := TRMTiffExportForm.Create(nil);
    try
      tmp.edScaleX.Text := FloatToStr(Self.ScaleX);
      tmp.edScaleY.Text := FloatToStr(Self.ScaleY);
      tmp.chkMonochrome.Checked := Self.Monochrome;
      tmp.cmbPixelFormat.ItemIndex := Integer(Self.PixelFormat);
      Result := tmp.ShowModal;
      if Result = mrOK then
      begin
        Self.ScaleX := StrToFloat(tmp.edScaleX.Text);
        Self.ScaleY := StrToFloat(tmp.edScaleY.Text);
        Self.Monochrome := tmp.chkMonochrome.Checked;
        Self.PixelFormat := TPixelFormat(tmp.cmbPixelFormat.ItemIndex);
      end;
    finally
      tmp.Free;
    end;
  end;
end;

procedure TRMTiffExport.InternalOnePage(aPage: TRMEndPage);
var
  lBitmap: TBitmap;
begin
  lBitmap := TBitmap.Create;
  try
    lBitmap.Width := FPageWidth;
    lBitmap.Height := FPageHeight;
    lBitmap.Monochrome := FMonochrome;
    lBitmap.PixelFormat := FPixelFormat;
    DrawbkPicture(lBitmap.Canvas);
    aPage.Draw(ParentReport, lBitmap.Canvas, Rect(0, 0, FPageWidth, FPageHeight));

    {$IFDEF USE_IMAGEEN}
    FImageEnIO.Params.TIFF_ImageIndex := 0;
    FImageEnIO.AttachedBitmap := lBitmap;
    FImageEnIO.SaveToStreamTIFF(ExportStream);
    FImageEnIO.AttachedBitmap := nil;
    {$ELSE}
    WriteTiffToStream(ExportStream, lBitmap);
    {$ENDIF}
  finally
    lBitmap.Free;
  end;
end;

procedure TRMTiffExport.OnExportPage(const aPage: TRMEndPage);
var
  lFileName: string;
begin
  {$IFNDEF USE_IMAGEEN}
  inherited;
  Exit;
  {$ENDIF}

  FPageWidth := Round(aPage.PrinterInfo.ScreenPageWidth * ScaleX);
  FPageHeight := Round(aPage.PrinterInfo.ScreenPageHeight * ScaleY);
  if FPageNo = 0 then
    lFileName := FileName;

  try
    if FPageNo = 0 then
      ExportStream := TFileStream.Create(lFileName, fmCreate)
    else
      ExportStream := TMemoryStream.Create;

    InternalOnePage(aPage);
    {$IFDEF USE_IMAGEEN}
    if FPageNo > 0 then
    begin
      ExportStream.Position := 0;
      FImageEnIO.LoadFromStream(ExportStream);
      FImageEnIO.Params.TIFF_ImageIndex := FPageNo; // increment this for each page
      FImageEnIO.InsertToFileTIFF(FileName);
    end;
    {$ENDIF}
  finally
    FreeAndNil(ExportStream);
    Inc(FPageNo);
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMBMPExportForm}

procedure TRMTiffExportForm.Localize;
begin
  Font.Name := RMLoadStr(SRMDefaultFontName);
  Font.Size := StrToInt(RMLoadStr(SRMDefaultFontSize));
  Font.Charset := StrToInt(RMLoadStr(SCharset));

  RMSetStrProp(Self, 'Caption', rmRes + 1807);
  RMSetStrProp(chkMonochrome, 'Caption', rmRes + 1808);
  RMSetStrProp(Label1, 'Caption', rmRes + 1806);
  RMSetStrProp(Label4, 'Caption', rmRes + 1788);

  btnOK.Caption := RMLoadStr(SOk);
  btnCancel.Caption := RMLoadStr(SCancel);
end;

procedure TRMTiffExportForm.FormCreate(Sender: TObject);
begin
  Localize;
end;

end.