2010年09月04日

[Delphi 7]画像抜けしないQuickReport用TQRImage互換(条件あり)コンポ

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

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

○手法
 1)VCLのDrawを回避、自力描画
  「中村の里」 http://www.asahi-net.or.jp/~HA3T-NKMR/tips004.htm がベースです。
 2)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.
posted by ありい at 13:35| Comment(4) | TrackBack(0) | Delphi | このブログの読者になる | 更新情報をチェックする
この記事へのコメント
始めまして。渡辺といいます。
Quickreportでの画像抜け事象で困っていて、このページにたどり着きました。
ただ、私の力では、このHogeQRImageをどう使ったらよいのかわかりません。すみませんが、使い方について解説をお願いできませんでしょうか。
Posted by 渡辺 at 2011年10月21日 14:20
渡辺さん、コメントありがとうございます(^^)

#嬉しい初コメントです!

使い方ですが、

 1)ダウンロード:HogeQRImage.pas をクリックして適当なフォルダに保存

 2)ファイル名を含めて、HogeQRImageを適当な名前に変更
   ※しなくても構いませんけど...(^^; 

 3)その後、Delphiで「コンポーネントのインストール」で取り込むと「QReport」タブに追加されます
   ※2)手順で33行目:RegisterComponents('QReport', [THogeQRImage]); で他のタブに変える事が可能です

 4)作成したプログラムのTQRImageを↑と差し替え

上記の手順で、当方ではピタっと抜けがおさまりました。渡辺さんの環境でも抜けなくなると良いですね!

#一応、注意事項をご参照下さい。あとテストは充分行ってくださいね。

また結果をコメントして頂けたら嬉しいです!
Posted by ありい at 2011年10月22日 06:57
うまくゆきました。
windows7 + DelphiXE2 + Quickreport Ver5.05.1です。
いくつかの帳票のQRImageをHogeQRImageに置き換えした。
改修前にはPDFに書き出してテストをすると、気まぐれに画像がとんだものが、改修後では画像の抜けは起きていません。印刷ではばっちりです。
ただ、一部の帳票のプレビューで、画像が汚く表示をされます。試にQRImageとHogeQRImageを並べて表示をするとHogeQRImageだけが汚く表示されるのです。原因不明です。
とりあえず、印刷ではきれいに出ますので、実用的にはHogeQRImageをつかわせていただいて解決です。
どうもありがとうございました。
Posted by 渡辺 at 2011年10月22日 15:18
早速試して頂いて、ありがとうございます!
画像抜けは解決したようで、とりあえず良かったです(^^)

> ただ、一部の帳票のプレビューで、画像が汚く表示をされます。試にQRImageとHogeQRImageを並べて表示をするとHogeQRImageだけが汚く表示されるのです。原因不明です。

あらら、プレビューですかぁ...ちょっと予想が付かないです、申し訳ありません... m(__)m

> とりあえず、印刷ではきれいに出ますので、実用的にはHogeQRImageをつかわせていただいて解決です。

お役に立てたようで何よりです(^^)
Posted by ありい at 2011年10月22日 20:39
コメントを書く
お名前:

メールアドレス:

ホームページアドレス:

コメント:

認証コード: [必須入力]


※画像の中の文字を半角で入力してください。
※ブログオーナーが承認したコメントのみ表示されます。
この記事へのトラックバックURL
http://blog.seesaa.jp/tb/161535795
※ブログオーナーが承認したトラックバックのみ表示されます。

この記事へのトラックバック
×

この広告は1年以上新しい記事の投稿がないブログに表示されております。