home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Pascal / Source□ / DeHQX-200-Source / MyStandardFile.unit < prev    next >
Encoding:
Text File  |  1991-08-23  |  7.6 KB  |  297 lines  |  [TEXT/PJMM]
  1. unit MyStandardFile;
  2. { DeHQX v2.0.0 © Peter Lewis, Aug 1991 }
  3.  
  4. interface
  5.  
  6.     uses
  7.         Types, OSUtils, Files, Dialogs, StandardFile, MyTypes, MyUtilities, MyFileSystem;
  8.  
  9.     type
  10.         MySFReply = record
  11.                 Rgood: boolean;
  12.                 Rfolder: boolean;
  13.                 RfType: OSType;
  14.                 RvRefNum: integer;
  15.                 RdirID: longInt;
  16.                 RfName: str63;
  17.             end;
  18.  
  19.     function MFSPt: point;
  20.     procedure GetFile (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; var reply: MYSFReply);
  21.     procedure GetFile1 (t: OSType; var reply: MySFReply);
  22.     procedure GetFolder (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; id: integer; var reply: MySFReply);
  23. { NOTE: GetFolder must be passed a Dialog ID with Button 11 being a folder button }
  24. { NOTE: reply.copy should be interpreted as reply.folder }
  25.     procedure PutFile (str, origName: str255; var reply: MySFreply);
  26.     procedure PutFolder (str, origName: str255; id: integer; var reply: MySFreply);
  27. { NOTE: PutFolder must be passed a Dialog ID with Button 9 being a folder button }
  28. { NOTE: reply.copy should be interpreted as reply.folder }
  29.     function Button11Hook (item: integer; dlg: DialogPtr): integer;
  30. { NOTE: Button11Hook sets Button11 when it converts Button 11 to Button 1 (Open) }
  31.     function Button9Hook (item: integer; dlg: DialogPtr): integer;
  32. { NOTE: Button9Hook sets Button9 when it converts Button 9 to Button 1 (Save) }
  33.     procedure SetSFFile (wdrn: integer; dirID: longInt);
  34.  
  35. implementation
  36.  
  37.     procedure SetSFFile (wdrn: integer; dirID: longInt);
  38.         var
  39.             oe: OSErr;
  40.             vrn: integer;
  41.             procID: longInt;
  42.             s: str255;
  43.     begin
  44.         if dirID = 0 then
  45.             oe := GetWDInfo(wdrn, vrn, dirID, procID)
  46.         else
  47.             vrn := wdrn;
  48.         integerP(SFSaveDiskA)^ := -vrn;
  49.         longIntP(CurDirStoreA)^ := dirID;
  50.     end;
  51.  
  52.     function MFSPt: point;
  53.         var
  54.             pt: point;
  55.     begin
  56.         pt.v := 40;
  57.         pt.h := 40;
  58.         MFSPt := pt;
  59.     end;
  60.  
  61.     procedure SetStdReply (var reply: MySFReply; stdReply: StandardFileReply);
  62.     begin
  63.         with reply do begin
  64.             Rgood := stdReply.sfGood;
  65.             Rfolder := ord(stdReply.sfIsFolder) <> 0;        { Argghhh!  Bloody Apple and there C booleans! }
  66.             RfType := stdReply.sfType;
  67.             RvRefNum := stdReply.sfFile.vRefNum;
  68.             RdirID := stdReply.sfFile.parID;
  69.             RfName := stdReply.sfFile.name;
  70.         end;
  71.     end;
  72.  
  73.     procedure SetOldReply (var reply: MySFReply; oldReply: SFReply);
  74.         var
  75.             oe: OSErr;
  76.     begin
  77.         with reply do begin
  78.             Rgood := oldReply.good;
  79.             Rfolder := oldReply.copy;
  80.             RfType := oldReply.fType;
  81.             oe := GetDirID(oldReply.vRefNum, RvRefNum, RdirID);
  82.             RfName := oldReply.fName;
  83.         end;
  84.     end;
  85.  
  86.     procedure GetFile (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; var reply: MySFReply);
  87.         var
  88.             stdReply: StandardFileReply;
  89.             oldReply: SFReply;
  90.     begin
  91.         with reply do
  92.             if has_newStdFile then begin
  93.                 StandardGetFile(ffilter, numTypes, typeList, stdReply);
  94.                 SetStdReply(reply, stdReply);
  95.             end
  96.             else begin
  97.                 SFGetFile(MFSPt, '', ffilter, numTypes, typeList, nil, oldReply);
  98.                 oldReply.copy := false;
  99.                 SetOldReply(reply, oldReply);
  100.             end;
  101.     end;
  102.  
  103.     procedure GetFile1 (t: OSType; var reply: MySFReply);
  104.         var
  105.             typeList: SFTypeList;
  106.     begin
  107.         if t = OSType(noType) then
  108.             GetFile(nil, -1, typeList, reply)
  109.         else begin
  110.             typeList[0] := t;
  111.             GetFile(nil, 1, typeList, reply);
  112.         end;
  113.     end;
  114.  
  115.     procedure PutFile (str, origName: str255; var reply: MySFreply);
  116.         var
  117.             stdReply: StandardFileReply;
  118.             oldReply: SFReply;
  119.     begin
  120.         with reply do
  121.             if has_newStdFile then begin
  122.                 StandardPutFile(str, origname, stdReply);
  123.                 SetStdReply(reply, stdReply);
  124.             end
  125.             else begin
  126.                 SFPutFile(MFSPt, str, origname, nil, oldReply);
  127.                 oldReply.copy := false;
  128.                 SetOldReply(reply, oldReply);
  129.             end;
  130.     end;
  131.  
  132.     procedure GrayButton (dlg: dialogPtr; item: integer);
  133.         var
  134.             kind: integer;
  135.             h: handle;
  136.             r: rect;
  137.             ps: PenState;
  138.     begin
  139.         GetDItem(dlg, item, kind, h, r);
  140.         InsetRect(r, 4, 2);
  141.         GetPenState(ps);
  142.         PenPat(gray);
  143.         PenMode(patBic);
  144.         PaintRoundRect(r, 3, 3);
  145.         SetPenState(ps);
  146.     end;
  147.  
  148.     procedure UngrayButton (dlg: dialogPtr; item: integer);
  149.         var
  150.             kind: integer;
  151.             h: handle;
  152.             r: rect;
  153.     begin
  154.         GetDItem(dlg, item, kind, h, r);
  155.         Draw1Control(controlHandle(h));
  156.     end;
  157.  
  158.     procedure UpdateButton (dlg: dialogPtr; item: integer; active: boolean);
  159.     begin
  160.         if not active then
  161.             GrayButton(dlg, item);
  162.     end;
  163.  
  164.     procedure InitButton (dlg: dialogPtr; item: integer; var active: boolean; new: boolean);
  165.         var
  166.             kind: integer;
  167.             h: handle;
  168.             r: rect;
  169.             ps: PenState;
  170.     begin
  171.         active := new;
  172.         GetDItem(dlg, item, kind, h, r);
  173.         if active then
  174.             HiliteControl(controlHandle(h), 0)
  175.         else
  176.             HiliteControl(controlHandle(h), 255);
  177.     end;
  178.  
  179.     procedure SetButton (dlg: dialogPtr; item: integer; var active: boolean; new: boolean);
  180.     begin
  181.         if active <> new then begin
  182.             if new then
  183.                 UngrayButton(dlg, item)
  184.             else
  185.                 GrayButton(dlg, item);
  186.             InitButton(dlg, item, active, new);
  187.         end;
  188.     end;
  189.  
  190.     var
  191.         oldReply: SFReply;
  192.         newReply: StandardFileReply;
  193. { item1 is ThisFolder }
  194.         item1: integer;
  195.         button1: boolean;
  196.         active1: boolean;
  197.  
  198.     procedure SetButtons (dlg: dialogPtr);
  199.         var
  200.             new1: boolean;
  201.     begin
  202.         if has_newStdFile then begin
  203.             new1 := newReply.sfFile.parID <> 1; { everywhere except  desktop???? }
  204.         end
  205.         else begin
  206.             new1 := true;
  207.         end;
  208.         SetButton(dlg, item1, active1, new1);
  209.     end;
  210.  
  211.     function ButtonModalFilter (dlg: dialogPtr; var er: eventRecord; var item: integer): boolean;
  212.     begin
  213.         SetButtons(dlg);
  214.         if (er.what = updateEvt) and (dlg = dialogPtr(er.message)) then begin
  215.             UpdateButton(dlg, item1, active1);
  216.         end;
  217.         ButtonModalFilter := false;
  218.     end;
  219.  
  220.     function ButtonModalFilterSys7 (dlg: dialogPtr; var er: eventRecord; var item: integer; data: ptr): boolean;
  221.     begin
  222.         ButtonModalFilterSys7 := ButtonModalFilter(dlg, er, item);
  223.     end;
  224.  
  225.     function ButtonHook (item: integer; dlg: DialogPtr): integer;
  226.     begin
  227.         if not has_newStdFile or (GetWRefCon(dlg) = longint(sfMainDialogRefCon)) then begin
  228.             if item = sfHookFirstCall then begin
  229.                 button1 := false;
  230.                 InitButton(dlg, item1, active1, active1);
  231.                 SetButtons(dlg);
  232.             end;
  233.             if active1 then begin
  234.                 if item <> sfHookLastCall then begin
  235.                     button1 := item = item1;
  236.                     if button1 then
  237.                         item := sfItemOpenButton;
  238.                 end;
  239.             end;
  240.         end;
  241.         ButtonHook := item;
  242.     end;
  243.  
  244.     function ButtonHookSys7 (item: integer; dlg: DialogPtr; data: ptr): integer;
  245.     begin
  246.         ButtonHookSys7 := ButtonHook(item, dlg);
  247.     end;
  248.  
  249.     procedure PutFolder (str, origName: str255; id: integer; var reply: MySFreply);
  250.     begin
  251.         if has_newStdFile then begin
  252.             item1 := 13;
  253.             active1 := true;
  254.             CustomPutFile(str, origName, newReply, id + 1, MFSPt, @ButtonHookSys7, @ButtonModalFilterSys7, nil, nil, nil); {@ButtonModalFilterSys7}
  255.             SetStdReply(reply, newReply);
  256.             reply.Rfolder := button1;
  257.         end
  258.         else begin
  259.             item1 := 9;
  260.             active1 := true;
  261.             SFPPutFile(MFSPt, str, origname, @ButtonHook, oldReply, id, nil);
  262.             oldReply.copy := button1;
  263.             SetOldReply(reply, oldReply);
  264.         end;
  265.     end;
  266.  
  267.     function CallFileFilterSys7 (pb: CInfoPBPtr; addr: ptr): boolean;
  268.     inline
  269.         $205F, $4E90;
  270.  
  271.     function FileFilterSys7 (pb: CInfoPBPtr; addr: ptr): boolean;
  272.     begin
  273.         if (BAND(pb^.ioFlAttrib, $0010) = 0) and (addr <> nil) then
  274.             FileFilterSys7 := CallFileFilterSys7(pb, addr)
  275.         else
  276.             FileFilterSys7 := false;
  277.     end;
  278.  
  279.     procedure GetFolder (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; id: integer; var reply: MySFReply);
  280.     begin
  281.         if has_newStdFile then begin
  282.             item1 := 10;
  283.             active1 := true;
  284.             CustomGetFile(@FileFilterSys7, numTypes, typeList, newReply, id + 1, MFSpt, @ButtonHookSys7, @ButtonModalFilterSys7, nil, nil, ffilter);
  285.             SetStdReply(reply, newReply);
  286.             reply.Rfolder := button1;
  287.         end
  288.         else begin
  289.             item1 := 11;
  290.             active1 := true;
  291.             SFPGetFile(MFSPt, '', ffilter, numTypes, typeList, @ButtonHook, oldReply, id, nil);
  292.             oldReply.copy := button1;
  293.             SetOldReply(reply, oldReply);
  294.         end;
  295.     end;
  296.  
  297. end.