Date: Tue, 15 Nov 1994 19:02:18 -0800
From: derekb@OREGON.UOREGON.EDU (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:  derekb@oregon.uoregon.edu   [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<derekb@oregon.uoregon.edu>]
"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==_--