frexpimg.pas

来自「不错的报表工具」· PAS 代码 · 共 644 行 · 第 1/2 页

    frExportSet.Destroy;
  end;
  pgList.Clear;
  ParsePageNumbers;
  Result := Res;
end;

procedure TfrImgFltExport.OnBeginDoc;
begin
  OnAfterExport := AfterExport;
  CurrentPage := 0;
end;

procedure TfrImgFltExport.OnBeginPage;
begin
  Inc(CurrentPage);
  Canvas := TBitmap.Create;
  Canvas.Canvas.Brush.Color := clWhite;
  if Monochrome then
    Canvas.Monochrome := true
  else
    Canvas.Monochrome := false;
  if not Crop then
  begin
    Canvas.Width := CurReport.EMFPages[CurrentPage - 1].PrnInfo.Pgw;
    Canvas.Height := CurReport.EMFPages[CurrentPage - 1].PrnInfo.Pgh;
  end;
  MaxX := 0;
  MaxY := 0;
  MinX := CurReport.EMFPages[CurrentPage - 1].PrnInfo.Pgw;
  MinY := CurReport.EMFPages[CurrentPage - 1].PrnInfo.Pgh;
end;

procedure TfrImgFltExport.OnData(x, y: Integer; View: TfrView);
var
  ind: integer;
begin
  ind := 0;
  if (pgList.Find(IntToStr(CurrentPage), ind)) or (pgList.Count = 0) then
  begin
    if View.x < MinX then
      MinX := View.x;
    if View.y < MinY then
      MinY := View.Y;
    if (View.x + View.dx) > MaxX then
      MaxX := View.x + View.dx + 1;
    if (View.y + View.dy) > MaxY then
      MaxY := View.y + View.dY + 1;
    if Crop then
    begin
      Canvas.Canvas.Brush.Color := clWhite;
      Canvas.Width := MaxX;
      Canvas.Height := MaxY
    end;
    View.Draw(Canvas.Canvas);
  end;
end;

procedure TfrImgFltExport.OnEndPage;
var
  ind: integer;
  RFrom, RTo: TRect;
begin
  ind := 0;
  if (pgList.Find(IntToStr(CurrentPage), ind)) or (pgList.Count = 0) then
  begin
    if Crop then
    begin
      RFrom := Rect(MinX, MinY, MaxX, MaxY);
      RTo := Rect(0, 0, MaxX - MinX, MaxY - MinY);
      Canvas.Canvas.CopyRect(RTo, Canvas.Canvas, RFrom);
      Canvas.Width := MaxX - MinX;
      Canvas.Height := MaxY - MinY;
    end;
    Save;
  end;
  Canvas.Free;
end;

procedure TfrBMPExport.Save;
begin
  Canvas.SaveToFile(ChangeFileExt(FileName, '_' + IntToStr(CurrentPage) +
    '.bmp'));
end;

procedure TfrTIFFExport.Save;
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(ChangeFileExt(FileName, '_' +
    IntToStr(CurrentPage) + '.tif'), fmCreate);
  SaveTiffToStream(Stream, Canvas);
  Stream.Free;
end;

procedure TfrImgFltExport.AfterExport(const FileName: string);
begin
  frProgressForm.Close;
  DeleteFile(FileName);
end;

procedure TfrTIFFExport.SaveTIFFToStream(Stream: TStream; Bitmap: TBitmap);
var
  BM: HBitmap;
  Header, Bits, BitsPtr, TmpBitsPtr: PChar;
  HeaderSize, BitsSize: DWORD;
  Width, Height, DataWidth, BitCount: Integer;
  MapRed, MapGreen, MapBlue: array[0..255, 0..1] of Byte;
  ColTabSize, i, k, BmpWidth: Integer;
  Red, Blue: Char;
  O_XRes, O_YRes, O_Soft, O_Strip, O_Dir, O_BPS: LongInt;
begin
  BM := Bitmap.Handle;
  if BM = 0 then
    exit;
  GetDIBSizes(BM, HeaderSize, BitsSize);
  GetMem(Header, HeaderSize + BitsSize);
  try
    Bits := Header + HeaderSize;
    if GetDIB(BM, Bitmap.Palette, Header^, Bits^) then
    begin
      Width := PBITMAPINFO(Header)^.bmiHeader.biWidth;
      Height := PBITMAPINFO(Header)^.bmiHeader.biHeight;
      BitCount := PBITMAPINFO(Header)^.bmiHeader.biBitCount;
      ColTabSize := (1 shl BitCount);
      BmpWidth := Trunc(BitsSize / Height);
      if BitCount = 1 then
      begin
        DataWidth := ((Width + 7) div 8);
        D_BW[1]._Value := LongInt(Width);
        D_BW[2]._Value := LongInt(abs(Height));
        D_BW[8]._Value := LongInt(abs(Height));
        D_BW[9]._Value := LongInt(DataWidth * abs(Height));
        Stream.Write(TifHeader, sizeof(TifHeader));
        O_XRes := Stream.Position;
        Stream.Write(X_Res_Value, sizeof(X_Res_Value));
        O_YRes := Stream.Position;
        Stream.Write(Y_Res_Value, sizeof(Y_Res_Value));
        O_Soft := Stream.Position;
        Stream.Write(Software, sizeof(Software));
        D_BW[6]._Value := 0;
        D_BW[10]._Value := O_XRes;
        D_BW[11]._Value := O_YRes;
        D_BW[13]._Value := O_Soft;
        O_Dir := Stream.Position;
        Stream.Write(NoOfDirs, sizeof(NoOfDirs));
        Stream.Write(D_BW, sizeof(D_BW));
        O_Strip := Stream.Position;
        if Height < 0 then
          for I := 0 to Height - 1 do
          begin
            BitsPtr := Bits + I * BmpWidth;
            Stream.Write(BitsPtr^, DataWidth);
          end
        else
          for I := 1 to Height do
          begin
            BitsPtr := Bits + (Height - I) * BmpWidth;
            Stream.Write(BitsPtr^, DataWidth);
          end;
        Stream.Write(NullString, sizeof(NullString));
        D_BW[6]._Value := O_Strip;
        Stream.Seek(O_Dir, soFromBeginning);
        Stream.Write(NoOfDirs, sizeof(NoOfDirs));
        Stream.Write(D_BW, sizeof(D_BW));
        Stream.Seek(4, soFromBeginning);
        Stream.Write(O_Dir, sizeof(O_Dir));
      end;
      if BitCount in [4, 8, 16] then
      begin
        DataWidth := Width;
        if BitCount = 4 then
        begin
          Width := (Width div BitCount) * BitCount;
          if BitCount = 4 then
            DataWidth := Width div 2;
        end;
        D_COL[1]._Value := LongInt(Width);
        D_COL[2]._Value := LongInt(abs(Height));
        D_COL[3]._Value := LongInt(BitCount);
        D_COL[8]._Value := LongInt(Height);
        D_COL[9]._Value := LongInt(DataWidth * abs(Height));
        for I := 0 to ColTabSize - 1 do
        begin
          MapRed[I][1] := PBITMAPINFO(Header)^.bmiColors[I].rgbRed;
          MapRed[I][0] := 0;
          MapGreen[I][1] := PBITMAPINFO(Header)^.bmiColors[I].rgbGreen;
          MapGreen[I][0] := 0;
          MapBlue[I][1] := PBITMAPINFO(Header)^.bmiColors[I].rgbBlue;
          MapBlue[I][0] := 0;
        end;
        D_COL[14]._Count := LongInt(ColTabSize * 3);
        Stream.Write(TifHeader, sizeof(TifHeader));
        Stream.Write(MapRed, ColTabSize * 2);
        Stream.Write(MapGreen, ColTabSize * 2);
        Stream.Write(MapBlue, ColTabSize * 2);
        O_XRes := Stream.Position;
        Stream.Write(X_Res_Value, sizeof(X_Res_Value));
        O_YRes := Stream.Position;
        Stream.Write(Y_Res_Value, sizeof(Y_Res_Value));
        O_Soft := Stream.Position;
        Stream.Write(Software, sizeof(Software));
        O_Strip := Stream.Position;
        if Height < 0 then
          for I := 0 to Height - 1 do
          begin
            BitsPtr := Bits + I * BmpWidth;
            Stream.Write(BitsPtr^, DataWidth);
          end
        else
          for I := 1 to Height do
          begin
            BitsPtr := Bits + (Height - I) * BmpWidth;
            Stream.Write(BitsPtr^, DataWidth);
          end;
        D_COL[6]._Value := O_Strip;
        D_COL[10]._Value := O_XRes;
        D_COL[11]._Value := O_YRes;
        D_COL[13]._Value := O_Soft;
        O_Dir := Stream.Position;
        Stream.Write(NoOfDirs, sizeof(NoOfDirs));
        Stream.Write(D_COL, sizeof(D_COL));
        Stream.Write(NullString, sizeof(NullString));
        Stream.Seek(4, soFromBeginning);
        Stream.Write(O_Dir, sizeof(O_Dir));
      end;
      if BitCount in [24, 32] then
      begin
        D_RGB[1]._Value := LongInt(Width);
        D_RGB[2]._Value := LongInt(Height);
        D_RGB[8]._Value := LongInt(Height);
        D_RGB[9]._Value := LongInt(3 * Width * Height);
        Stream.Write(TifHeader, sizeof(TifHeader));
        O_XRes := Stream.Position;
        Stream.Write(X_Res_Value, sizeof(X_Res_Value));
        O_YRes := Stream.Position;
        Stream.Write(Y_Res_Value, sizeof(Y_Res_Value));
        O_BPS := Stream.Position;
        Stream.Write(BitsPerSample, sizeof(BitsPerSample));
        O_Soft := Stream.Position;
        Stream.Write(Software, sizeof(Software));
        O_Strip := Stream.Position;
        for I := 0 to Height - 1 do
        begin
          BitsPtr := Bits + I * BmpWidth;
          for K := 0 to Width - 1 do
          begin
            Blue := (BitsPtr)^;
            Red := (BitsPtr + 2)^;
            (BitsPtr)^ := Red;
            (BitsPtr + 2)^ := Blue;
            BitsPtr := BitsPtr + BitCount div 8;
          end;
        end;
        if BitCount = 32 then
          for I := 0 to Height - 1 do
          begin
            BitsPtr := Bits + I * BmpWidth;
            TmpBitsPtr := BitsPtr;
            for k := 0 to Width - 1 do
            begin
              (TmpBitsPtr)^ := (BitsPtr)^;
              (TmpBitsPtr + 1)^ := (BitsPtr + 1)^;
              (TmpBitsPtr + 2)^ := (BitsPtr + 2)^;
              TmpBitsPtr := TmpBitsPtr + 3;
              BitsPtr := BitsPtr + 4;
            end;
          end;
        BmpWidth := Trunc(BitsSize / Height);
        if Height < 0 then
          for I := 0 to Height - 1 do
          begin
            BitsPtr := Bits + I * BmpWidth;
            Stream.Write(BitsPtr^, Width * 3);
          end
        else
          for I := 1 to Height do
          begin
            BitsPtr := Bits + (Height - I) * BmpWidth;
            Stream.Write(BitsPtr^, Width * 3);
          end;
        D_RGB[3]._Value := O_BPS;
        D_RGB[6]._Value := O_Strip;
        D_RGB[10]._Value := O_XRes;
        D_RGB[11]._Value := O_YRes;
        D_RGB[14]._Value := O_Soft;
        O_Dir := Stream.Position;
        Stream.Write(NoOfDirs, sizeof(NoOfDirs));
        Stream.Write(D_RGB, sizeof(D_RGB));
        Stream.Write(NullString, sizeof(NullString));
        Stream.Seek(4, soFromBeginning);
        Stream.Write(O_Dir, sizeof(O_Dir));
      end;
    end;
  finally
    FreeMem(Header);
  end;
end;

procedure TfrImgFltSet.Localize;
begin
  Ok.Caption := frLoadStr(SOk);
  Cancel.Caption := frLoadStr(SCancel);
  Caption := frLoadStr(frRes + 1878);
  GroupPageRange.Caption := frLoadStr(frRes + 44);
  Label7.Caption := frLoadStr(frRes + 47);
  label1.Caption := frLoadStr(frRes + 48);
  GroupBox1.Caption := frLoadStr(frRes + 1879);
  Label2.Caption := frLoadStr(frRes + 1880);
  CropPage.Caption := frLoadStr(frRes + 1881);
  Mono.Caption := frLoadStr(frRes + 1882);
end;

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


end.