home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Utilities / Miscellaneous / CopyPaste 3.3.4 / CopyPaste Tools Sourcecode / Open File / Open File.p < prev    next >
Encoding:
Text File  |  1997-06-06  |  2.4 KB  |  106 lines  |  [TEXT/CWIE]
  1. {•This sourcecode is an example for creating a FKey coderesource with•}
  2. {•Metrowerks Pascal. It is copyrighted by Peter Hoerster and released•}
  3. {•for free use in any Shareware or Freeware product as a way to thank all•}
  4. {•programmers who share code snippets. You may put this sources on any•}
  5. {•CD ROM or any Archive Server but you may not sell it. •}
  6.  
  7. {• For comments please write to <hoerster@muenster.de>•}
  8.  
  9. unit OpenFile;
  10.  
  11. interface
  12.  
  13.     uses
  14.         Types, OSUtils, GestaltEqu, Script, notification, Resources, Events,
  15.          PascalA4, QuickDraw, ToolUtils, Memory, LowMem, Scrap,StandardFile;
  16.  
  17.  
  18.  
  19. {$MAIN}
  20.                         
  21.     procedure main;        
  22.  
  23. implementation
  24.  
  25.     
  26.     procedure main;
  27.         var
  28.             oldA4: LongInt;
  29.             myerr: oserr;
  30.             myclipsize: longint;
  31.             myclipHandle: handle;
  32.             
  33.         function GetFile (var gsavereply: SFReply): OSErr;
  34.         var
  35.  
  36.             where: Point;
  37.             typelist: sftypelist;
  38.         begin
  39.             typelist[1] := 'TEXT';
  40.             typelist[2] := 'PICT';
  41.             SetPt(where, 104, 100);
  42.             SFGetFile(where, '', nil, 4, @typeList, nil, gsavereply);
  43.             if not gsavereply.good then
  44.                 GetFile := 1
  45.             else
  46.                 GetFile := NoErr;
  47.         end;
  48.  
  49.             
  50.         procedure getsaved;
  51.         const
  52.             HeaderSize = 512;            { PICT file header - we ignore this }
  53.         var
  54.             fndrinfo: finfo;
  55.             gsaveref: integer;
  56.             gsavereply: sfreply;
  57.  
  58.  
  59.  
  60.         procedure fillclipboard (thetype: OSType);
  61.         begin
  62.             mycliphandle := Tempnewhandle(myclipsize,myerr);
  63.             if myerr=noerr then 
  64.                 begin
  65.                     Temphlock(mycliphandle,myerr);                                            { Read picture portion of file }
  66.                     if fsread(gsaveref, myclipsize, mycliphandle^) = noerr then
  67.                         begin
  68.                             myerr := ZeroScrap;
  69.                             myerr := putscrap(myclipsize, thetype, myclipHandle^);
  70.                         end;
  71.                     Temphunlock(myCliphandle,myerr);
  72.                 end;
  73.             TempDisposeHandle(myCliphandle,myerr);
  74.         end;
  75.  
  76.     begin
  77.         if getfile(gsavereply) = noerr then
  78.         if FSOpen(gsaveReply.fname, gsaveReply.vRefNum, gsaveref) = noerr then
  79.         if geteof(gsaveref, myclipsize) = noerr then
  80.         if getfinfo(gsaveReply.fname, gsaveReply.vRefNum, fndrinfo) = noerr then
  81.         if fndrinfo.fdtype = 'PICT' then
  82.             begin
  83.                 myerr := SetFPos(gsaveref, FSFromStart, HeaderSize);        { Skip over header }
  84.                 myclipsize := myclipsize - HeaderSize;
  85.                 fillclipboard('PICT')
  86.             end
  87.         else if fndrinfo.fdtype = 'TEXT' then
  88.             begin
  89.                 fillclipboard('TEXT')
  90.             end;
  91.         if gsaveref <> 0 then
  92.             begin
  93.                 myerr := FSclose(gsaveref);
  94.                 gsaveref := 0;
  95.             end;
  96.     end;
  97.  
  98.             
  99.             
  100.             
  101.     begin
  102.         oldA4 := SetCurrentA4;
  103.         getsaved;
  104.         oldA4 := SetA4(oldA4);
  105.     end;
  106. end.