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