| ziv-2014 |
|---|
| Гадаю по адресам :) Давай код. |
private
{ Private declarations }
vbmapFs, sbmapFs, vbmapRs, sbmapRs: TBitmap;
procedure LoadImage(FileName1, FileName2: string);
procedure DrawImage;
procedure TextOutOnForm(Canvas: TCanvas; X1, X2, Y, N: integer; Text: string);
procedure BuildImage;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
// vbmapFs хранит готовое изображение для отображения 1
vbmapFs := TBitmap.Create;
vbmapFs.Width := 1;
vbmapFs.Height := 1;
vbmapFs.PixelFormat := pf24bit;
// sbmapFs хранит исходное изображение бланка 1
sbmapFs := TBitmap.Create;
sbmapFs.Width := 1;
sbmapFs.Height := 1;
sbmapFs.PixelFormat := pf24bit;
// vbmapRs хранит готовое изображение для отображения 2
vbmapRs := TBitmap.Create;
vbmapRs.Width := 1;
vbmapRs.Height := 1;
vbmapRs.PixelFormat := pf24bit;
// sbmapRs хранит исходное изображение бланка 2
sbmapRs := TBitmap.Create;
sbmapRs.Width := 1;
sbmapRs.Height := 1;
sbmapRs.PixelFormat := pf24bit;
LoadImage('Original1.bmp','Original2.bmp');
BuildImage; // Построение изображения
DrawImage; // Обновление картинки на экране
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
vbmapFs.Destroy;
sbmapFs.Destroy;
vbmapRs.Destroy;
sbmapRs.Destroy;
end;
procedure TForm1.TextOutOnForm(Canvas: TCanvas; X1, X2, Y, N: integer;
Text: string);
var
i: integer;
k: double;
begin
Canvas.MoveTo(X1, Y - 10);
Canvas.LineTo(X1, Y );
Canvas.MoveTo(X2, Y - 10);
Canvas.LineTo(X2, Y );
if N > 1 then k := (X2 - X1) / (N - 1) // Шаг символов
else k := 1;
if Length(Text) > N then
SetLength(Text, N);
for i := 0 to Length(Text) - 1 do
Canvas.TextOut(X1 + Round(K*i - Canvas.TextWidth(Text[i+1])/2), Y, Text[i+1]);
end;
procedure TForm1.BuildImage;
begin
// Очистка фона 1/
vbmapFs.Width := sbmapFs.Width ;
vbmapFs.Height := sbmapFs.Height;
vbmapFs.PixelFormat := pf24bit;
vbmapFs.Canvas.Draw(0, 0, sbmapFs);
// Очистка фона 2/
vbmapRs.Width := sbmapRs.Width ;
vbmapRs.Height := sbmapRs.Height;
vbmapRs.PixelFormat := pf24bit;
vbmapRs.Canvas.Draw(0, 0, sbmapRs);
// Параметры шрифта
vbmapFs.Canvas.Font.Name := 'Arial';
vbmapFs.Canvas.Font.Size := 16;
// Вывод текста
TextOutOnForm(vbmapFs.Canvas, 203, 1382, 337, 35, SuName.Text);
end;
procedure TForm1.DrawImage;
var
nw, nh: integer;
begin
nw := vbmapFs.Width - 4;
nh := vbmapFs.Height - 4;
if cbZoom.ItemIndex = 0 then begin
// Уместить в окне
nh := ScrollBox1.Height - 4;
nw := Round(ScrollBox1.Height*vbmapFs.Width /vbmapFs.Height) - 4;
if nw > ScrollBox1.Width then begin
nw := ScrollBox1.Width - 4;
nh := Round(ScrollBox1.Width *vbmapFs.Height/vbmapFs.Width ) - 4;
end;
end;
if cbZoom.ItemIndex = 2 then begin
// Масштаб 50%
nw := (vbmapFs.Width - 4) div 2;
nh := (vbmapFs.Height - 4) div 2;
end;
with PaintBox1 do begin
Width := nw;
Height := nh;
Canvas.Lock;
// Задать режим масштабирования со сглаживанием
SetStretchBltMode(Canvas.Handle, HALFTONE);
// Скопировать картинку с масштабированием
StretchBlt(Canvas.Handle, 0, 0, Width , Height, vbmapFs.Canvas.Handle,
0, 0, vbmapFs.Width , vbmapFs.Height, SRCCOPY);
Canvas.Unlock;
end;
end;
procedure TForm1.LoadImage(FileName1, FileName2: string);
var
pic1, pic2: TPicture;
begin
if not FileExists(FileName1) then MessageDlg('Файл '+FileName1+' не найден', mtWarning,[mbOk], 0)
else if not FileExists(FileName1) then MessageDlg('Файл '+FileName2+' не найден', mtWarning,[mbOk], 0)
else
begin
pic1 := TPicture.Create;
pic1.LoadFromFile(FileName1);
sbmapFs.Width := pic1.Graphic.Width ;
sbmapFs.Height := pic1.Graphic.Height;
sbmapFs.PixelFormat := pf24bit;
sbmapFs.Canvas.Draw(0, 0, pic1.Graphic);
pic1.Destroy;
pic2 := TPicture.Create;
pic2.LoadFromFile(FileName2);
sbmapRs.Width := pic2.Graphic.Width ;
sbmapRs.Height := pic2.Graphic.Height;
sbmapRs.PixelFormat := pf24bit;
sbmapRs.Canvas.Draw(0, 0, pic2.Graphic);
pic2.Destroy;
end;
end;
procedure TForm1.SuNameChange(Sender: TObject);
begin
BuildImage; // Построение изображения
DrawImage; // Обновление картинки на экране
end;
procedure TForm1.PageControl1Change(Sender: TObject);
begin
BuildImage; // Построение изображения
DrawImage; // Обновление картинки на экране
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
BuildImage; // Построение изображения
DrawImage; // Обновление картинки на экране
end;
procedure TForm1.PaintBox2Paint(Sender: TObject);
begin
BuildImage; // Построение изображения
DrawImage; // Обновление картинки на экране
end;
procedure TForm1.ScrollBox1Resize(Sender: TObject);
begin
BuildImage; // Построение изображения
end;
procedure TForm1.cbZoomChange(Sender: TObject);
begin
BuildImage; // Построение изображения
DrawImage; // Обновление картинки на экране
end;
end.