uses
Dos;
const
VideoMem = $A000;
type
TColor = packed record
r, g, b: Byte;
end;
TPalette = array [0..255] of TColor;
PPalette = ^TPalette;
TImage = packed array [0..320*200-1] of Byte;
PImage = ^TImage;
var
Palette: TPalette;
procedure SetGrMode(AMode: Byte);
var
Regs: Registers;
begin
Regs.AH := $00;
Regs.AL := AMode;
Intr($10, Regs);
end;
procedure SetOneColor(AIndex: Integer; AColor: TColor);
begin
Port[$3C8] := AIndex;
Port[$3C9] := AColor.r shr 2;
Port[$3C9] := AColor.g shr 2;
Port[$3C9] := AColor.b shr 2;
end;
procedure SetGrdPal(const ANewPal: TPalette);
var
I: Integer;
begin
for I := 0 to 255 do
SetOneColor(I, ANewPal);
end;
procedure ClearImage(AImage: PImage);
var
I: Longint;
begin
for I := 0 to 320*200 - 1 do
AImage^ := 0;
end;
procedure CopyImage(AImage, ADestImage: PImage);
begin
ADestImage^ := AImage^;
end;
procedure ShowImage(AImage: PImage);
var
Screen: TImage absolute VideoMem:0000;
I: Longint;
begin
for I := 0 to 320*200 - 1 do
Screen := AImage^;
end;
function LoadImage(AImage: PImage; APal: PPalette; AFileName: string): Boolean;
var
F: file;
W, H, L: LongInt;
I: Byte;
B: Byte;
X, Y: Integer;
begin
LoadImage := False;
{$I-}
Assign(F, AFileName);
Reset(F, 1);
{$I+}
if IOResult <> 0 then
begin
WriteLn('IOResult <> 0');
readln;
end;
Seek(F, $12);
BlockRead(F, W, SizeOf(W));
BlockRead(F, H, SizeOf(H));
if (W <> 320) or (H <> 200) then
Exit;
Seek(F, $36); {gfdfg $3A}
for I := 0 to 255 do
begin
BlockRead(F, B, SizeOf(B));
APal^.R := B;
BlockRead(F, B, SizeOf(B));
APal^.G := B;
BlockRead(F, B, SizeOf(B));
APal^.B := B;
BlockRead(F, B, SizeOf(B)); { Alpha }
end;
Seek(F, $436);
{BlockRead(F, AImage^, SizeOf(AImage^));}
for Y := H - 1 downto 0 do
for X := 0 to W - 1 do
BlockRead(F, AImage^[Y*320+X], 1);
Close(F);
end;
function GetMouseX: Word;
var
w: Word;
begin
asm
mov ah,0
mov al,$3
int $33
mov w,cx
end;
GetMouseX := w;
end;
function GetMouseY: Word;
var
w: Word;
begin
asm
mov ah,0
mov al,$3
int $33
mov w,dx
end;
GetMouseY := w;
end;
procedure ShowMouseCursor;
begin
asm
mov ah,0;
mov al,1;
int $33;
end;
end;
procedure HideMouseCursor;
begin
asm
mov ah,0;
mov al,2;
int $33;
end;
end;
procedure SetMouseClip(x1, y1, x2, y2: Word);
begin
asm
mov ah,0
mov al,$7
mov cx,x1
mov dx,x2
int $33
mov ah,0
mov al,$8
mov cx,y1
mov dx,y2
int $33
end;
end;
var
ZoomX, ZoomY, ZoomR, ZoomSR: Integer;
procedure Zoom(AImage: PImage; AResImage: PImage);
var
X, Y, A: Integer;
begin
for Y := - ZoomR div 2 to ZoomR div 2 do
for X := - ZoomR div 2 to ZoomR div 2 do
begin
{A := 320*Y + X;
AResImage^[A] := AImage^[A];}
AResImage^[320*(ZoomY + Y) + ZoomX + X] :=
AImage^[320*(ZoomY + Y div 2) + ZoomX + X div 2];
end;
end;
var
Image, BImage: PImage;
I: Integer;
Res: Boolean;
Key: Char;
begin
GetMem(Image, 64000);
GetMem(BImage, 64000);
Res := LoadImage(Image, @Palette, 'bm.bmp');
SetGrMode($13);
SetGrdPal(Palette);
SetGrdPal(Palette);
ZoomX := 160;
ZoomY := 100;
ZoomR := 50;
ZoomSR := ZoomR div 2;
SetMouseClip(1 + ZoomSR, 1 + ZoomSR, 320 - ZoomSR, 200 - ZoomSR);
HideMouseCursor;
while Port[$60] <> 1 do
begin
ZoomX := GetMouseX;
ZoomY := GetMouseY;
CopyImage(Image, BImage);
Zoom(Image, BImage);
ShowImage(BImage);
end;
SetGrMode(3);
FreeMem(Image, 64000);
FreeMem(BImage, 64000);
end.
Не загружается .BMP картинка (Pascal)
Это программа-лупа, т.е. пользователь наводит курсор (тут не курсор, а прямоугольник), и изображение как бы увеличивается.
Язык Pascal.
Программа *.bmp файл загружать не хочет, подскажите пожалуйста, что мне исправить:
Код:
Файл bm.bmp находится в той же папке, что и .PAS-файл.
Вот архив с исходником:http://narod.ru/disk/25760902000/%D0%9B%D1%83%D0%BF%D0%B0.rar.html
EXE-файл работает как надо, а запускаю PAS-файл на выполнение, и вылазиет ошибка ((.
Всё, проблема решена, тему можно закрывать.