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==_--