{$NewDeskAcc Open Close Action Init -1 -1 '--ShowPic5\H**'} {$keep 'Showpic'} {$optimize 7} {$names-} PROGRAM ShowPicNDA; { This is Version 5.4, see comments below } { Version 1.0, by Lunatic. Copyright 5/17/88 Bruce Mendez Inspiration for parts of this code was provided by the Meltdown NDA by Jason Harper. Help during development of v 1.0 was provided by Guy T. Rice and the "gang" in the Apple II section on GEnie. Thanks, guys! Bruce... Any comments, questions, suggestions, spare money (any amount will be accepted), criticisms, or anything else I didn't think of can be sent to me at 3361 St. Michael Ct. Palo Alto, CA 94306 or on GEnie: L.BRUCE (as in Lunatic Bruce) } { Version 2 and later by Dave Leffler written in ORCA Pascal v 1.2 This program is Freeware. Distribute freely, but don't sell! With version 5 the only thing that carries over from version 1 is the name and the fact that this NDA loads and displays Screen graphics. It has been completely rewritten at this point and includes no original code from version 1.0 Lets you view: Uncompressed Graphics ($C1 or BIN), Compressed Graphics ($C0, aux $0001), Compressed Apple Prefered format ($C0, aux $0002), Compressed PaintWorks format ($C0, aux $0000), Compressed PaintWorks Gold format ($C0, aux $8000), PrintShop GS Graphics ($F8, aux $C323) 3200 Color Pictures ($04, TXT or $06, BIN) MUST end with ".3200" or be ($C1, aux $0002) French 3200 Color APP pictures ($04, TXT or $06, BIN) MUST end with ".3201" GIF graphics ($04, TXT or $06, BIN) MUST end with ".GIF" Converts 320 mode color to 640 mode color (default palette), Converts 320 mode color to 640 mode grey scale (semi-intelligent) Converts to 320 or 640 mode with or without default palette (new to 4.6) View multiple pictures for a slide show effect (New to 4.x) Shows selected Top, Middle, or Bottom of Paint graphics (New to 4.x) with simulated scrolling (New to 4.4x) Adds Continuous Slide Show Display (New to 4.56) Allows overriding of error display for invalid files, Allows setting of delay factor for slide shows, Now available as a standard window. (New to 5.x) Lets you save: Uncompressed Screen file (PIC, $C1), Compressed Graphics file, APF (PNT, $C0, aux $0002) (New to 4.x) Double high APF graphics (New to 4.6) Skips over Folders and Changes prefix if one folder selected (4.7) Inspired by Bruce Mendez and Stephen P. Lepisto. Stephen wrote the original Assembler Routine used in LoadPic. Also, Jonah Stich wrote the original 3200 color routines. I must thank Stephan A Bennett for the LZW decoding routines for the GIF pictures and whomever wrote MyGIF for the IBM. I Couldn't have done this without Bruce, Stephen, Jonah, Stephen, and my strength in the Lord, Thanks! Catch me on GEnie as D.LEFFLER America Online as DAVE.L32 } USES Common, QuickDrawII, MenuMgr, EventMgr, WindowMgr, MemoryMgr, ToolLocator, DeskMgr, MscToolSet, DialogMgr { required for SFToolSet }, SFToolSet, GSOS, ResourceMgr, ControlMgr, IntegerMath, LineEdit; const rControlTemplate = $8004; { standards } rPString = $8006; rWindParam1 = $800E; NDAwindowID = $40A6E; { my resource #'s } HelpwindowID = $1BB78; myPStringID = $040A71; { # for LineEdit value } myCBTID = $040A73; { # for CheckBox #1 value } myCBT2ID = $040A74; { # for CheckBox #2 value } Showbutton = 1; { my item #'s } Helpbutton = 2; DelayEditLine = 3; ErrorCheckBox = 4; RestrictCheckBox = 5; SFToolSet = 23; TXT = $04; { filetype for Text files } BIN = $06; { filetype for Binary files } DIR = $0F; { filetype for subdirectories } PNT = $C0; { filetype for packed graphics } PW = $00000; { auxtype for PaintWorks graphics } PK = $00001; { auxtype for PackBytes graphics } APF = $00002; { auxtype for Apple Preferred Format graphics } PWG = $08000; { auxtype for PaintWorks Gold 640 mode graphics } PIC = $C1; { filetype for unpacked graphics } LGTHSCRN = 0032768; { length of screen file } PICTURE = $00001; { auxtype for QuickDraw II picture } C3200 = $00002; { auxtype for 3200 color graphics } PSGS = $F8; { filetype for PrintShop GS files } PSGSAUX = $0C323; { auxtype for PrintShop GS files } type pathname2 = record { standard pathname entry } nameLength : byte; prefix1 : byte; prefix2 : byte; fileName : packed array [1..253] of char; end; fileEntryArray = record { standard file entry } fileType : integer; auxFileType : longint; path : pathname2; end; namesBuffer = record {structure of multiGetFile return } bufferLength : integer; fileEntry : fileEntryArray; end; namesptr = ^namesBuffer; nHandle = ^namesptr; replyRecord2 = record good : integer; namesHandle : nHandle; end; inparm1 = record { used with LoadPict } Pictptr : ptr; filename : gsosInStringPtr; bottom : integer; end; inparm1ptr = ^inparm1; inparm2 = record { used with ConvPict, SavePict, Load3200 } Pictptr : ptr; value : integer; value2 : ptr; end; inparm2ptr = ^inparm2; CheckBoxTemplate = record { settings stored in the resource fork } pCount : integer; ID : longint; rect1 : longint; rect2 : longint; procdef : longint; flag : integer; moreflags : integer; refCon : longint; titleRef : longint; initialValue : integer; { this is really the only one I need } end; CBTptr = ^CheckBoxTemplate; CBTHndl = ^CBTptr; Str = packed array [1..3] of byte; { needed for LineEdit record } StrPtr = ^Str; StrHndl = ^StrPtr; str2 = string[2]; { needed for LineEdit record } str2ptr = ^str2; str2hndl = ^str2ptr; dirEntryptr = ^dirEntryOSDCB; { get directory entry } var { global vars } { most of these variables are not really global, but the fool thing crashes if they aren't put this way } ItsOpen : boolean; { Flag for our window open } ShowPicID : Integer; { our memory ID } ShowPicpath : gsosInString; { ShowPic's pathname } myWindPtr : grafPortPtr; { NDA window pointer } myWindPtr1 : grafPortPtr; { Help window pointer } nameptr : namesptr; { most of these variables are not } path1ptr : ptr; { general pointer, filename pointer } path1 : gsosInString; { the current file's pathname } path2ptr : ptr; { general pointer, filetype pointer } mytype : integer; { the current file's filetype } myaux : integer; { the current file's auxtype } TypList : typeList5_0; { our typelist for GetFile } eventrec : EventRecord; { our event record } myReply : replyRecord2; { our reply record } myPrefix : setPrefixOSDCB; { for changing the prefix } myPrefs : prefsOSDCB; { for changing system preferences } oldPrefs : integer; { old system preferences } myLevel : levelOSDCB; { for changing file level } oldLevel : integer; { old system level } changed : boolean; { flag for changed values } showerrors : boolean; { flag for error messages } newshowerrors : integer; { it's new value } restrict : boolean; { flag for restrict files } newrestrict : integer; { it's new value } delay : integer; { delay factor } newdelay : integer; { it's new value } error : integer; { error # } SizeofImage : LongInt; { size of screen value } Screen : ptr; { pointer to screen area } Screen1 : ptr; { pointer to shadow screen area } temp : integer; { need I say } templ : longint; CurrResFileID, { old Resource file ID } CurrResAppID, { old application ID } ResFileID : Integer; { my Resource file ID } delayStr : String; { string for saving to resource } isGIF : boolean; { is it a GIF picture? } is3200 : boolean; { is it a 3200 color picture? } timer : integer; { need I say? } { if the functions below were in Pascal this would be a huge file } function loadpict(pictparms1:inparm1ptr):integer;extern; { assembler routine } function load3200(pictparms2:inparm2ptr):integer;extern; { assembler routine } function convpict(pictparms2:inparm2ptr):integer;extern; { assembler routine } function savepict(pictparms2:inparm2ptr):integer;extern; { assembler routine } function LGetPathname2(userID,fileNum:integer):gsosInStringPtr;tool ($11, $22); { Loader Routine } { Below is needed to bypass prototype checking } function OpenResourceFile_(openAccess: integer; mapAddress: Procptr; fileName: gsosInStringptr): integer; tool ($1E, $0A); procedure SFMultiGet2_(whereX, whereY, promptVerb : integer; promptRef: univ longint; filterProcPtr: procPtr; theTypeList: typeList5_0; var theReply: replyRecord2); tool ($17, $14); {$ToolParms+} {$DataBank+} procedure DrawMyWindow; { How we update the NDA window, pretty simple } begin DrawControls(myWindPtr); end; { DrawMyWindow } {$DataBank-} {$ToolParms-} function Upper(ch: char): char; { I saw this somewhere! } begin if ch in ['a'..'z'] then ch := chr(ord(ch) - ord('a') + ord('A')); Upper := ch; end; { Upper } {$ToolParms+} {$DataBank+} function GetMyFiles(DirPtr : dirEntryPtr):integer; { we only want to show our files } var ftype : integer; auxtype : longint; flength : longint; filename : pString; size, i : integer; begin ftype := DirPtr^.fileType; { get filetype } auxtype := DirPtr^.auxType; { get auxillary filetype } flength := DirPtr^.eofValue; { get file length } size := DirPtr^.name^.theString.size;{ get filename } filename[0] := chr(size); for i := 1 to size do { convert gsos string to pString } filename[i] := Upper(DirPtr^.name^.theString.theString[i]); if ftype = DIR then GetMyFiles := displaySelect { Don't forget to show folders } else if ((ftype = PSGS) and (auxtype = PSGSAUX)) then GetMyFiles := displaySelect { Print Shop GS color graphic } else if ((ftype = PIC) and (auxtype <> PICTURE)) then GetMyFiles := displaySelect { unpacked graphic, not QDII Picture } else if ((ftype = PNT) and ((auxtype = PW) or (auxtype = PK) or (auxtype = APF) or (auxtype = PWG))) then GetMyFiles := displaySelect { packed graphic } else if ((ftype = BIN) or (ftype = TXT)) then begin if not restrict then GetMyFiles := displaySelect else if ((flength = LGTHSCRN) or { screen size } (pos('.3200',filename) > 0) or { ends with ".3200" } (pos('.3201',filename) > 0) or { ends with ".3201" } (pos('.GIF',filename) > 0)) then { ends with ".GIF" } GetMyFiles := displaySelect { proper length, GIF or 3200 color pic } else GetMyFiles := noDisplay; end { if BIN or TXT } else GetMyFiles := noDisplay; end; {$DataBank-} {$ToolParms-} procedure GetValues; { Get show errors and delay from window } var tempStrHand : StrHndl; { handle of our editline } tempSize,j : Integer; { will hold size and counter } theEditLine : leRecHndl; { LERecord Handle } tempStr : String; { our string } begin { First the easy part, the checkbox } newshowerrors := GetCtlValue(GetCtlHandleFromID(myWindPtr, ErrorCheckBox)); if ((newshowerrors = 0) <> showerrors) then changed := true; { set changed for writing out the resource } showerrors := (newshowerrors = 0); { change an integer to boolean } newrestrict := GetCtlValue(GetCtlHandleFromID(myWindPtr, RestrictCheckBox)); if ((newrestrict = 1) <> restrict) then changed := true; { set changed for writing out the resource } restrict := (newrestrict = 1); { change an integer to boolean } theEditLine := { Now, the hard part, the edit line, get LEControl Handle } LERecHndl(GetCtlTitle(GetCtlHandleFromID(myWindPtr,DelayEditLine))); tempStrHand:=StrHndl(LEGetTextHand(theEditLine)); { Now get text handle } tempSize:=LEGetTextLen(theEditLine); { and size } for j:=0 to tempSize do { move it to our string } tempStr[j]:=Chr(tempStrHand^^[j]); tempStr[tempSize+1] := chr(0); { make it a "C" string } delayStr[0]:= chr(tempSize); { now for the one to } for j := 1 to tempSize do { save in the resource } delayStr[j]:=Chr(tempStrHand^^[j]); newdelay := Dec2Int(@tempStr,3,0); { change it to a number } if (newdelay <> delay) then changed := true; { set changed for writing out the resource } delay := newdelay; { set new value } end; { Get Values } procedure SetPrefs; { Set system up to ask for any disks not found } begin GetSysPrefsGS(myPrefs); { we'll need the old value to restore it later } oldPrefs := myPrefs.preferences; myPrefs.preferences := (myPrefs.preferences & $1FFF) | $8000; SetSysPrefsGS(myPrefs); end; { Get Prefs } procedure ResetPrefs; { Reset back to old system preferences } begin myPrefs.preferences := oldPrefs; SetSysPrefsGS(myPrefs); end; { ResetPrefs } function Open: grafPortPtr; { Open our windows and start things } begin if ItsOpen then { already open! Bring to the front } SelectWindow(myWindPtr) else begin { not open! We'll make it } myWindPtr := Nil; { we haven't opened it yet } CurrResAppID := GetCurResourceApp; { save application ID } ResourceStartup(ShowPicID); { Tell Resource Manager we're here } error := toolerror; if (error <> 0) then { Must be a problem, don't make NDA } error := ErrorWindow(0,nil,error) else begin { Open our resources } GetLevelGS(myLevel); { Get old system file level } oldLevel := myLevel.level; { and then set ours to 0 } myLevel.level := 0; { so it isn't closed } SetLevelGS(myLevel); SetPrefs; { we're going to need our boot disk } ResFileID := OpenResourceFile_(3,nil,@ShowPicpath); error := toolerror; if (error <> 0) then { couldn't open them!, don't continue } error := ErrorWindow(0,nil,error) else begin { change to our resource file } CurrResFileID := GetCurResourceFile; { save current } SetCurResourceFile(ResFileID); error := toolerror; if (error <> 0) then { can't get our resource? } error := ErrorWindow(0,nil,error) else begin { Let's make our windows } myWindPtr1 := NewWindow2(nil,nil,nil,nil,resourceVerb, HelpWindowID,rWindParam1); { create Help window } myWindPtr := NewWindow2(nil,nil,@DrawMyWindow,nil,resourceVerb, NDAwindowID,rWindParam1); { create the NDA window } SetSysWindow(myWindPtr); { make it an NDA window } ItsOpen := true; { the windows are open } end; { else } SetCurResourceFile(CurrResFileID); { restore current file } end; { if resource opened without error } ResetPrefs; { go back to old setting } myLevel.level := oldLevel; SetLevelGS(myLevel); { go back to old level } end; { if resource manager started without error } SetCurResourceApp(CurrResAppID); { restore current app } end; { if open or not } GetValues; { to initialize them } changed := false; { initialize values changed flag } Open := myWindPtr; { return window ptr to Desk Manager } end; { Open } procedure Close; var mystring : str2hndl; { resource handles } mybox : CBTHndl; mybox2 : CBTHndl; begin if ItsOpen then begin { Can't do a thing unless already open } GetValues; { Look for changed values } CloseWindow(myWindPtr); { Close ALL our windows } CloseWindow(myWindPtr1); SetPrefs; { We'll need the disk } if changed then begin { something's changed, update resources } mystring := str2hndl(LoadResource(rPString,myPStringID)); mystring^^ := delayStr; { load the EditLine entry and change } mybox := CBTHndl(LoadResource(rControlTemplate,myCBTID)); { load the Checkbox template and change initial value } mybox^^.initialValue := ord(not showerrors); mybox2 := CBTHndl(LoadResource(rControlTemplate,myCBT2ID)); { load the Checkbox template and change initial value } mybox2^^.initialValue := ord(restrict); MarkResourceChange(true,rPString,myPStringID); { Yep, changed } MarkResourceChange(true,rControlTemplate,myCBTID); MarkResourceChange(true,rControlTemplate,myCBT2ID); end; { if changed } CloseResourceFile(ResFileID); { close it down, by the book } ResourceShutdown; { Tell Resource Manager we're gone, write and close } ResetPrefs; { We don't need to ask for a disk anymore } end; { if Its Open } ItsOpen := false; { Tell us the windows are closed } end; { Close } procedure Init(Code:Integer); { Only called by DeskStartup or DeskShutdown } begin if (Code <> 0) then begin { We must be starting up } ItsOpen := false; { obviously the window's not open } ShowPicID := MMStartup; { Get our ID } ShowPicpath := LGetPathName2(ShowPicID,$0001)^; { Get our pathname } error := toolerror; { We'll need it for resources } if (error <> 0) then delay := ErrorWindow(1,nil,error); { uh oh! No pathname! } Screen := pointer($E12000); { where graphics are in memory } Screen1 := pointer($012000); { where shadow graphics are in memory } SizeofImage := $08000; { SUPER Hires size } myPrefs.pcount := 1; { set up GS/OS DCBs } myLevel.pcount := 1; with myPrefix do begin pCount := 2; prefixNum := 8; { We'll mess with prefix #8 } end; { with } end { if Code <> 0 } else begin if ItsOpen then { shutting down so Close it first } Close; MMShutDown(ShowPicID); { Tell Memory Manager We're through } end; { else } end; { Init } procedure Action(Code:Integer; evtrecptr:eventRecPtr); { Main Routine } var ScreenHandle : Handle; { Memory for saved screen } ScreenHandle1 : Handle; { Memory for saved shadow screen } ToolsZeroPage : Handle; { Memory for SFToolSet } SFAlreadyUp : boolean; { Did we start tools flag } procedure HelpWindow; { Show Help Window, wait for keypress } begin ShowWindow(myWindPtr1); { Make it visible } SelectWindow(myWindPtr1); { Bring it to the front } DrawControls(myWindPtr1); { Fill it out } repeat until GetOSEvent(MDownMask+KeyDownMask,eventrec); { wait for key } HideWindow(myWindPtr1); { Make it invisible } end; { HelpWindow } Procedure DoOpenPic; { main routine } var inprm1 : inparm1; { parameters for Load } inptr1 : inparm1ptr; { pointer to it } inprm2 : inparm2; { parameters for Save or Convert } inptr2 : inparm2ptr; { pointer to it } count : integer; { # of picture we're working on } kontinu : boolean; { continuous loop flag } redo1 : boolean; { go again flag if DIR selected } tempb : boolean; { temporary boolean } filestring : String; { for checking filename .3200 .GIF } i : integer; { counter } function StartSF: integer; { Start Standard File ToolSet } var TZPptr : ptr; { pointer to our memory } SFerror : integer; { error # } begin ToolsZeroPage := NewHandle($400, { allocate 4 pages for System 5.x } ShowPicID, { User ID for memory blocks } attrBank+attrFixed+attrLocked+attrPage, { Attributes } nil); { start in bank 0 } LoadOneTool(SFToolSet,$0301); { load Standard File v 3.1+ } SFerror := ToolError; if (SFerror = 0) then begin { loaded, let's start it } TZPptr := ToolsZeroPage^; { Dereference Handle to a pointer } SFStartUp(ShowPicID, { UserID for memory blocks } Ord(TZPptr)); { low address of zero page pointer } SFAlreadyUp := false; { WE started the tool } end; { if not error }; StartSF := SFerror; { return the error } end; { StartSF } procedure StopSF; { Shutdown Standard File ToolSet } begin SFShutDown; { Turn it off } UnLoadOneTool(SFToolSet); { Unload it } DisposeHandle(ToolsZeroPage); { Get rid of the memory } end; { StopSF } procedure SaveScreen; { Save the current SHR screen to a buffer } begin PtrtoHand(Screen, ScreenHandle, SizeOfImage); { Move the data } end; { SaveScreen } procedure RestoreScreen; { Bring the old SHR screen back } begin HandtoPtr(ScreenHandle, Screen, SizeOfImage); { Move the data back } end; { RestoreScreen } function SaveScreen1:integer; { Save the current shadow screen to a buffer } begin { for 3200 pictures } ScreenHandle1 := NewHandle(SizeOfImage, ShowPicID, 8, nil); { Allocate a block of memory to save current shadow screen } error := toolerror; if (error = 0) then begin { Must not be a problem } PtrtoHand(Screen1, ScreenHandle1, SizeOfImage); { Move the data } SaveScreen1 := 0; end else if (error = $0201) then SaveScreen1 := $DA05 { change it to an understandable error message } else SaveScreen1 := error; { otherwise give them the real error } end; { SaveScreen1 } procedure RestoreScreen1; { Bring the old shadow screen back } begin { for 3200 pictures } HandtoPtr(ScreenHandle1, Screen1, SizeOfImage); { Move the data back } DisposeHandle(Screenhandle1); { Get rid of our memory } end; { RestoreScreen1 } function ErrorMsg(errornum : integer):boolean; { Error display routine } begin If (errornum <> 0) then begin ErrorMsg := true; { an error occured } if showerrors then begin { do they want to see it? } sysbeep; { get their attention } RestoreScreen; { put desktop back } ShowCursor; { give them a cursor } temp := ErrorWindow(0,nil,errornum); { show error } HideCursor; { not in my picture, you don't } end; { if showerrors } end { if error <> 0 } else ErrorMsg := false; { Indicate No Error occured } end; { ErrorMsg } procedure GetMyKey; { Wait for a event, then take action } label 1, 2; { bad practice, but needed for error routines } var key : char; { key pressed } redo : boolean; { flag to restore timer } i : integer; { counter } procedure SaveIt; begin tempb := showerrors; { it'd sure be nice to see } showerrors := true; { errors here } redo := not ErrorMsg(savepict(inptr2)); showerrors := tempb; { back to the old way } end; { SaveIt } begin inptr2^.pictptr := screen; 2: timer := delay * 323 + 2; { let's get a true number } if is3200 then timer := 2; repeat if (not is3200) then for i := 1 to 1000 do begin end; { timer delay } timer := timer - 1; { tick, tick tick } until (GetOSEvent(MDownMask+KeyDownMask+autoKeyMask, eventrec) or (timer = 0)); { loop until an event occurs or timer runs out } redo := false; { reset redo variable } if timer <> 0 then begin 1: if (eventrec.eventWhat = KeyDownEvt) or { get keypress } (eventrec.eventWhat = autoKeyEvt) then begin key := Upper(chr(ord(eventrec.eventMessage & $007F)));{ what is it? } if (key = chr($B)) then begin { Scroll up ^K } if (not is3200) then begin if ((inptr1^.bottom & $C0) > 0) then begin inptr1^.bottom := inptr1^.bottom - $40; redo := not ErrorMsg(loadpict(inptr1)); end else redo := true; end; end { if key is Up } else if (key = chr($8)) then begin { Scroll left ^H } if (not is3200) then begin if isGIF then begin if (inptr1^.bottom > $100) then begin inptr1^.bottom := inptr1^.bottom - $400; redo := not ErrorMsg(loadpict(inptr1)); end { if > $100 } else redo := true; end { if isGIF } else if (inptr1^.bottom > 0) then begin inptr1^.bottom := inptr1^.bottom - $40; redo := not ErrorMsg(loadpict(inptr1)); end { is > 0 and not isGIF } else redo := true; end; { not is3200 } end { if key is Left } else if (key = chr($15)) then begin { Scroll right ^U } if (not is3200) then begin if isGIF then begin if (inptr1^.bottom < $800) then begin inptr1^.bottom := inptr1^.bottom + $400; redo := not ErrorMsg(loadpict(inptr1)); end { if < $800 } else redo := true; end { if isGIF } else if (inptr1^.bottom < $80) then begin inptr1^.bottom := inptr1^.bottom + $40; redo := not ErrorMsg(loadpict(inptr1)); end { if < $80 and not isGIF } else redo := true; end; { not is3200 } end { if key is Right } else if (key = chr($A)) then begin { Scroll down ^J } if (not is3200) then begin if ((inptr1^.bottom & $C0) < $80) then begin inptr1^.bottom := inptr1^.bottom + $40; redo := not ErrorMsg(loadpict(inptr1)); end else redo := true; end; end { if key is Down } else if (key = 'K') then begin { Continuous Slide Show } kontinu := not kontinu; redo := true; if kontinu then sysbeep; sysbeep; end { if key is K } else if (key = chr($1B)) then begin { Quit Show } count := myReply.good; kontinu := false; end { if key is Escape } else if (key = '?') or { Help me } (key = '/') then begin RestoreScreen; { let's get a desktop } HelpWindow; { show it } if (not is3200) then redo := not ErrorMsg(loadpict(inptr1)); { now back to the shoe } end { if key is ? } else if (is3200) then begin { something to kill it here } end { if it was a 3200 picture } else if (key = 'S') then begin { Save Screen } inptr2^.value := 0; SaveIt; end { if key is S } else if (key = 'P') then begin { Save APF } inptr2^.value := $8000; SaveIt; end { if key is P } else if (key = 'D') then begin { Save Double APF } inptr2^.value := $4000; SaveIt; end { if key is D } else if (key = ' ') then begin { Pause } repeat until GetOSEvent(MDownMask+KeyDownMask,eventrec); goto 1; { process keystroke for command } end { if key is space } else if (key = 'C') then begin { Color Convert } inptr2^.value := 0; redo := not ErrorMsg(convpict(inptr2)); end { if key is C } else if (key = 'G') then begin { Gray Scale Convert } inptr2^.value := 1; redo := not ErrorMsg(convpict(inptr2)); end { if key is G } else if (key = '3') then begin { 320 mode convert } inptr2^.value := 2; redo := not ErrorMsg(convpict(inptr2)); end { if key is 3 } else if (key = '#') then begin { 320 palette convert } inptr2^.value := 3; redo := not ErrorMsg(convpict(inptr2)); end { if key is # } else if (key = '6') then begin { 640 mode convert } inptr2^.value := 4; redo := not ErrorMsg(convpict(inptr2)); end { if key is 6 } else if (key = '^') then begin { 640 palette convert } inptr2^.value := 5; redo := not ErrorMsg(convpict(inptr2)); end; { if key is ^ } end; { if key down } end; { if timer <> 0 } if redo then goto 2; { go back and show picture again } end; { GetMyKey } Begin { DoOpenPic } GetValues; { Let's see what they are } SFAlreadyUp := false; SFAlreadyUp := SFStatus; { Is SFToolSet already up? } error := ToolError; If (SFAlreadyUp = false) or (error <> 0) then { Let's get it then } error := StartSF; { Make sure Standard File v 3.x is loaded } If (error = 0) then begin { no error, so we'll go to work } ScreenHandle := NewHandle(SizeOfImage, ShowPicID, 8, nil); { Allocate a block of memory to save current screen } TypList.numEntries := 5; { our list of files to display } TypList.fileAndAuxTypes[1].flags := $8000; TypList.fileAndAuxTypes[1].fileType := PIC; { Load uncomp ($C1) pics } TypList.fileAndAuxTypes[1].auxType := 0; TypList.fileAndAuxTypes[2].flags := $8000; TypList.fileAndAuxTypes[2].fileType := PNT;{Load compressed ($C0) pics } TypList.fileAndAuxTypes[2].auxType := 0; TypList.fileAndAuxTypes[3].flags := $8000; TypList.fileAndAuxTypes[3].fileType := BIN;{ Load binary ($06) pictures} TypList.fileAndAuxTypes[3].auxType := 0; TypList.fileAndAuxTypes[4].flags := 0; TypList.fileAndAuxTypes[4].fileType := PSGS;{Load PrintShopGS graphics } TypList.fileAndAuxTypes[4].auxType := PSGSAUX; { only color graphics } TypList.fileAndAuxTypes[5].flags := $8000; TypList.fileAndAuxTypes[5].fileType := TXT; { Load text ($04) pictures } TypList.fileAndAuxTypes[5].auxType := 0; HideCursor; { Hide the cursor so that it isn't saved with the screen } SaveScreen; { Save the old SHR screen } Repeat { until redo1 is false } redo1 := false; { only redo1 if DIR } ShowCursor; { Show the cursor so that we can use SF } SFMultiGet2_(22, 77, 0, @'Select ALL the Pictures to Show:', @GetMyFiles, TypList, myReply); { Get the pictures } if (myReply.good > 0) then begin { Did they want some? } HideCursor; { Hide the cursor again } count := 1; { start with first file } kontinu := false; { No continuous slide show } path1ptr := @myReply.namesHandle^^.fileEntry.path; { get first pathname } inptr1 := @inprm1; { initialize pointers } inptr2 := @inprm2; inptr1^.pictptr := screen; repeat { until count > myReply.good } with path1 do begin { convert to gsosInString } theString := pStringptr(path1ptr)^; size := Length(pStringptr(path1ptr)^); end; mytype := integerptr(ord4(path1ptr) - 6)^;{ get filetype } myaux := integerptr(ord4(path1ptr) - 4)^; { get auxtype } inptr1^.filename := @path1; { set filename } inptr1^.bottom := 0; { top of picture } inptr2^.pictptr := @path1; { set filename } isGif := false; { initialize } is3200 := false; filestring := pStringptr(path1ptr)^; for i := 1 to length(filestring) do { convert to uppercase } filestring[i] := Upper(filestring[i]); if (mytype = DIR) then begin { a DIR selected } if (myReply.good = 1) then begin { only one ? } myPrefix.prefix := @path1; { set that prefix } SetPrefixGS(myPrefix); redo1 := true; { let's go again } end; { if single folder } end { if folder, so we can skip them } else if (((mytype = PIC) and (myaux = C3200))or (((mytype = BIN) or (mytype = TXT)) and ((pos('.3201',filestring) > 0) or (pos('.3200',filestring) > 0)))) then begin inptr2^.value := (delay + 1) * 45; is3200 := true; if not ErrorMsg(SaveScreen1) then begin; { save memory } tempb := ErrorMsg(Load3200(inptr2)); RestoreScreen1; { restore shadow memory } RestoreScreen; { picture gets trashed so cover it } GetMyKey; { process the keystroke } end; { able to get shadow storage space } end { if 3200 color picture } else if (((mytype = BIN) or (mytype = TXT)) and (pos('.GIF',filestring) > 0)) then begin isGif := true; if not ErrorMsg(LoadPict(inptr1)) then { do it } GetMyKey; { now for other commands } end { if GIF picture } else if not ErrorMsg(LoadPict(inptr1)) then { do it } GetMyKey; { now for other commands } path1ptr := pointer(ord4(path1ptr) + (ord(path1ptr^) & $00FF) + 7); { get next picture } count := count + 1; { increase picture # } if (count > myReply.good) and kontinu then begin count := 1; { end of list, but continuous show } path1ptr := @myReply.namesHandle^^.fileEntry.path; end; until (count > myReply.good); { at end of list? } DisposeHandle(pointer(myReply.namesHandle)); { get rid of it } end; { if good reply } RestoreScreen; { Restore the old SHR screen } until (redo1 = false); { was it a DIR? } ShowCursor; { Bring the cursor back } If not SFAlreadyUp then StopSF; { If we opened it, then close it } DisposeHandle(Screenhandle); { Get rid of our memory } end { if error = 0 } else begin { We had a problem starting the SFToolSet } showerrors := true; { they might like to see it } showerrors := ErrorMsg(error); { Show the error } end; { Problem } DrawControls(myWindPtr); { redraws my window, the program doesn't seem to } end; { DoOpenPic } begin { Action } { This is the easy part } SetPrefs; { We'll need our disk } if (Code = eventAction) then begin { an event! } eventrec := evtrecptr^; { copy record over to ours } eventrec.TaskData := 0; eventrec.taskMask := $0017BFFF; { what do we want TM to handle } eventrec.lastClickTick := 0; eventrec.ClickCount := 0; eventrec.TaskData2 := 0; { zero these out to get the } eventrec.TaskData3 := 0; { proper response from a } eventrec.TaskData4 := 0; { ROM 03 machine? } eventrec.lastClickPt.h := 0; eventrec.lastClickPt.v := 0; myaux := TaskMasterDA(-1,eventrec); { let the machine handle it } if (myaux = wInControl) then begin { was a control hit? } templ := eventrec.TaskData4; { which control hit? } if (templ = Showbutton) then DoOpenPic else if (templ = Helpbutton) then HelpWindow end { if wInControl } else if (myaux = wInSpecial) then { was it the edit menu? } Code := 1; { We handled Edit Menu item } end; { eventAction } ResetPrefs; { Through with disk } end; { Action } begin { There is no main program in an NDA } end. { but this is needed to compile properly }