Otherware/Otherware_1_SB_Development.iso/mac/developm/scnote/scrnfkey.022/ScreenFKEY.p

Text File | 1989-10-04 | 9KB | 282 lines

{ pasmat -q -k -t 2 -: aFKEY6.p FKEY6.p -r -u }

{*#############################################################################################
#
#    Apple Macintosh Developer Technical Support
#
#    FKEY6 : Saves the contents of the main Macintosh screen to a PICT file.
#
#    ScreenFKEY.p
#
#    Copyright ⌐ 1989 Apple Computer, Inc.
#    All rights reserved.
#
#    Versions:
#            1.00                     10/89
#
#    Components:
#            ScreenFKEY.p            October 1, 1989
#            ScreenFKEY.a              October 1, 1989
#            ScreenFKEY.make          October 1, 1989
#
#    ScreenFKEY is a basic example on how to spool a PICT file to disk by replacing the
#    bottleneck PutPICProc, it saves the contents of the screen to a file. The FKEY creates
#    ten files Screen 0 through Screen 9; it is necessary to erase or rename old files when
#    the limit is reached.
#
#    This FKEY works in any Macintosh computer and saves the screen regardless of the
#    setting of the screen; to use, it has to be added to the System file using ResEdit.
#
############################################################################################*}



{ The basic strategy is as follows:
  1.- Make sure we can create the file.
  2.- If Color QuickDraw is available then use a color port
      else use a regular B/W port
  3.- Replace the bottleneck procedure for our own putPict procedure
  4.- Open a picture, 3 above guarantees that data will go to disk
  5.- CopyBits the whole screen into itself causing the stuff to go
      to the picture.
  6.- Close the picture
  7.- Finish the PICT file.
  8.- Leave things (QDProcs, port) the way they were.       }

{ Another point of interest is the technique used to provide pseudo
  globals needed for the process to work by tagging the fields to the
  end of the grafport record.           }

UNIT FKEY;

INTERFACE

    USES Memtypes, Quickdraw, OSIntf, ToolIntf, PackIntf;

TYPE
     BitMapPtr = ^BitMap; { Type casting stuff }

{ structure used to mantain some globals that can not be accessed
  in the standard way when QD calls the bottleneck procedure   }

    GDataRec = RECORD
        pHand: PicHandle; { picture being created }
        gRef: INTEGER; { file reference number }
        fileOK: BOOLEAN; { problems flag }
    END;

    { now lets put together a port + our data structure      }
    GportPlus = RECORD
        TRUEPort: CGrafPort;
        GDStuff: GDataRec;
    END;

    GPPtr = ^GportPlus;

{ main procedure for the FKEY }
PROCEDURE PICTOut;

{ PutPICTData replaces the standard bottleneck proc }
PROCEDURE PutPICTData(dataPtr: Ptr;  byteCount: INTEGER);



IMPLEMENTATION

PROCEDURE PutPICTData{(dataPtr: Ptr; byteCount: INTEGER)};

VAR
    longCount: LONGINT; { byte count }
    myPortPlus: GPPtr; { global data pointer }

BEGIN

    GetPort(grafPtr(myPortPlus)); { to access the global data }

    longCount := byteCount;

    IF myPortPlus^.GDStuff.fileOK THEN BEGIN { do this only if file is still OK }

        IF FSWrite(myPortPlus^.GDStuff.gRef, longCount, dataPtr) <> noErr THEN
            { something bad occurred, must delete file }
            myPortPlus^.GDStuff.fileOK := FALSE;

        IF myPortPlus^.GDStuff.pHand <> NIL THEN { if the picture is already open }
            { keep size up to date so QD }
            { can adjust for oddness        }
            myPortPlus^.GDStuff.pHand^^.picSize := myPortPlus^.GDStuff.pHand^^.picSize + longCount;
    END

END;

{ The main procedure of the FKEY.
  This code installs the bottle neck procedure, opens the picture and does all
  the house keeping.
}

PROCEDURE PICTOut;

VAR
    err: OSErr;
    i: INTEGER;
    longCount, longZero: LONGINT;
    myProcs: CQDProcs;
    myOldProcs: QDProcs;

    savePictSizeFrame: Picture;

    nameStr: Str255;
    vrefnum: INTEGER;
    bytesAvail: LONGINT;

    oldPort: grafPtr;
    wPortPlus: GportPlus;
    wPortPlusPtr: GPPtr;
    myDev, aDev: GDHandle;
    pictHand: PicHandle;
    globalRef: INTEGER;

    theWorld: SysEnvRec;

    bitPtr: BitMapPtr;

    { We use this procedure to kill the file if something fails.
    We don't want to leave files laying around, do we? }
    PROCEDURE DeathKiss;
    BEGIN
        IF globalRef <> 0 THEN
            err := FSClose(globalRef);

        { close the file if it is open }
        err := FSDelete(nameStr, vrefnum); { to make sure Delete works }
        SysBeep(1); { Let the world know }
        Exit(PICTOut); { and get out of here! }
    END; {DeathKiss}

BEGIN {PICTOut}

    err := SysEnvirons(1, theWorld); { Lets check if we have what we need }

    { initializing the pointer to port + global stuff}
    wPortPlusPtr := @wPortPlus;

    { Init this variable to help exit procedure clean our stuff when we have to run away. }
    globalRef := 0; { if not zero then a file is open }

    { first we see if it is possible to open file }

    IF GetVInfo(0, @nameStr, vrefnum, bytesAvail) <> noErr THEN
        { get info on default volume }
        DeathKiss; { error, get out of here! }

    { At this point we could check to see if there is room in the volume for the PICT file,
    I chose not to because using a value for the maximun length could probably abort the
    process when there is room for the actual length. I decided that it is better to fail
    when trying to write than kill the saving without reason. }

    { We try to create a file 'Screen x' beginning with 0 up to 9, if ten
    files exist we exit and abort the saving              }
    nameStr := 'Screen 0'; { initial name }
    REPEAT BEGIN
        err := Create(nameStr, vrefnum, 'GAO.', 'PICT');
        IF err <> noErr THEN BEGIN
            IF err = dupFNErr THEN BEGIN { if file already there bump the name }
                nameStr[8] := Chr(Ord(nameStr[8]) + 1);
                IF nameStr[8] = ':' THEN { ten files should be enough }
                    DeathKiss; { can't make more files, get out of here! }
            END
            ELSE
                DeathKiss; { error, get out of here! }
        END
    END UNTIL (err = noErr);

    IF FSOpen(nameStr, vrefnum, globalRef) <> 0 THEN { if error delete }
        DeathKiss; { error, get out of here! }

    { file should be open at this point, so we try to write out the header for the pict file }
    longZero := 0;
    longCount := 4;
    FOR i := 1 TO (532  DIV 4 ) DO BEGIN { init PICT header and then some }
        err := FSWrite(globalRef, longCount, @longZero);
        IF err <> noErr THEN
        DeathKiss {error while file open, get out and kill file }
    END;

    IF SetFPos(globalRef, fsFromStart, 522) <> noErr THEN
        DeathKiss; {error while positioning file, exit }

    GetPort(oldPort); { save current port }

    { init global vars }
    wPortPlus.GDStuff.gRef := globalRef; { for file accesses }
    wPortPlus.GDStuff.pHand := NIL; { no picture when begining }
    wPortPlus.GDStuff.fileOK := TRUE; { we hope }

    IF theWorld.hasColorQD THEN BEGIN
        OpenCport(CGrafPtr(wPortPlusPtr)); { Lets get a color port }
        SetStdCProcs(myProcs); { set its bottleneck procs }
        grafPtr(wPortPlusPtr)^.grafProcs := @myProcs;
        myProcs.putPicProc := @PutPICTData;
        myDev := GetMainDevice; { to get to screen }
        bitPtr := BitMapPtr(myDev^^.gdPMap^)
    END ELSE BEGIN
        Openport(grafPtr(wPortPlusPtr)); { Lets get an old style port }
        SetStdProcs(myOldProcs); { set procs }
        grafPtr(wPortPlusPtr)^.grafProcs := @myOldProcs;
        myOldProcs.putPicProc := @PutPICTData;
        bitPtr := BitMapPtr(@wPortPlusPtr^.TRUEPort.portPixMap)
    END;

    ClipRect(bitPtr^.bounds); { Just in case, make sure clip region is OK. }

    pictHand := OpenPicture(bitPtr^.bounds);

    { On a Macintosh II + color port OpenPicture fails if the heap
    doesn't have at least 1000 bytes free, so we better check
    if we have a valid handle         }

    IF pictHand <> NIL THEN BEGIN
        wPortPlus.GDStuff.pHand := pictHand; { now we have a handle }

        { CopyBits will call our procedure }
        CopyBits(bitPtr^, bitPtr^, bitPtr^.bounds, bitPtr^.bounds, srcCopy, NIL);

        ClosePicture;

    { We need this later to complete file }
        savePictSizeFrame := pictHand^^;

        KillPicture(pictHand) { release all memory }

    END ELSE { no picture saved so we have to kill the file }
        wPortPlus.GDStuff.fileOK := FALSE;

    { Now we proceed to clean up and to restore the port }
    grafPtr(wPortPlusPtr)^.grafProcs := NIL;
    SetPort(oldPort);
    IF theWorld.hasColorQD THEN
        { Lets get rid of the color port }
        CloseCport(CGrafPtr(wPortPlusPtr))
    ELSE
        ClosePort(grafPtr(wPortPlusPtr)); {or get rid of the normal port}

    { after everything is back in good shape we can check if the copybits data
    went to disk a O.K. and if there is a picture at all }

    IF NOT (wPortPlus.GDStuff.fileOK) THEN
        DeathKiss; {error while saving file, exit }

    IF SetFPos(globalRef, fsFromStart, 512) <> noErr THEN
        DeathKiss; {error while positioning file, exit }

    longCount := SizeOf(Picture);
    IF FSWrite(globalRef, longCount, @savePictSizeFrame) <> noErr THEN
        DeathKiss; {error while writing picture size and rect to file, exit }

    IF FSClose(globalRef) <> noErr THEN { now close the file }
        DeathKiss; {error while closing file, exit }

END; {PICTOut}

END. { Unit FKEY }