Date: Tue, 15 Nov 1994 19:02:18 -0800
From:
[email protected] (Derek Boonstra)
Subject: Submission
--========================_6153076==_
Content-Type: text/plain; charset="us-ascii"
'SimpleSavePict-pas.txt' is a Unit written in Think Pascal to save Gworlds
or current active windows as a file of PICT format.
I'm hoping that it will be placed in /info-mac/dev/source.
Thankyou,
--========================_6153076==_
Content-Type: text/plain; name="SimpleSavePict-pas.txt"; charset="us-ascii"
Content-Disposition: attachment; filename="SimpleSavePict-pas.txt"
unit SavePict;
{Written by Derek Boonstra for PUBLIC DOMAIN}
{11/94}
{please feel free to use as whole, or any parts, for any proj. }
{If you have any comments/questions or regards }
{write:
[email protected] [Go Ducks!] }
{}
{I appreciate all positive and/or constructive mail }
interface
procedure ExGworldToPict (name: str255; RefNum: integer; MyWorld: cGrafPtr);
{For new PICT file of Initialized Gworld...}
{...call: ExGworldToPict('',0,MyWorld);}
procedure ExWindToPict (name: str255; RefNum: integer);
{For new PICT file of current, active window...}
{...call: ExWindToPict('',0);}
implementation
{------------------------------}
procedure ShowError (err: integer; message: str255);
var
TheErrStr: string;
begin
case err of
noErr:
TheErrStr := message;
bdNamErr:
TheErrStr := 'Bad File Name';
dupFNErr:
TheErrStr := 'Duplicate File Name';
dirFulErr:
TheErrStr := 'File Directory is Full';
extFSErr:
TheErrStr := 'External File System Error';
ioErr:
TheErrStr := 'I/O Error';
nsverr:
TheErrStr := 'No Such Volume';
vLckdErr:
TheErrStr := 'Software Volume is Locked';
wPrErr:
TheErrStr := 'Hardware Volume is locked';
fnfErr:
TheErrStr := 'File not found';
opWrErr:
TheErrStr := 'The File is already open';
tmfoErr:
TheErrStr := 'Toomany Files are open';
fnOpnErr:
TheErrStr := 'The file failed to open';
wrPermErr:
TheErrStr := 'Read/Write permission not granted';
rfNumErr:
TheErrStr := 'Bad Reference Number';
otherwise
TheErrStr := message;
end;
{*** Do Something with "TheErrStr" ***}
end;
{------------------------------}
procedure PutNewFile (var reply: SFreply);
const
SUGGEST = 'Untitled.pict';
var
where: Point;
begin
where.v := 100;
where.h := 100;
SFPutFile(Where, 'Save PICT as?', SUGGEST, nil, reply);
end;
{------------------------------}
function CreatePictFile (fname: string; vnum: integer): boolean;
var
f, err, i: integer;
where: Point;
TheInfo: FInfo;
name: str255;
begin
err := GetFInfo(fname, vnum, TheInfo);
case err of
NoErr: {File already exists}
with TheInfo do
begin
if (fdType <> 'PICT') then
begin
ShowError(0, 'The file You are replacing is not a PICT.');
CreatePictFile := false;
exit(CreatePictFile);
end;
err := fsclose(f);
err := FSDelete(fname, vnum);
err := create(fname, vnum, 'Appl', 'PICT');
if err <> 0 then
begin
ShowError(err, '');
CreatePictFile := false;
exit(CreatePictFile);
end;
end;
FNFerr: {NewFile}
begin
err := create(fname, vnum, 'Appl', 'PICT');
if err <> 0 then
begin
ShowError(err, '');
CreatePictFile := false;
exit(CreatePictFile);
end;
end;
otherwise
if err <> 0 then
begin
ShowError(err, '');
CreatePictFile := false;
exit(CreatePictFile);
end;
end;
CreatePictFile := true;
end;
{------------------------------}
function GetPictH (var PictH: PicHandle; MyWorld: cGrafPtr; MyWind:
Grafptr): boolean;
var
OrigPort: Grafptr;
thePICTSize: longint;
Userect: rect;
begin
if MyWorld <> nil then
with MyWorld^ do
begin
GetPort(OrigPort);
hlock(handle(PortPixMap));
Userect := PortPixMap^^.bounds;
SetPort(GrafPtr(MyWorld));
ClipRect(Userect);
PictH := OpenPicture(Userect);
CopyBits(BitMapHandle(PortPixMap)^^, BitMapHandle(PortPixMap)^^,
Userect, Userect, SrcCopy, nil);
ClosePicture;
hunlock(handle(PortPixMap));
SetPort(OrigPort);
end;
if MyWind <> nil then
with MyWind^ do
begin
Userect := portbits.bounds;
ClipRect(Userect);
PictH := OpenPicture(Userect);
CopyBits(portbits, portbits, Userect, Userect, SrcCopy, nil);
ClosePicture;
end;
thePICTSize := GetHandleSize(handle(PictH));
if thePICTSize <= 10 then
begin
ShowError(0, 'Sorry, There is not enough memory to save a PICT file.');
DisposHandle(handle(PictH));
GetPictH := false;
end
else
GetPictH := true;
end;
{------------------------------}
function WritePictFile (fname: str255; vnum: integer; PictH: PicHandle):
boolean;
const
HEADERSIZE = 512;
var
LoopIndex, ZeroValue, f, err, i, v: integer;
ByteCount, thePICTSize: LongInt;
fRect: rect;
PictPort, tPort: GrafPtr;
TheInfo: FInfo;
TempHeader: array[1..128] of longint;
procedure GetOut;
begin
ShowError(err, 'Sorry, an internal error occurred while writing the PICT
file.');
err := fsclose(f);
err := FSDelete(fname, vnum);
DisposHandle(handle(PictH));
WritePictFile := false;
exit(WritePictFile)
end;
begin
err := fsopen(fname, vnum, f);
if err <> 0 then
GetOut;
err := SetFPos(f, FSFromStart, 0);
{Make the Header}
for LoopIndex := 1 to 128 do
TempHeader[LoopIndex] := 0;
ByteCount := HEADERSIZE;
err := fswrite(f, ByteCount, @TempHeader);
ByteCount := SizeOf(TempHeader);
if ByteCount <> HEADERSIZE then
begin
GetOut;
end;
HLock(Handle(PictH));
thePICTSize := GetHandleSize(handle(PictH));
err := fswrite(f, thePICTSize, pointer(PictH^));
HunLock(Handle(PictH));
if err <> 0 then
GetOut;
DisposHandle(handle(PictH));
ByteCount := ByteCount + thePICTSize;
err := SetEOF(f, ByteCount);
err := fsclose(f);
if err <> 0 then
GetOut;
err := GetFInfo(fname, vnum, TheInfo);
if TheInfo.fdCreator <> ' Appl' then
begin
TheInfo.fdCreator := 'Appl';
err := SetFInfo(fname, vnum, TheInfo);
end;
if TheInfo.fdType <> 'PICT' then
begin
TheInfo.fdType := 'PICT';
err := SetFInfo(fname, vnum, TheInfo);
if err <> 0 then
GetOut;
end;
err := FlushVol(nil, vnum);
WritePictFile := true;
end;
{------------------------------}
procedure ExGworldToPICT (name: str255; RefNum: integer; MyWorld: cGrafPtr);
var
reply: SFReply;
Goodness: boolean;
PictH: picHandle;
begin
if (name = '') then
begin
PutNewFile(reply);
Goodness := reply.good;
if not Goodness then
begin
ShowError(0, 'IOerr');
exit(ExGworldToPICT);
end;
with reply do
begin
name := fname;
RefNum := vRefNum;
end;
end;{if (name = '') then}
Goodness := CreatePictFile(name, RefNum);
if Goodness then
Goodness := GetPictH(PictH, MyWorld, nil);
if Goodness then
Goodness := WritePictFile(name, RefNum, PictH);
end;
{------------------------------}
procedure ExWindToPICT (name: str255; RefNum: integer);
var
OurPort: Grafptr;
reply: SFReply;
Goodness: boolean;
PictH: picHandle;
begin
GetPort(OurPort);
if (name = '') then
begin
PutNewFile(reply);
Goodness := reply.good;
if not Goodness then
begin
ShowError(0, 'IOerr');
exit(ExWindToPICT);
end;
with reply do
begin
name := fname;
RefNum := vRefNum;
end;
end;{if (name = '') then}
Goodness := CreatePictFile(name, RefNum);
if Goodness then
Goodness := GetPictH(PictH, nil, OurPort);
if Goodness then
Goodness := WritePictFile(name, RefNum, PictH);
end;
end.
--========================_6153076==_
Content-Type: text/plain; charset="us-ascii"
Derek Boonstra [#milk<
[email protected]>]
"I am just a small mouse in a large mechanical suit"
"Good Idea: Riding a train to Oregon. Bad Idea: Pushing a train to Oregon"
For every action, there are equal and opposing forces of paper work.
--========================_6153076==_--
