TPaintBoxで図形を拡大／縮小表示するには
解決Delphi 5, WindoswXPの環境です。
フォームにTPaintBoxを貼り付け、MovoTo,LineToで線を描画します。
この描画した図形を拡大／縮小表示するには、どのようにすればいい
でしょうか。拡大／縮小のボタンをフォームに配置し、各ボタンを押すと
拡大／縮小するようにしたいと思っております。
よろしくお願いします。
PaintBox はその下のキャンバスに直接描画しているので
PaintBox に描画した内容だけを拡大縮小する事は出来ません。
PaintBoxの下に Panel や Memo 等を配置した状態で
PaintBox1.Canvas.CopyRect(Rect(0,0,200,200),PaintBox1.Canvas,Rect(0,0,100,100));
をやるとわかると思いますが・・・
TImage を使用して下さい
KHE00221さん。ご回答ありがとうございます。
PaintBox1.Canvas.CopyRect(Rect(0,0,200,200),PaintBox1.Canvas,Rect(0,0,100,100));
をやってみました。(0,0,100,100)の領域の図形が(0,0,200,200)に拡大
されました。PaintBoxのみの拡大／縮小はできないということですね。
TImageであれば、TImage全体の領域に拡大／縮小することは可能でしょうか。
可能であれば、その方法を教えていただけますでしょうか。
よろしくお願いします。
TImage で全体イメージを拡大したいのならば
Image1.Stretch := True; としたうえで
//２倍
Image1.Width := Image1.Picture.Width * 2;
Image1.Height := Image1.Picture.Height * 2;
//１倍
Image1.Width := Image1.Picture.Width * 1;
Image1.Height := Image1.Picture.Height * 1;
//半分
Image1.Width := Image1.Picture.Width div 2;
Image1.Height := Image1.Picture.Height div 2;
でできるけど？
KHE00221さん。ありがとうございます。
教えていただいたコードを実行すると、元のイメージコンポーネント
も拡大／縮小されます。
私の説明不足でしたが、元のイメージコンポーネントはそのままで
中身（描画した図形）だけを拡大／縮小したいのです。
よろしくお願いします。
無茶を言わない
16x16 のイメージを 16x16 のまま拡大表示(2倍)できると思う？
4x4部分しか表示しないなら別だけど
>中身（描画した図形）だけを拡大／縮小したいのです。
できますよ。
TImage は、内部に抱えた画像をウィンドウズから受け取る描画命令に自動的に同期して
表示するクラスです。TImage のサイズと内部の画像のサイズは独立していますから
TImage のサイズに関係なく、画像を任意のサイズに変更できます。
Jpeg 画像をロードして、その縦横を０．６倍する例を示します。
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtDlgs, ExtCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
OpenPictureDialog1: TOpenPictureDialog;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private 宣言 }
public
{ Public 宣言 }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
Jpeg;
procedure TForm1.Button1Click(Sender: TObject);
var
jpg: TJpegImage;
begin
if OpenPictureDialog1.Execute then
begin
jpg := TJpegImage.Create;
try
jpg.LoadFromFile(OpenPictureDialog1.FileName);
Image1.Picture.Bitmap.Assign(jpg);
finally
jpg.Free;
end;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
bmp:TBitmap;
begin
if Assigned(Image1.Picture.Bitmap) then
begin
bmp := TBitmap.Create;
try
bmp.Assign(Image1.Picture.Bitmap);
bmp.Width := Round(Image1.Picture.Bitmap.Width * 0.6);
bmp.Height := Round(Image1.Picture.Bitmap.Height * 0.6);
bmp.Canvas.StretchDraw(Rect(0, 0, bmp.Width, bmp.Height),Image1.Picture.Bitmap);
Image1.Picture.Bitmap.Assign(bmp);
finally
bmp.Free;
end;
end;
end;
end.
ところで
ペイントツールでも作ろうとしているのかな？
KHE00221さん、junkiさんご回答ありがとうございます。
ご返事が遅くなり、すみません。
KHE00221さん。
>ペイントツールでも作ろうとしているのかな？
そのような高級なツールをつくろうとは、しておりません。
単に図形の縮小／拡大をしたいと考えています。
junkiさん。
示されたコードを実行すると、JPGの画像が縮小されることが確認
できました。拡大のほうもつくりましたが、こちらのほうは
縮小してから拡大すると、画像がつぶれました。
junkiさんのＨＰを拝見しますと（画像の拡大は）、かなり難解だと思われ ました。
今回は、Imageに線と四角形を描画してそれを縮小／拡大したかったので
下記のコードで実現できそうなので、これで解決とさせていただきます。
procedure TForm1.Button1Click(Sender: TObject);
begin
Image1.Canvas.MoveTo(10,10);
Image1.Canvas.LineTo(100,100);
Image1.Canvas.Rectangle(100, 100, 150, 150);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
bmp:TBitmap;
begin
bmp := TBitmap.Create;
try
bmp.Width := Image2.Width;
bmp.Height := Image2.Height;
bmp.Canvas.CopyRect(Image1.Canvas.ClipRect, Image1.Canvas, Image1.Canvas.ClipRect);
StretchBlt(Image2.Canvas.Handle, 0,0, Round(Image1.Width*0.8), Round(Image1.Height*0.8),
bmp.Canvas.Handle, 0,0, bmp.Width, bmp.Height, SRCCOPY);
finally
bmp.Free;
end;
end;
KHE00221さん、junkiさん
ご教示いただきありがとうございました。
ペイントツールではなく，
単に，図形を描いて，それを拡大縮小表示するのであれば，メタファイルを利用
する方法もあります．メタファイルは拡大縮小してもギザギザになりません．
参考までに．
新規プロジェクトに以下を配置
TButton 1つ
TImage 1つ
動作確認環境 WindowsXP(SP2) + Delphi 7 Pro
//=============================================================================
// メタファイルに文字列と四角形を描き，それをImage1に表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
AMetaFile : TMetafile;
ACanvas : TMetaFileCanvas;
AWidth : Integer;
AHeight : Integer;
begin
Self.VertScrollBar.Visible := False;
Self.HorzScrollBar.Visible := False;
Image1.Stretch := True;
Image1.Picture.Assign(nil);
AMetaFile:=TMetafile.Create;
AMetaFile.Width := Image1.Width;
AMetaFile.Height := Image1.Height;
try
ACanvas:=TMetafileCanvas.Create(AMetaFile,0);
try
//Canvasの全領域を塗潰す
ACanvas.Brush.Color := clSilver;
ACanvas.FillRect(ACanvas.ClipRect);
//指定サイズの文字サイズで文字を描く
ACanvas.Font.Size := 50;
ACanvas.Brush.Style:=bsClear;
ACanvas.TextOut(0,0,'Delphi');
//四角形を描画
ACanvas.Pen.Width := 6;
ACanvas.Pen.Color := clGreen;
ACanvas.Rectangle(30,10,130,70);
finally
ACanvas.Free;
end;
Image1.Picture.Assign(AMetaFile);
finally
AMetaFile.Free;
end;
end;
//=============================================================================
// Image1のサイズを変更する
// Stretch=TrueでPicture.Assignしているのでメタファイルも拡大縮小表示
// メタファイの元サイズには変更なし
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
ASize : Double;
begin
ASize := 1.2;
Image1.Width := Trunc(Image1.Width * ASize);
Image1.Height := Trunc(Image1.Height * ASize);
end;
end.
>中身（描画した図形）だけを拡大／縮小したいのです。
最初に描画した内容をそのままにしたいのであれば，メタファイルの場合，
保存，読出しも簡単です．
ちょっと，質問の意味とは違うかも知れませんが...
保存の例(先のコードを修整)
finally
ACanvas.Free;
end;
Image1.Picture.Assign(AMetaFile);
AMetaFile.SaveToFile('TestMeta.emf');
Mr.XRAYさん。
解決済みにしたにもかかわらず、教えていただきありがとうございます。
確かに、解決済み時のこーどではギザギザになってしまいました。
Mr.XRAYさんのコードで実行するとなめらかに拡大／縮小ができました。
また、メタファイルを保存しそれを再表示するのは、
procedure TForm1.Button4Click(Sender: TObject);
var
AMetaFile : TMetafile;
begin
AMetaFile:=TMetafile.Create;
try
AMetaFile.LoadFromFile('TestMeta.emf');
Image1.Picture.Assign(AMetaFile);
finally
AMetaFile.Free;
end;
end;
で出来ました。
あと１つ質問させていただきますと、拡張／縮小したImage1のある矩形領域
を別のImage2にそのままコピーすることはできるでしょうか。
Image2を配置し
procedure TForm1.Button3Click(Sender: TObject);
var
rc: TRect;
begin
rc.Left := 10;
rc.Top := 10;
rc.Right := rc.Left + Image2.Width;
rc.Bottom := rc.Top + Image2.Height;
with Image2.Canvas do
begin
CopyRect(ClipRect, Image1.Canvas, rc)
end;
end;
を実行すると
'ビットマップを持っているときのみイメージの変更が可能です'
というデバッガのエラーが出ます。
厚かましい質問ですみませんが、よろしくお願いします。
ラスタデータ ＝ ピクセルごとに色情報を持つデータ
ベクタデータ ＝ 座標を指定してどの色でどの太さでどう線を引く、とかいうデータ
TBitmap はラスタデータ
Metafile はベクタデータのためのオブジェクト
TCanvas は、ラスタデータ、ベクタデータを描くための土台、紙みたいなもの
CopyRect は TCanvas のメソッドで、描かれているラスタデータのコピー
だから、Metafile の一部分だけコピーすることはできない。
コピー先のクリップリージョンの矩形にメタファイルを描くだけ。
プログラマは、コピー元のキャンバスに描かれているメタファイルの内容を知っているはず。
レスの仕方が適切でなかったようです．
>単に，図形を描いて，それを拡大縮小表示するのであれば，メタファイルを利用
これは，拡大縮小するだけであれば，と解釈して下さい．
Image1に表示しているメタファイルの一部分を他のTImageに描画するには工夫が必要
です．
私のレスでは
Image1.Picture.Assign(AMetaFile);
としていますが，場合によっては，
Image1.StretchDraw
等を使用する必要があるかも知れません(この時は拡大縮小のたびに際描画が必要)．
方法については，SHさんが，どんな画像を扱い，どんなことをされたいのか，もう
少し見えてこないと，何とも言えません．
また，画像の種類(Bitmap,MetaFile)の知識も必要かも知れません．
先のレスは，あくまでも「拡大縮小で滑らかに」という趣旨のものです．あしからず．
procedure TForm1.Button1Click(Sender: TObject);
const
RATIO = 4.000;
var
mf: TMetafile;
rc, rc2: TRect;
ACanvas: TMetaFileCanvas;
AWidth : Integer;
AHeight: Integer;
begin
Image1.Stretch := False;
Image2.Stretch := False;
Image3.Stretch := False;
Image1.Picture.Assign(nil);
Image2.Picture.Assign(nil);
Image3.Picture.Assign(nil);
mf := TMetafile.Create;
mf.Width := Image1.Width;
mf.Height := Image1.Height;
try
ACanvas := TMetafileCanvas.Create(mf, 0);
try
ACanvas.Brush.Color := clYellow;
ACanvas.FillRect(ACanvas.ClipRect);
ACanvas.Font.Size := 110;
ACanvas.Brush.Style := bsClear;
ACanvas.TextOut(50, 40, 'Delphi MetaFile');
ACanvas.Pen.Width := 6;
ACanvas.Pen.Color := clFuchsia;
ACanvas.Rectangle(50, 40, 440, 197);
finally
ACanvas.Free;
end;
Image1.Picture.Assign(mf);
Application.ProcessMessages;
Sleep(1000);
// 図形を1/4に縮小
mf.Width := Round(mf.Width / RATIO);
mf.Height := Round(mf.Height / RATIO);
Image1.Picture.Assign(mf);
// Image2に部分描画
Image2.Width := 100;
Image2.Height := 40;
Image2.Picture.Bitmap.Width := 100;
Image2.Picture.Bitmap.Height := 40;
Image2.Canvas.Draw(-10, -10, mf);
// Image3に部分コピー
Image1.Picture.Bitmap.Width := Image1.Width;
Image1.Picture.Bitmap.Height := Image1.Height;
Image1.Canvas.Draw(0, 0, mf);
Image3.Width := 100;
Image3.Height := 40;
rc.Left := 10;
rc.Top := 10;
rc.Right := rc.Left + Image3.Width;
rc.Bottom := rc.Top + Image3.Height;
with Image3.Canvas do begin
CopyRect(ClipRect, Image1.Canvas, rc);
end;
Application.ProcessMessages;
Sleep(1000);
// 図形を元に戻す
mf.Width := Round(mf.Width * RATIO);
mf.Height := Round(mf.Height * RATIO);
Image1.Picture.Assign(mf);
// mf.SaveToFile(METAFILE);
finally
mf.Free;
end;
end;
うんとさん、Mr.XRAYさん、尋ねよ、さらば見出さんさん ご回答ありがとうございます。
ビットマップとメタファイルについて調べてみました。
１．ビットマップは、ピクセルと呼ばれる小さい正方形をイメージの最小
単位として。各ピクセルの色情報を格納したバイト型の配列である。
２．メタファイルは、イメージをベクターベースの型式で保存したものであ る。イメージの描画方法に関する指示の集合を保存する。
私が、扱おうとしているのは画像データではなく、単にキャンバスに
MoveTo,LineTo等で描画した線／図形を拡大／縮小したいと考えております。
Mr.XRAYさん、尋ねよ、さらば見出さんさん のコードを合わせて以下の
コードで拡大／縮小した図形のある矩形領域を別のイメージにコピーする
ことが出来ました。
procedure TForm1.Button1Click(Sender: TObject);
var
AMetaFile : TMetafile;
ACanvas : TMetaFileCanvas;
AWidth : Integer;
AHeight : Integer;
rc: TRect;
begin
Self.VertScrollBar.Visible := False;
Self.HorzScrollBar.Visible := False;
Image1.Stretch := True;
Image1.Picture.Assign(nil);
AMetaFile:=TMetafile.Create;
AMetaFile.Width := Image1.Width;
AMetaFile.Height := Image1.Height;
try
ACanvas:=TMetafileCanvas.Create(AMetaFile,0);
try
//Canvasの全領域を塗潰す
ACanvas.Brush.Color := clSilver;
ACanvas.FillRect(ACanvas.ClipRect);
//指定サイズの文字サイズで文字を描く
ACanvas.Font.Size := 50;
ACanvas.Brush.Style:=bsClear;
ACanvas.TextOut(0,0,'Delphi');
//四角形を描画
ACanvas.Pen.Width := 6;
ACanvas.Pen.Color := clGreen;
ACanvas.Rectangle(30,10,130,70);
//直線を画
ACanvas.MoveTo(10,10);
ACanvas.LineTo(100,100);
//四角形を描画
ACanvas.Rectangle(100, 100, 150, 150);
finally
ACanvas.Free;
end;
Image1.Picture.Assign(AMetaFile);
AMetaFile.Width := Round(AMetaFile.Width*1.5);
AMetaFile.Height := Round(AMetaFile.Height*1.5);
Image2.Picture.Bitmap.Width := Image2.Width;
Image2.Picture.Bitmap.Height := Image2.Height;
Image2.Canvas.Draw(0, 0, AMetaFile);
rc.Left := 100;
rc.Top := 100;
rc.Right := 100;
rc.Bottom := 100;
Image3.Width := rc.Right;
Image3.Height := rc.Bottom;
Image3.Canvas.Brush.Color := clSilver;
Image3.Canvas.FillRect(Image3.Canvas.ClipRect);
BitBlt(Image3.Canvas.Handle,0,0,Image3.Width,Image3.Height,Image2.Canvas.Handle,rc.Left,rc.Top, SRCCOPY);
finally
AMetaFile.Free;
end;
end;
うんとさん、Mr.XRAYさん、尋ねよ、さらば見出さんさん ご教示
誠にありがとうございました。
| ツイート |  |