[delphi-users:1238] 今更Delphi7のQuickReportの画像抜けの話
ありい
仕事の都合でD7用TQRImage互換の画像抜けしない(※１)コンポを作りました。
ここに至るまでには色々ありましたが、とりあえず当方では画像抜けゼロを達
成しています。
そんな訳で物凄い今更感はありますが、ひょっとすると助かる人が居るかもし
れない＆後述の
調査・発表をされている中村さんへの敬意と感謝を込めて公開させて頂きたいと
思います。
※１ 「画像抜けしない」とは、APIの失敗による描画失敗が発生していない事を
指します。
当方の実験では稀にプリンター側の問題(※２)で画像抜けが発生する事が
ありました。
当然ですが、このケースには対応できません。
※２ 印刷スプーラのファイルには画像が入っている事を確認しています。
○手法
１）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
がベースです。
どちらも中村さんの調査と発表がなければ到底回避できませんでした。
○前提・制限
・Delphi7&添付のQuickReportでしか試していません。
・2000/XPで動作確認。
・Metafileは非対応(元の処理に丸投げ)
・上記は飽くまで当方での調査結果からの話で、皆様の所でも必ず同じ状況が
起こる、または起こらない事を
保証するものではありません。無保証・自己責任でお使い下さい(お約束)
・商用/非商用問わず、ソースの改変などご自由に。
---------------------------------------------------------------------------------
// 適当な名前に置換して下さい
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.
MLホームページ: http://www.freeml.com/delphi-users
----------------------------------------------------------------------
おもしろ写真を撮ったらMLにアップしよう！
http://ad.freeml.com/cgi-bin/sa.cgi?id=f9WbT
-----------------------------------------------------[freeml by GMO]--
hirodel
WindowsXP
Delphi2010
StringGridにおいて、各列の右寄せ左寄せを下記の様に行っておりましたが
右寄せした項目が
（[ANO ANO]みたいに）二重の表示になってしまいます 解決方法は有るのでしょうか？
また、「StringGrid1DrawCell」イベント以外でも右寄せ左寄せの方法は有るのでしょうか？
procedure StGrid.StringGrid1DrawCell(Sender: TObject; ACol,
ARow: Integer; Rect: TRect; State: TGridDrawState);
var
DRect: TRect;
Mode: Integer;
begin
{
Cells[ 0,0]:='ANO';//
Cells[ 1,0]:='月日';//
Cells[ 2,0]:='項目';//
Cells[ 3,0]:='単価';//
Cells[ 4,0]:='数量';//
Cells[ 5,0]:='金額';//
}
StringGrid1.Canvas.FillRect(Rect);
DRect.Top := Rect.Top + 2;
DRect.Left := Rect.Left + 2;
DRect.Right := Rect.Right - 2;
DRect.Bottom:= Rect.Bottom - 2;
if (ACol = 0)or
(ACol = 3)or
(ACol = 4)or
(ACol = 5)
then
begin
Mode := DT_RIGHT;
end
else if (ACol = 1) or
(ACol = 2) then //右寄せはDT_RIGHT DT_LEFT
begin
Mode := DT_LEFT;
end;
DrawText(StringGrid1.Canvas.Handle, PChar(StringGrid1.Cells[ACol,ARow]),
Length(StringGrid1.Cells[ACol,ARow]), DRect, Mode);
end;
MLホームページ: http://www.freeml.com/delphi-users
----------------------------------------------------------------------
メーリス初！freemlなら絵文字が友達に届く！
http://ad.freeml.com/cgi-bin/sa.cgi?id=fUkYx
中村＠ブレーン
多分あっちこっちに参考ソースが有ると思いますが、
DefaultDraw = True の場合、文字やセル枠がデフォルト位置に描かれてから
OnDrawCell が起きます。ですから
1) セル枠の内側を塗りつぶしてから文字を描く。
2) DefaultDraw = False で頑張る。
の2通りのやり方があります。
hirodel さんは書きました:
----------
東京都 日野市 中村拓男
MLホームページ: http://www.freeml.com/delphi-users
----------------------------------------------------------------------
ベジモンゲットだぜ！ゆるカワなベジモンと新しい農場ライフ♪
http://ad.freeml.com/cgi-bin/sa.cgi?id=fUmkB