이미지 빠지지 않는 QuickReport 용 TQRImage 호환

HogeQRImage.pas

http://ari-memo.seesaa.net/article/161535795.html

-----------------------------------------------------------------------------------

今更Delphi7？(^^;
昨日Delphi XEが発売されたがな～！という話は置いといて(^^;

仕事上、どうしても必要で調査＆作成。

○手法
　１）VCLのDrawを回避、自力描画
　　「中村の里」　http://www.asahi-net.or.jp/~HA3T-NKMR/tips004.htm　がベースです。
　２）Delphiのメモリ管理を回避
　　SetLengthをGlobalAlloc(API)に変更
　　Delphi-ML　http://leed.issp.u-tokyo.ac.jp/~takeuchi/delphi/browse.cgi?index=063699&back=http%3A%2F%2Fw3%2Esfdata%2Ene%2Ejp%2FML%2FCB%2Fmsg25648%2Ehtml　がベースです。

　どちらも中村さんの調査と発表がなければ到底回避できませんでした。本当に感謝です m(__)m

○前提・制限
　・Delphi7&添付のQuickReportでしか試していません。
　・2000/XPで動作確認。
　・Metafileは非対応(元の処理に丸投げ)
　・『画像が抜けない』は飽くまで当方での調査結果からの話であり、皆様の所でも
必ず同じ状況が起こる、または起こらない事を保証するものではありません。
　・無保証・自己責任でお使い下さい(お約束)
　・商用/非商用問わず、ソースの改変などご自由に。

---------------------------------
ダウンロード: HogeQRImage.pas
---------------------------------

// 適当な名前に置換して下さい
unit HogeQRImage;

interface

uses
  Windows, Classes, Graphics, JPEG, Math, SysUtils, Dialogs, Forms,
  qrctrls, quickrpt, qrprntr, SyncObjs;

// Cardinalで戻して欲しいので自己定義
function KStretchDIBits(DC: HDC; DestX, DestY, DestWidth, DestHeight, SrcX,
  SrcY, SrcWidth, SrcHeight: Integer; Bits: Pointer; var BitsInfo: TBitmapInfo;
  Usage: UINT; Rop: DWORD): Cardinal; stdcall; external gdi32 name 'StretchDIBits';

type
  // 適当な名前に置換して下さい
  THogeQRImage = class(TQRImage)
  protected
    procedure Print(OfsX, OfsY : integer); override;
  end;

procedure Register;

implementation

uses StrUtils;

var
  CRITICAL_SECTION: TCriticalSection;

procedure Register;
begin
  RegisterComponents('QReport', [THogeQRImage]);	// 適当な名前に置換して下さい
end;

// ここで調査記録
procedure WriteLog(sLog: string);
begin
  // 必要があればロジックを埋めて下さい
end;

// APIエラーの内容取得(汎用)
function GetAPIErrorMessage(caError: cardinal): string;
const
  MAX_BUF = 1024;
var
  buf: PChar;
begin
  result := '[' + CurrToStr(caError) + ']';
  Buf := AllocMem(MAX_BUF);
  try
    FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, caError, 0, buf, MAX_BUF, nil);
    result := result + buf;
  finally
    FreeMem(Buf);
  end;
end;

// 最終APIエラーの内容取得
function GetLastAPIErrorMes(): string;
begin
  result := GetAPIErrorMessage(GetLastError);
end;

// 中村さんTipsから
//   API結果判定(失敗時、例外を投げるように) 2010.06.03 Edit(ARI)
procedure StretchDrawBitmap(Canvas:TCanvas;  // 描画先キャンバス
                            r : TRect;       // 描画先範囲
                            Bitmap:TBitmap); // ビットマップ
const
  InfoSize = SizeOf(TBitmapInfoHeader) + 4 * 256;
var
  OldMode   : integer;      // StretchModeの保存用
  pInfo     : PBitmapInfo;  // DIBヘッダ＋カラーテーブルへのポインタ

  InfoData  : array[0..InfoSize-1] of Byte; // DIBヘッダ＋カラーテーブル
  Image     : PByte;        // DIBのピクセルデータ
  DC        : HDC;          // GetDIBits 用 Device Context
  OldPal    : HPALETTE;     // パレット保存用

  ret: cardinal;
  nSize: integer;
begin
    SetLastError(0);

    pInfo :=@InfoData;

    // 24 Bit DIB の領域を確保
    nSize := ((Bitmap.Width * 24 + 31) div 32) * 4 * Bitmap.Height;
    Image := PByte(GlobalAlloc(GMEM_FIXED or GMEM_ZEROINIT, nSize));

    if Image = nil then begin
      // メモリ確保失敗、再チャレンジ
      Image := PByte(GlobalAlloc(GMEM_FIXED or GMEM_ZEROINIT, nSize));
      if Image = nil then begin
        // 再チャレンジも失敗
        raise Exception.Create('GlobalAlloc = nil : ' + GetLastAPIErrorMes());
      end;
    end;

    try
      // DIB のBitmapInfoHeader を初期化
      with pInfo^.bmiHeader do begin
        biSize := SizeOf(TBitmapInfoHeader);
        biWidth := Bitmap.Width;     biHeight := Bitmap.Height;
        biPlanes := 1;               biBitCount := 24;
        biCompression := BI_RGB;
      end;

      // 24bpp DIB イメージを取得
      DC := GetDC(0);
      if DC = 0 then begin
        // 失敗
        raise Exception.Create('GetDC = nil : ' + GetLastAPIErrorMes());
      end;

      try
        OldPal := 0;
        if Bitmap.Palette <> 0 then begin
          OldPal := SelectPalette(DC, Bitmap.Palette, True);
          if OldPal = 0 then begin
            // 失敗
            raise Exception.Create('SelectPalette = nil : ' + GetLastAPIErrorMes());
          end;
        end;

        if GetDIBits(DC, Bitmap.Handle, 0, Bitmap.Height,
                  Image, pInfo^, DIB_RGB_COLORS) = 0 then begin
          // 失敗
          raise Exception.Create('GetDIBits = 0 : ' + GetLastAPIErrorMes());
        end;

        if OldPal <> 0 then SelectPalette(DC, OldPal, True);
      finally
        ReleaseDC(0, DC);
      end;

      // StretchDIBits
      //   ※SetStretchBltModeはStretchDIBitsには不要と思われる。当方では問題は起きていない。
      ret := KStretchDIBits(Canvas.Handle,
                    r.Left,r.Top,r.Right-r.Left,r.Bottom-r.Top,
                    0,0,pInfo^.bmiHeader.biWidth,pInfo^.bmiHeader.biHeight,
                    Image,pInfo^,DIB_RGB_COLORS,SRCCOPY);

      if (ret = 0) or (ret = GDI_ERROR) then begin
        // 失敗
        raise Exception.Create('KStretchDIBits = ' + CurrToStr(ret) + ' : ' + GetLastAPIErrorMes());
      end;

    finally
      GlobalFree(THandle(Image));
    end;
end;

procedure THogeQRImage.Print(OfsX, OfsY: integer);
const
  MAX_RETRY: integer = 10;
  SLEEP_SHORT: integer = 20;
var
  Dest : TRect;
  bmp: TBitmap;
  DC, SavedDC : THandle;

  bPreview: boolean;
  bPrepare: boolean;
  sStatus: string;

  nRetry: integer;
  caPreError: cardinal;

  procedure AssignBmp();
  begin
    if Picture.Graphic is TBitmap then begin
      bmp.Assign(Picture.Bitmap);
    end
    else begin
      bmp.Assign(Picture.Graphic);
    end;

    // 24bitにする
    bmp.PixelFormat := pf24Bit;
  end;

begin
  CRITICAL_SECTION.Enter;
  try
    // ここまでのエラーコード
    caPreError := GetLastError();

    if Picture.Graphic is TMetafile then begin
      // TMetafileは、わからんので元の処理に丸投げして終了
      inherited Print(OfsX,OfsY);
      exit;
    end;

    if Picture.Graphic = nil then begin
      // 元画像がnilの場合、わからんので元の処理に丸投げして終了
      inherited Print(OfsX,OfsY);
      exit;
    end;

    if Picture.Graphic.Empty then begin
      // 元画像が空の場合、わからんので元の処理に丸投げして終了
      //   全面白の画像はEmpty扱いになるようだ
      inherited Print(OfsX,OfsY);
      exit;
    end;

    bPreview := ParentReport.QRPrinter.ShowingPreview;
    bPrepare := (not bPreview) and (ParentReport.QRPrinter.Destination = qrdMetafile);

    if bPreview then begin
      sStatus := '[Preview]';
    end
    else if bPrepare then begin
      sStatus := '[Prepare]';
    end
    else begin
      sStatus := '[Print]';
    end;

    if (not AutoSize) and bPrepare then begin
      // わざわざ後の処理をやる必要はない
      //   ※...と思っている。
      //   ※当方では問題は起きていないが不安な人は、このブロック取り払って下さい。
      exit;
    end;

    bmp := TBitmap.Create;
    try
      Dest.Top := QRPrinter.YPos(OfsY + Size.Top);
      Dest.Left := QRPrinter.XPos(OfsX + Size.Left);
      Dest.Right := QRPrinter.XPos(OfsX + Size.Width + Size.Left);
      Dest.Bottom := QRPrinter.YPos(OfsY + Size.Height + Size.Top);

      // とりあえずBitmapにする
      AssignBmp();

      if bmp.Empty then begin
        WriteLog('！bmp.Empty = true');
      end;

      // ※以下の繰り返し処理は、リトライで何とか復旧を試みていた頃の名残り。
      // ※現在はリトライのお世話にはなっていないけど、わざわざ消す程でもないので残している。
      // ※不要と思われる方は(ログ取りなど含めて)削除して下さい。

      if Stretch then begin
        nRetry := 0;

        while nRetry <= MAX_RETRY do begin
          try
            StretchDrawBitmap(QRPrinter.Canvas, Dest, bmp);
            break;
          except
            on E: Exception do begin
              Inc(nRetry);
              WriteLog(IntToStr(nRetry) + '回目失敗 - ' + sStatus + E.Message);
              Application.ProcessMessages;
              Sleep(SLEEP_SHORT);

              if (nRetry mod 2) = 0 then begin
                // 偶数回の失敗時、bmpの再生成
                bmp.Free;
                bmp := TBitmap.Create;
                AssignBmp();
              end;

              if nRetry = (MAX_RETRY + 1) then begin
                // 上限到達
                WriteLog('Print前 - ' + GetAPIErrorMessage(caPreError));
              end;
            end;
          end;
        end;
      end
      else begin
        IntersectClipRect(QRPrinter.Canvas.Handle, Dest.Left, Dest.Top, Dest.Right, Dest.Bottom);
        DC := GetDC(QRPrinter.Canvas.Handle);
        SavedDC := SaveDC(DC);
        try
          Dest.Right := Dest.Left +
            round(Picture.Width / Screen.PixelsPerInch * 254 * ParentReport.QRPrinter.XFactor);
          Dest.Bottom := Dest.Top +
            round(Picture.Height / Screen.PixelsPerInch * 254 * ParentReport.QRPrinter.YFactor);
          if Center then OffsetRect(Dest, (QRPrinter.XSize(Size.Width) -
              round(Picture.Width / Screen.PixelsPerInch * 254 * ParentReport.QRPrinter.XFactor)) div 2,
            (QRPrinter.YSize(Size.Height) -
              round(Picture.Height / Screen.PixelsPerInch * 254 * ParentReport.QRPrinter.YFactor)) div 2);

          nRetry := 0;

          while nRetry <= MAX_RETRY do begin
            try
              StretchDrawBitmap(QRPrinter.Canvas, Dest, bmp);
              break;
            except
              on E: Exception do begin
                Inc(nRetry);
                WriteLog(IntToStr(nRetry) + '回目失敗 - ' + sStatus + E.Message);
                Application.ProcessMessages;
                Sleep(SLEEP_SHORT);

                if (nRetry mod 2) = 0 then begin
                  // 偶数回の失敗時、bmpの再生成
                  bmp.Free;
                  bmp := TBitmap.Create;
                  AssignBmp();
                end;

                if nRetry = (MAX_RETRY + 1) then begin
                  // 上限到達
                  WriteLog('Print前 - ' + GetAPIErrorMessage(caPreError));
                end;
              end;
            end;
          end;

        finally
          RestoreDC(DC, SavedDC);
          SelectClipRgn(QRPrinter.Canvas.Handle, 0);
        end;
      end;

    finally
      bmp.Free;
    end;

  finally
    CRITICAL_SECTION.Leave;
  end;
end;

initialization
  CRITICAL_SECTION := TCriticalSection.Create;

finalization
  CRITICAL_SECTION.Free;

end.

----------------------------------------------------------------------------------------------

delphi xe2 적용 

기존 출력시 이미지 빠지는거 해결이 되었음