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 적용
기존 출력시 이미지 빠지는거 해결이 되었음
