[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
{
========================================
GRABIMG.PAS (C) 1994-1996 SCOTT TUNSTALL
DISTRIBUTE FREELY
----------------------------------------
This program allows you to load in a 256 colour PCX and save
areas of it as a .IMG file.
Use the cursor keys to move the cross hairs. Press space when you
are at the top left of the area you wish to cut, then when the
second pair of cross hairs appear, move them to the bottom right
of the image to cut. You will see the size of the image in
horizontal width & vertical height at the bottom left of the
screen. When you have a sprite of the desired size defined
within the crosshairs, press space again.
If the Shape (it must be less than width/height 255 * 255) can be
grabbed then you will be asked for a filename for the Shape to
be saved.
Standard MS - DOS filenames are required.
===============
For the coders:
---------------
Shape grabbed is from the non planar, unchained VGA mode $13.
=====================
File format of image:
---------------------
Byte 0 : Width
Byte 1 : Height
Byte 2.. Actual Shape data itself, uncompressed. The data is
saved row by row, line by line.
To read it use the LoadShape command present in NEWGRAPH
ex:
var p: pointer;
LoadShape('SPRITE.IMG',p);
...
To display it use the Blit/Block/ClipBlit/ClipBlock commands.
}
Uses NEWGRAPH, NWKBDINT, CRT, DOS;
{ NOTE : NWKBDINT - in KEYBOARD.SWG
NEWGRAPH - in GRAPHICS.SWG }
Var BarColour : byte;
FirstBarX,
FirstBarY,
SecondBarX,
SecondBarY: word;
Grabbing: boolean;
BufferSeg,
BufferOffset:word;
ThePalette: PaletteType;
{
Find the brightest colour available, and, yes I did program
this, it's not from SWAG or anything like that. Shall I explain
it to you ?
Each Colour has it's own Red, Green and Blue value attached to it.
Each Colour can have Red, Green and Blue component values of 64
thus giving 262,144 colours (64 * 64 * 64)
To find the brightest colour you just read the palette entries,
add up the Red, Green and Blue values and check if they are the
brightest so far. If they are, take a note of what Colour has
those values and do until all Colours are scanned. Easy eh? :-)
}
Function GetBrightestColour: byte;
Var Total: byte;
Count: byte;
RedTotal,
GreenTotal,
BlueTotal, ColourWithBestHue : byte;
BestHueFound,
HueValue: longint;
Begin
Count:=0;
BestHueFound:=0;
ColourWithBestHue:=0;
HueValue:=0;
Repeat
GetPalette(Count,RedTotal,GreenTotal,BlueTotal);
HueValue:=BlueTotal+(GreenTotal*16)+(RedTotal * 256);
If HueValue > BestHueFound Then
Begin
BestHueFound:=HueValue;
ColourWithBestHue:=Count;
End;
Inc(Count);
Until Count=0;
GetBrightestColour:=ColourWithBestHue;
End;
Procedure Sort(Var N1, N2: word);
Var Temp: word;
Begin
If N1 > N2 Then
Begin
Temp:=N1;
N1:=N2;
N2:=Temp;
End;
End;
Procedure GetTheShape;
Var ShapeName: PathStr;
Palette: PaletteType;
OldBarX,
OldBarY: word;
TheShapePointer: pointer;
MemRequired: word;
Key: char;
Begin
OldBarX:=FirstBarX;
OldBarY:=FirstBarY;
{
O.K. As the graphics unit I've written only takes X and Y
coordinates that are ordered (i.e. define a rectangular
area) I've got to make sure than X1 is less than X2 and
Y1 is less than Y2.
}
Sort(FirstBarX,SecondBarX);
Sort(FirstBarY,SecondBarY);
If (FirstBarX < SecondBarX) And (FirstBarY < SecondBarY) Then
Begin
GetAllPalette(Palette);
MemRequired:= ExtShapeSize((SecondBarX-FirstBarX),
(SecondBarY-FirstBarY));
GetMem(TheShapePointer,MemRequired);
GetAShape(FirstBarX,FirstBarY,SecondBarX,SecondBarY,TheShapePointer^);
SetSourceBitmapAddr($a000,0);
Cls;
Block(0,0,TheShapePointer^);
BarColour:=GetBrightestColour;
SetColour(BarColour);
OutTextXY(0,192,'SAVE THIS IMAGE (Y/N) :');
Repeat
key:=upcase(readkey);
Until (key= 'Y') or (key = 'N');
If key = 'Y' Then
Begin
Asm
MOV AX,2
INT $10
End;
Write('Save Shape as :');
Readln(ShapeName);
{$i-}
SaveShape(ShapeName,TheShapePointer);
{$i+}
End;
FreeShape(TheShapePointer);
InitVGAMode;
SetAllPalette(ThePalette);
ShowBitmap(BufferSeg,BufferOffset);
FirstBarX:=OldBarX;
FirstBarY:=OldBarY;
End;
End;
{
I'm not too keen on this proc.. reckon I will change it later
when my Bsc is over.
}
Procedure UpdateBars(Var HorizontalBar, VerticalBar: word);
Begin
If Keydown[72] And (VerticalBar >0) Then
Dec(VerticalBar);
If Keydown[80] And (VerticalBar <200) Then
Inc(VerticalBar);
If Keydown[75] And (HorizontalBar >=0) Then
Dec(HorizontalBar);
If Keydown[77] And (HorizontalBar <320) Then
Inc(HorizontalBar);
End;
Procedure GrabShape;
Var
Dist: integer;
TempString: string[4];
Begin
BarColour:=GetBrightestColour;
HookKeyboardInt;
Repeat
ShowBitmap(BufferSeg,BufferOffset);
SetSourceBitmapAddr($a000,0);
SetColour(BarColour);
Line(FirstBarX,0,FirstBarX,199);
Line(0,FirstBarY,319,FirstBarY);
If Grabbing Then
Begin
Line(SecondBarX,0,SecondBarX,199);
Line(0,SecondBarY,319,SecondBarY);
If SecondBarX > FirstBarX Then
Dist:=(SecondBarX - FirstBarX)+1
Else
Dist:=(FirstBarX - SecondBarX)+1;
Str(Dist,TempString);
OutTextXY(0,190,'WIDTH: '+TempString);
If SecondBarY > FirstBarY Then
Dist:=(SecondBarY - FirstBarY)+1
Else
Dist:=(FirstBarY - SecondBarY)+1;
Str(Dist,TempString);
OutTextXY(160,190,'HEIGHT:'+TempString);
End;
{ Memw[$40:$1a]:=Memw[$40:$1c]; }
If Not Grabbing Then
Begin
UpdateBars(FirstBarX, FirstBarY);
If Keydown[57] Then Begin
Sound(50);
Delay(100);
NoSound;
Grabbing:=True;
SecondBarX:=FirstBarX+15;
SecondBarY:=FirstBarY+15;
End;
End
Else
Begin
UpdateBars(SecondBarX, SecondBarY);
If Keydown[57] Then
Begin
UnHookKeyBoardInt;
SetSourceBitmapAddr(BufferSeg,BufferOffset);
GetTheShape;
Grabbing:=False;
HookKeyBoardInt;
End;
End;
{ Make sure that bars flicker }
Until KeyDown[1];
UnHookKeyboardInt;
End;
{
What this does is allocate memory for the PCX (Assuming 64000
bytes are free for it) then loads the PCX into RAM, where it
can be read (but not altered) by this program.
}
Procedure LoadPCXIntoBuffer(ThePCXFileName:string);
Begin
If MaxAvail > 64000 Then
Begin
Bitmap(BufferSeg,BufferOffset);
SetSourceBitmapAddr(BufferSeg,BufferOffset);
InitVGAMode;
LoadPCX(ThePCXFileName,ThePalette);
SetAllPalette(ThePalette);
SetSourceBitmapAddr($a000,0);
CopySourceBitmap;
End
Else
Begin
Writeln;
Writeln('Out of memory error. The program needed 64K for the');
Writeln('PCX buffer but only ',maxavail div 1024,'K was');
Writeln('available.');
Writeln;
Halt;
End;
End;
Procedure FreeBuffer;
Begin
FreeBitmap(BufferSeg,BufferOffset);
End;
{
Ask for the name of PCX to load.
}
Procedure RequestPCXFile;
Var PCXName: PathStr;
DummyFileVar: File;
Begin
Writeln;
Writeln('Enter name of Mode 13h 256 colour PCX file to load :');
Readln(PCXName);
Assign(DummyFileVar,PCXName);
{$i-}
Reset(DummyFileVar);
{$i+}
If IoResult = 0 Then
LoadPCXIntoBuffer(PCXName)
Else
Begin
Writeln;
Writeln('Error in loading your .PCX file!');
Writeln('The filename (and/or path) specified does not exist.');
Halt;
End;
End;
{
Main()
}
Begin
Writeln;
Writeln('PCX Shape grabber (C) 1995 Scott Tunstall.');
Writeln;
Writeln('Written especially for :');
Writeln(' Scott "B & Q" Ramsay');
Writeln(' Paul Langa');
Writeln;
If ParamCount <>1 Then
RequestPCXFile
Else
LoadPCXIntoBuffer(Paramstr(1));
Grabbing:=False;
FirstBarX:=160;
FirstBarY:=100;
SecondBarX:=160;
SecondBarY:=100;
GrabShape;
FreeBuffer;
END.
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]