[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
(*
====================================================================
FILENAME : GRABIMG2.PAS
AUTHOR : SCOTT TUNSTALL (aka LIEUTENANT KOJAK)
CREATION : 20TH JULY 1996
DATE
DISTRIBUTE FREELY AS LONG AS MY NAME, CODE AND COMMENTS REMAIN
INTACT.
ALL WORK (C) 1996 SCOTT TUNSTALL
--------------------------------------------------------------------
REQUIREMENTS:
NEEDS KOJAKVGA, WHICH SHOULD BE IN THE GRAPHICS.SWG POST.
WHAT THIS PROGRAM DOES
----------------------
This program allows you to load in a 256 colour PCX and save
areas of it as a .IMG file. Specify the PCX filespec on the command
line.
Use the cursor keys to move the cross hairs. (Using CTRL + direction
makes the crosshairs move faster).
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 <= width/height 255 * 200) can be
grabbed then you will be presented with a menu which allows
you to manipulate the sprite. (If you can't see the menu text, use
the + and - keys to change the menu text colour. Also, pressing
T moves menu to (t)op of screen whereas B moves menu to (b)ottom )
IMPROVEMENTS OVER 1ST GRABIMG
-----------------------------
All known bugs have been fixed, more options allowed...
validation, what more can I say? Except GRABIMG2 is the
BUSINESS! I should be charging you lot for writing
this !!! :)
===============
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 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.
*)
{
Requires KOJAKVGA, which should be in the SWAG post you got this
GRABIMG2 from. I wrote it, so it has my name.
If you can't find KOJAKVGA then you will have to convert this
to work with NEWGRAPH. Sorry!
NWKBDINT is in June 96's KEYBOARD.SWG - author: Me!
}
Uses KOJAKVGA, NWKBDINT, CRT, DOS;
Var BarColour : byte;
MenuColour: byte;
MenuY : byte;
FirstBarX,
FirstBarY,
SecondBarX,
SecondBarY: integer;
LastWidth : word;
LastHeight: word;
Grabbing : boolean;
BufferPtr : pointer;
ThePalette: PaletteType;
{
Find the brightest colour available. (Smarm removed :) )
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
GetRGB(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;
{
Thought I'd re-write this in asm, just to be nerdy.
}
Procedure Sort(Var N1, N2: integer); Assembler;
Asm
PUSH DS
LDS SI,N1
LES DI,N2
MOV AX,[SI]
MOV BX,[ES:DI]
CMP AX,BX
JL @NoSwap
MOV [SI],BX
MOV [ES:DI],AX
@NoSwap:
POP DS
End;
Procedure ShowImage(boxcolour: byte; Var Theimage:pointer);
Begin
Cls;
UseColour(boxcolour);
Rectangle(0,0, 1+ShapeWidth(TheImage^),
1+ShapeHeight(TheImage^));
Block(1,1,TheImage^);
End;
{
Oh my God! The original code here was so err.. unoptimised!
}
Procedure GetTheShape(bmapptr:pointer; x1,y1,x2,y2:integer);
Var ShapeFile, PaletteFile: PathStr;
TheShapePointer: pointer;
MemRequired: word;
Key: char;
Begin
Sort(x1,x2);
if (x2-x1)>254 then x2:=x1+254;
Sort(y1,y2);
if (y2-y1)>199 then y2:=y1+199;
{
Ahem. A small bug was here in the last version :(
}
MemRequired:= ShapeSize(x1,y1,x2,y2);
UseBitmap(Bmapptr);
GetMem(TheShapePointer,MemRequired);
GetAShape(X1,Y1,X2,Y2,TheShapePointer^);
UseBitmap(ptr($a000,0));
UnHookKeyboardInt;
repeat
ShowImage(MenuColour,TheShapePointer);
UseFont(1);
FillArea(0,MenuY,319,MenuY+24,0);
PrintAt(0,MenuY, 'T/B = MENU TOP/BOTTOM +/- = COLOUR');
PrintAt(0,MenuY+8, 'S/P = SAVE IMAGE/PALETTE TO DISK');
PrintAt(0,MenuY+16, 'X/Y = FLIP IN X/Y DIRECTION C = CANCEL');
Repeat
key:=upcase(readkey);
Until (key in ['T', 'B', '-', '+', 'S','P','X','Y','C']);
Case key of
'T' : MenuY:=0;
'B' : MenuY:=191-24;
'-' : Dec(MenuColour);
'+' : Inc(MenuColour);
'S' : Begin
ShowImage(MenuColour, TheShapePointer);
Gotoxy(1,1+(MenuY SHR 3));
TextColor(MenuColour);
TextBackground(0);
Write('SAVE IMAGE AS :');
ReadLn(ShapeFile);
SaveShape(ShapeFile,TheShapePointer);
End;
'P' : Begin
ShowImage(MenuColour, TheShapePointer);
Gotoxy(1,1+(MenuY SHR 3));
TextColor(GetBrightestColour);
TextBackground(0);
Write('SAVE PALETTE AS :');
Readln(PaletteFile);
SavePalette(PaletteFile, ThePalette);
End;
'X' : XFlipShape(TheShapePointer^);
'Y' : YFlipShape(TheShapePointer^);
End;
until key = 'C';
FreeShape(TheShapePointer);
End;
{
Small optimisations!
}
Procedure UpdateBars(Var HorizontalBar, VerticalBar: integer);
Begin
If Keydown[72] Then
Begin
If KeyDown[29] Then
Dec(VerticalBar,4)
Else
Dec(VerticalBar);
If (VerticalBar <0) Then VerticalBar:=0;
End;
If Keydown[80] Then
Begin
If KeyDown[29] Then
Inc(VerticalBar,4)
Else
Inc(VerticalBar);
If (VerticalBar >199) Then VerticalBar:=199;
End;
If Keydown[75] Then
Begin
If KeyDown[29] Then
Dec(HorizontalBar,4)
Else
Dec(HorizontalBar);
If (HorizontalBar <0) Then HorizontalBar:=0;
End;
If Keydown[77] Then
Begin
If KeyDown[29] Then
Inc(HorizontalBar,4)
Else
Inc(HorizontalBar);
If (HorizontalBar >319) Then HorizontalBar:=319;
End;
End;
Procedure GrabShape(BMapPtr: pointer);
Var
Dist: integer;
TempString: string[4];
Begin
BarColour:=MenuColour;
HookKeyboardInt;
UseBitmap(ptr($a000,0));
Repeat
ShowAllBitmap(BMapPtr);
UseColour(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;
LastWidth:=Dist;
Str(Dist,TempString);
PrintAt(0,190,'WIDTH: '+TempString);
If SecondBarY > FirstBarY Then
Dist:=(SecondBarY - FirstBarY)+1
Else
Dist:=(FirstBarY - SecondBarY)+1;
Dist:=(SecondBarY-FirstBarY)+1;
LastHeight:=Dist;
Str(Dist,TempString);
PrintAt(160,190,'HEIGHT:'+TempString);
UpdateBars(SecondBarX, SecondBarY);
If Keydown[57] Then
Begin
GetTheShape( BMapPtr, FirstBarX,FirstBarY, SecondBarX,
SecondBarY);
UseBitmap(ptr($a000, 0));
HookKeyBoardInt;
Grabbing:=False;
End;
End
Else
Begin
UpdateBars(FirstBarX, FirstBarY);
If Keydown[57] Then
Begin
Sound(50);
Delay(100);
NoSound;
Grabbing:=True;
SecondBarX:=FirstBarX+LastWidth;
SecondBarY:=FirstBarY+LastHeight;
End;
End;
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; var BMapPtr: pointer);
Begin
If MaxAvail > 64000 Then
Begin
BMapPtr:=New64KBitmap;
UseBitmap(BMapPtr);
Cls;
LoadPCX(ThePCXFileName,ThePalette);
InitVGAMode;
UsePalette(ThePalette);
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;
{
Ask for the name of PCX to load.
}
Procedure LoadPCXFile(var BMapPtr: pointer);
Var PCXName: PathStr;
DummyFileVar: File;
Begin
TextColor(LIGHTGRAY);
Writeln;
Writeln;
Writeln;
Writeln('ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ');
Writeln('PCX Shape grabber version 2 (C) 1996 Scott Tunstall.');
Writeln('All rights reserved. This item is FREEWARE.');
Writeln('ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ');
Writeln;
Writeln('Written especially for :');
Writeln(' SourceWare Archival Group');
Writeln(' Geoff Bassett');
Writeln(' Scott "B & Q" Ramsay');
Writeln(' Paul Langa');
Writeln;
If ParamCount = 0 Then
Begin
Writeln;
Write('Enter name of 256 colour PCX file to load :');
PCXName:='';
Readln(PCXName);
Assign(DummyFileVar,PCXName);
{$i-}
Reset(DummyFileVar);
{$i+}
If IoResult = 0 Then
LoadPCXIntoBuffer(PCXName,BMapPtr)
Else
Begin
TextColor(LIGHTRED);
Writeln;
Writeln('Error in loading your .PCX file! The file with the name');
Writeln('that you specified does not exist...');
Halt(1);
End;
End
Else
LoadPCXIntoBuffer(ParamStr(1),BMapPtr);
End;
{
Main()
}
Begin
Grabbing:=False;
FirstBarX:=160;
FirstBarY:=100;
SecondBarX:=160;
SecondBarY:=100;
LastWidth:=16;
LastHeight:=16;
Directvideo:=False;
LoadPCXFile(BufferPtr);
MenuColour:=GetBrightestColour;
MenuY:=191-24;
GrabShape(BufferPtr);
FreeBitmap(BufferPtr);
END.
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]