version 6.50 4 FAdventure FSelect AboutSA FOptions AboutEngine 238 268 C:\Documents and Settings\steve\Desktop\advpda\advpda.ico 2 bDeviceInfo.dll WebBrowser.dll 2 bDeviceInfo.dll WebBrowser.dll 2 webby:WebBrowser bdi:Class_bDeviceInfo 0 Sub designer addform(FAdventure,"Adventure PDA","",0,128,255)@ addimagebutton(fadventure,ButABC123,3,229,16,36,"",212,208,200,0,0,0,"cStretchImage","images\abc123.bmp",True,True,False,9)@ addimagebutton(fadventure,ButGo,92,168,18,18,"",0,0,0,0,0,0,"cStretchImage","images\butenter2.bmp",False,True,True,9)@ addtimer(fadventure,Timer1,55,130,100)@ addopendialog(fadventure,LoadDialog1,65,40,Save Files|*.sav)@ addsavedialog(fadventure,SaveDialog1,135,90,Save Files|*.sav)@ addimagebutton(fadventure,ButHELP,214,167,22,21,"",212,208,200,0,0,0,"cStretchImage","images\help.bmp",True,True,True,9)@ addimagebutton(fadventure,ButINV,190,167,21,21,"",212,208,200,0,0,0,"cStretchImage","images\inv.bmp",True,True,True,9)@ addimagebutton(fadventure,ButELC,142,167,20,21,"",212,208,200,0,0,0,"cStretchImage","images\move.bmp",True,True,True,9)@ addimagebutton(fadventure,ButMAG,165,167,21,21,"",212,208,200,0,0,0,"cStretchImage","images\magglass.bmp",True,True,True,9)@ addimagebutton(fadventure,ButGETDROP,112,167,27,21,"",212,208,200,0,0,0,"cStretchImage","images\\getdrop.bmp",True,True,True,9)@ addimagebutton(fadventure,ButDEL,202,211,36,18,"",0,0,0,0,0,0,"cStretchImage","images\butdel.bmp",False,False,False,9)@ addimagebutton(fadventure,ButENTER,202,229,36,36,"",128,255,128,0,0,0,"cStretchImage","images\butenter.bmp",False,False,False,9)@ addbutton(fadventure,ButSPACE,81,247,40,18,"__",255,255,185,0,0,0,True,False,10)@ addbutton(fadventure,ButB,141,247,20,18,"B",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButM,181,247,20,18,"M",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButN,161,247,20,18,"N",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButX,41,247,20,18,"X",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButC,61,247,20,18,"C",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButV,121,247,20,18,"V",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButZ,21,247,20,18,"Z",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButA,21,229,20,18,"A",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButS,41,229,20,18,"S",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButD,61,229,20,18,"D",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButH,121,229,20,18,"H",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButG,101,229,20,18,"G",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButF,81,229,20,18,"F",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButK,161,229,20,18,"K",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButL,181,229,20,18,"L",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButJ,141,229,20,18,"J",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButU,121,211,20,18,"U",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButP,181,211,20,18,"P",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButO,161,211,20,18,"O",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButI,141,211,20,18,"I",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButR,61,211,20,18,"R",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButT,81,211,20,18,"T",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButY,101,211,20,18,"Y",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButE,41,211,20,18,"E",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButW,21,211,20,18,"W",255,255,185,0,64,128,True,False,10)@ addbutton(fadventure,ButQ,1,211,20,18,"Q",255,255,185,0,64,128,True,False,10)@ addopendialog(fadventure,OpenDialog1,100,65,Data Files|*.DAT)@ addtextbox(fadventure,myCMD,1,167,90,20,"",221,221,221,0,0,0,True,True,False,8)@ addmenuitem(fadventure,MenuGame,"Game",True,False)@ addmenuitem(menugame,MenuNew,"New",True,False)@ addmenuitem(menugame,MenuLoad,"Load",True,False)@ addmenuitem(menugame,MenuSave,"Save",True,False)@ addmenuitem(menugame,MenuOptions,"Options",True,False)@ addmenuitem(fadventure,FAbout,"About",True,False)@ addmenuitem(fabout,FAboutScott,"Scott Adams Games",True,False)@ addmenuitem(fabout,FEngine,"The Game Engine",True,False)@ addform(FSelect,"Select Quest","",0,128,255)@ addlabel(fselect,AdvDesc,100,49,135,138,"",0,128,255,255,255,255,True,True,8)@ addimage(fselect,LOGO,5,5,187,20,"cStretchImage","images\head.bmp",0,128,255,True,True)@ addimage(fselect,ImgPic,7,77,90,108,"cStretchImage","",245,245,220,True,True)@ addbutton(fselect,ButOther,7,48,90,25,"Other...",255,255,179,0,0,0,True,True,9)@ addbutton(fselect,ButPlay,195,5,40,40,"Play",128,255,128,0,0,0,False,True,9)@ addcombo(fselect,PDselect,5,25,185,20,"",255,255,255,0,0,0,True,True,15,"Adventureland","Pirate Adventure","Mission Impossible","Voodoo Castle","The Count","Strange Odyssey","Mystery Fun House","Pyramid of Doom","Ghost Town","Savage Island One","Savage Island Two","Golden Voyage","Claymorgue Castle","Return to Pirates Isle","Buckaroo Banzai",8)@ addimage(fselect,Backgnd,6,76,92,110,"cCenterImage","",0,0,0,True,True)@ addform(AboutSA,"Scott Adams","",0,128,255)@ addtextbox(aboutsa,TxtScott,5,5,230,180,"The Scott Adams original text adventure games (data files) are copyrighted by Scott Adams and are shareware but the contribution is strictly voluntary and the amount is left to your own discretion. Please note that international cheques (in small amounts) are usually more expensive to cash than their face value is worth so please do not send same. Please send any payments to: Scott Adams, 706 Walnut Dell Road, Platteville WI 53818-9775, USA Homepage: http://www.msadams.com Email: msadams@msadams.com",255,255,128,0,0,128,True,True,True,8)@ addform(FOptions,"Options","",0,128,255)@ addbutton(foptions,KbdOnOff,127,103,55,25,"Kbd=Y",212,208,200,0,0,0,True,True,8)@ addcombo(foptions,Fontbold,180,15,50,22,"",255,255,128,0,0,0,True,True,2,"No","Yes",9)@ addlabel(foptions,labFontbold,140,15,35,20,"Bold",0,128,255,255,255,255,True,True,9)@ addcombo(foptions,Linkfix,180,75,50,22,"",255,255,128,0,0,0,True,True,2,"No","Yes",9)@ addlabel(foptions,labLinkfix,130,75,50,25,"Linkfix",0,128,255,255,255,255,True,True,9)@ addcombo(foptions,PDOptRvs,75,105,50,22,"",255,255,128,0,0,0,True,True,2,"Yes","No",9)@ addlabel(foptions,LabOptMsgs,10,105,75,20,"Msgs@Top",0,128,255,255,255,255,True,True,9)@ addlabel(foptions,LabOptLink,10,74,65,20,"Hyperlinks",0,128,255,255,255,255,True,True,9)@ addcombo(foptions,PDLinks,75,74,50,22,"",255,255,128,0,0,0,True,True,2,"Yes","No",9)@ addbutton(foptions,BUTAPPLY,185,103,50,25,"Apply",212,208,200,0,0,0,True,True,8)@ addcombo(foptions,PDFontSize,74,13,50,22,"",255,255,128,0,0,0,True,True,5,"1","2","3","4","5",9)@ addlabel(foptions,LabOptFontSize,10,15,65,20,"Font Size",0,128,255,255,255,255,True,True,9)@ addlabel(foptions,LabOptTheme,10,45,50,20,"Theme",0,128,255,255,255,255,True,True,9)@ addcombo(foptions,PDTheme,75,44,155,22,"",255,255,128,0,0,0,True,True,0,9)@ addarraylist(foptions,ArrayList1,165,40,65,20)@ addform(AboutEngine,"Game Engine","",0,128,255)@ addtextbox(aboutengine,txtAboutEngine,5,5,230,180,"This engine (v1.18) has been developed for Windows Mobile PDAs with .NET 2 framework. Please read the text files supplied if you wish to know more about the engine. The message board for this game is... http://games.groups.yahoo.com/group/adventurepda/ Many thanks to Scott Adams, the father of personal computer adventuring, for permission to create this engine and to Robert Schneck and Alan Cox whose drivers under C have been a great help. This engine is dedicated to the good old days of vintage computing! YOHO!",255,255,128,0,0,128,True,True,True,8)@ End Sub @EndOfDesignText@ ' ==================================================== ' === A D V E N T U R E P D A === ' ==================================================== ' A Scott Adams Adventure game driver ' Programmed 2008-2009: therealeasterbunny v1.18 ' ---------------------------------------------------- ' Thank you to Scott Adams who has graciously given me ' permission to create this driver for use with his ' game data files. ' ---------------------------------------------------- ' Thank you also to Alan Cox and Robert Schneck whose ' previous work under C was a great help in the ' creation of this work. ' ' - "Another Scott Free Driver" v1.20 - Robert Schneck ' - "ScottFree" v1.14 - Alan Cox ' ---------------------------------------------------- ' Other references: ' ' - 'Pirate Adventure' (Byte magazine, Dec 1980) ' ---------------------------------------------------- ' This game driver has been developed for PDAs running ' Windows Mobile with .NET 2 compact framework. It ' will also run on Windows PCs with .NET 2 installed ' and is dedicated to the good old days of vintage ' computing - YOHO! ' ==================================================== ' The user group for this game can be found at: ' http://games.groups.yahoo.com/group/adventurepda/ ' ==================================================== Sub Globals Dim myKbdOnOff myKbdOnOff = "Y" Dim KeyboardIsOff KeyboardIsOff = "N" Dim SecondCode SecondCode = 0 Dim hyper 'hyper = "file:///advpda.htm%3F" hyper = "about:" Dim AltHyper AltHyper = 0 Dim OptionsAltHyperOn OptionsAltHyperOn = "N" Dim aname aname = "href" ' --- HTML and THEMES Dim FontFace Dim Sleeping Sleeping = "N" Dim lastrefresh lastrefresh = "" Dim OpeningOther OpeningOther = "N" Dim HTML_BODY_BACKGROUND Dim HTML_LOOK_BACKGROUND Dim HTML_EXIT_BACKGROUND Dim HTML_MESG_BACKGROUND Dim HTML_ROOM_TEXT Dim HTML_LOOK_TEXT Dim HTML_EXIT_TEXT Dim HTML_MESG_TEXT Dim HTML_LOOK_PROMPT Dim HTML_EXIT_PROMPT Dim HTML_LOOK_HYPERLINK Dim HTML_EXIT_HYPERLINK Dim HTML_MESG_HYPERLINK Dim HTML_LINE_BREAK Dim HTML_START Dim HTML_LOOK_START,HTML_LOOK_END Dim HTML_EXIT_START,HTML_EXIT_END Dim HTML_MESG_START,HTML_MESG_END Dim HTML_LK_PROMPT_START Dim HTML_EX_PROMPT_START Dim HTML_PROMPT_END Dim HTML_END HTML_BODY_BACKGROUND = "#ffffa0" HTML_LOOK_BACKGROUND = "#ffa0ff" HTML_EXIT_BACKGROUND = "#ffbf60" HTML_MESG_BACKGROUND = "#ffffa0" HTML_ROOM_TEXT = "#000000" HTML_LOOK_TEXT = "#000000" HTML_EXIT_TEXT = "#000000" HTML_MESG_TEXT = "#000000" HTML_EXIT_PROMPT = "#800000" HTML_MESG_PROMPT = "#800000" HTML_HYPERLINK = "#0000ff" HTML_HYPERLINK = "#0000ff" HTML_HYPERLINK = "#0000ff" HTML_LINE_BREAK = "#808080" FontFace = "MS Sans Serif" FontSize = "1" HTML_START = "" HTML_LOOK_START = "
" HTML_LOOK_END = "
" HTML_EXIT_START = "
" HTML_EXIT_END = "
" HTML_MESG_START = "
" HTML_MESG_END = "
" HTML_LK_PROMPT_START = "" HTML_PROMPT_END = "" HTML_LINE = "
" HTML_END = "" Dim DisableLinks Dim Getting Dim Dropping Getting = "N" Dropping = "N" DisableLinks = "N" ' --- Constants GO_VERB = 1 LIGHT_SOURCE = 9 GET_VERB = 10 DROP_VERB = 18 CARRIED = -1 DESTROYED = 0 DARKBIT = 15 LIGHTOUTBIT = 16 Dim CarryingCanBe255 CarryingCanBe255 = "Y" ' --- Header Information Dim MagicHeader ' the magic header :) Dim NumItems ' number of items in adventure Dim NumActions ' number of actions in adventure Dim NumWords ' number of words (verbs and nouns) in adventure Dim NumRooms ' number of rooms in adventure Dim MaxCarry ' how much are we allowed to carry in adventure Dim PlayerRoom ' which room do we start in? Dim Treasures ' how many treasures do we need to win? Dim WordLength ' whats the word length for recognition? Dim NumMessages ' how many messages are there? Dim TreasureRoom ' where do we need to end up with the treasures? Dim LightTime ' what is the light time? Dim Checksum ' for save / load file recognition ' --- Footer Information Dim AdvVersion ' adventure version from header Dim AdvNo ' adventure number from header Dim MagicFooter ' magic footer ' --- Rooms Dim xRoomText(0) ' room descriptions Dim xRoomExit(0,0) ' rooms exits (redim'd to 'rooms,6' on loading) ' --- Items Dim xItemText(0) ' item descriptions Dim xItemLoc(0) ' item locations Dim xItemInitLoc(0) ' items initial locations Dim xItemAutoGet(0) ' item gettable (populated = gettable) ' --- Actions Dim xActionVocab(0) ' vocabulary Dim xActionVerb(0) ' verb Dim xActionNoun(0) ' noun Dim xActionCondition(0) ' condition Dim xActionAction(0) ' action ' --- words Dim xNouns(0) ' nouns Dim xVerbs(0) ' verbs ' --- Messages Dim xMessages(0) ' message texts ' --- General Stuff Dim xBitFlags(256) ' flags Dim verb ' verb input Dim noun ' noun input Dim NounText ' holds noun text Dim vnum ' verb number Dim nnum ' noun number Dim MyFileData ' Holds data stream from file Dim MyFileDataPos ' Holds the pointer to the current cursor position Dim L, X, Y ' loop counters Dim continuation ' all done with actions yet? Dim initial_load ' to cater for double look on adv 10 loading Dim done_intro_look ' ditto Dim LookCleared ' used for initial load / look issues Dim CarryingTooMuch ' set True if carrying too much Dim llPlayerRoom ' last look cmd had a player room of ... Dim llItemLoc(0) ' last look cmd had item locations as ... Dim llDark ' was the last look dark? Dim llClear ' did the last look clear the screen? Dim getNoun ' holds noun Dim GameHasTorch ' if games have torch (light time <5000) set to true Dim param(32) ' parameters for actions Dim act(4) ' for the action codes Dim ExitNames(6) ' holds North, East, etc... Dim LightRefill ' stores refill light time is used Dim CurrentCounter ' actions counter Dim CurrentSavedRoom ' current saved room Dim RoomSaved(256) ' save the rooms Dim Counters(256) ' our counters ... over the top maybe :) Dim myGETDROP Dim myMAG Dim myEL Dim myroomText Dim myroomExits Dim myAdventure Dim ComputerExit Dim OtherNegGet Dim txtLOOK Dim txtEXITS Dim txtMSG Dim LoadedFile Dim SeeLMAgain Dim ScreenType ScreenType = "240x240" LoadedFile = False Dim OptionsWarning Dim OptionsMyAdv Dim OptionsTheme Dim OptionsFontSize Dim OptionsLinks Dim OptionsLinksOn Dim OptionsRvsInfo Dim OptionsFontBold Dim Cancel Dim FoundItem Dim ThemeCustom Dim LastMsgHLColor ' Last Message Hyperlink Color Dim myLASTWORD1 Dim myLASTWORD2 Dim QuickDropChk Dim ABCIsOn ABCison = "Y" QuickDropChk = "N" OptionsFontBold = 0 Dim LinkGet Dim LinkDrop LinkGet = 0 LinkDrop = 0 Dim ImCarrying ImCarrying = 0 ThemeCustom = 4 Dim word1, word2 ' had to make these global to cater for drop all issue when dropping honey on adv1 ' --- Global dim the local arrays Dim startHere(0) Dim StartCarried(0) End Sub Sub xLeft(left_mystr,left_length) If left_mystr = "" Then Return Return SubString (left_mystr,0, left_length) End Sub Sub Trim(ttxt) Dim tch If StrLength(ttxt) < 2 Then Return ttxt tch = SubString(ttxt, 0, 1) Do While Asc(tch) < 33 ttxt = SubString(ttxt, 1, StrLength(ttxt)-1) tch = SubString(ttxt, 0, 1) Loop tch = SubString(ttxt, StrLength(ttxt)-1, 1) Do While Asc(tch) < 33 ttxt = SubString(ttxt, 0, StrLength(ttxt)-1) tch = SubString(ttxt, StrLength(ttxt)-1, 1) Loop Return ttxt End Sub Sub SetFlag(myflag) xBitFlags(myflag) = 1 End Sub Sub GetFlag(myflag) If xBitFlags(myflag) = 1 Then Return True Else Return False End Sub Sub ClearFlag(myflag) xBitFlags(myflag) = 0 End Sub Sub HX(htmlreplace) myHX = StrReplace(htmlreplace,">",">") myHX = StrReplace(myHX,"<","<") myHX = StrReplace(myHX,"{BR}","
") If OptionsFontBold = 1 Then myHX = "" & myHX & "" Return myHX End Sub Sub Right(right_mystr,right_length) If right_mystr = "" Then Return If right_length > StrLength(right_mystr) Then right_length = StrLength(right_mystr) Return SubString (right_mystr, StrLength (right_mystr) - right_length, right_length) End Sub Sub GetCommand(notYet) ' return false if output still needed ' notYet is true if some actions might correspond Dim gci Dim startRoom Dim gcflag Dim theItem Dim startHere(NumItems) Dim myTmpItems If (nnum = -1) Then ' no noun, so cant get it (/wear it!) AddTxtMsg ("I can't do that.
") Return True End If ' -------------------------------- ' GET ALL ' -------------------------------- If (nnum = -2) Then ' do a get all If IsDark = True Then ' if dark, then exit AddTxtMsg ("It's too dark to see!
") Return True End If gcflag = False CarryingTooMuch = False startRoom = PlayerRoom 'only get things that started off here (AND gettable) myTmpItems = "" For gci=0 To NumItems If (ItemHere(gci) = True) AND (StrLength(xItemAutoGet(gci))>0) Then myTmpItems = myTmpItems & "Y" Else myTmpItems = myTmpItems & "N" End If Next gci For gci = 0 To NumItems ' if it's still here, try to get it If (SubString(myTmpItems,gci,1) = "Y") AND (ItemHere(gci) = True) AND (xItemLoc(gci) = PlayerRoom) Then gcflag = True ' now attempt to get it AddTxtMsg (HX(xItemText(gci)) & ": ") ' attempting to grab item x Getting = "Y" LinkGet = gci nnum = WhichWord(xItemAutoGet(gci), "Nouns") getNoun = xItemAutoGet(gci) Getting = "N" PerformCommand LinkGet = 0 ' gci ' stop if we move, it gets dark, or hit too much If (PlayerRoom <> startRoom OR IsDark = True OR CarryingTooMuch = True) Then Exit 'For End If Next gci If (gcflag = False) Then ' if we didnt get anything, say so AddTxtMsg ("I don't see anything here!
") End If Return True End If ' --- done GET ALL LinkGet = 0 theItem = WhichItem(nnum, PlayerRoom) If (notYet AND (theItem < 0)) Then Return False If GetItem(theItem) = True Then If isdark Then AddtxtMsg ("It is dark but I felt around and got it.") Else AddTxtMsg ("OK
") End If Else If OtherNegGet = False Then AddTxtMsg("I am carrying too much.
") End If Return True End Sub Sub GetItem(myitem) OtherNegGet = False If (CountCarried >= MaxCarry) Then CarryingTooMuch = True Return False End If If myitem = -1 Then ' if no such item AddTxtMsg ("It's beyond my power to do that!
") OtherNegGet = True Return False End If If myitem = -2 Then ' not here AddTxtMsg ("Don't see it here!
") OtherNegGet = True Return False End If If myitem = -3 Then ' already carrying it AddTxtMsg ("I already have it.
") OtherNegGet = True Return False End If If LinkGet > 0 Then xItemLoc(LinkGet) = CARRIED LinkGet = 0 Else xItemLoc(myitem) = CARRIED End If Return True End Sub Sub WhichItem(nounnum,loc) ' nounNum must be >=0 or -3 ' if nounNum = -3 we use global getNoun (in case there are autoGets not in the noun list) Dim wii,wii2 Dim wiistr Dim wiresult ' num if item ' -1 if no such item ' -2 if item not at this location ' -3 if item carried (unless loc==CARRIED) SecondCode = 0 wiresult = -1 ' get noun If LinkGet > 0 Then SecondCode = LinkGet If LinkDrop > 0 Then SecondCode = LinkDrop If SecondCode = 0 Then For wii2 = 0 To NumItems If (xItemAutoGet(wii2) = xnouns(nounnum)) AND (xitemloc(wii2) = playerroom) Then SecondCode = wii2 End If Next wii2 End If If SecondCode > 0 Then For wii = SecondCode To SecondCode wiistr = "" If nounnum = -3 Then wiistr = getNoun Else wiistr = xNouns(nounnum) If StrLength(xItemAutoGet(wii)) > 0 AND (xLeft(StrToUpper(xItemAutoGet(wii)), WordLength) = xLeft(StrToUpper(wiistr), WordLength)) Then If (xItemLoc(wii) = loc) Then Return wii If (ItemCarried(wii) = True) Then Return -3 If (wiresult = -1) Then wiresult = -2 End If Next wii Else ' should this else be here or replace with another if of some kind? ###################################### For wii = 0 To NumItems wiistr = "" If nounnum = -3 Then wiistr = getNoun Else wiistr = xNouns(nounnum) If StrLength(xItemAutoGet(wii)) > 0 AND (xLeft(StrToUpper(xItemAutoGet(wii)), WordLength) = xLeft(StrToUpper(wiistr), WordLength)) Then If (xItemLoc(wii) = loc) Then Return wii If (ItemCarried(wii) = True) Then Return -3 If (wiresult = -1) Then wiresult = -2 End If Next wii End If Return wiresult End Sub Sub DropItem(di) Select di Case -1 AddTxtMsg ("It's beyond my power to do that.
") Case -2 AddTxtMsg ("I'm not carrying it!
") Case Else If LinkDrop > 0 Then xItemLoc(LinkDrop) = PlayerRoom LinkDrop = 0 Else xItemLoc(di) = PlayerRoom End If If StrLength(txtMsg)> 5 Then If StrToUpper(right(txtMsg,6)) <> "OK
" Then AddTxtMsg ("OK
") Else addTxtMsg ("OK
") End If End Select End Sub Sub DropCommand(notYet) ' return false if output still needed ' notYet is true iff some action might correspond Dim dci Dim startRoom Dim startdark Dim dcflag Dim theItem Dim startCarried(NumItems) Dim StillCarryingFromDrop Dim drii ' no noun If (nnum = -1) Then If word1 = "DROP" Then AddTxtMsg ("Drop what exactly?
") Else AddTxtMsg("I'm not sure what you mean.") End If Return True End If ' drop all If (nnum = -2) Then dcflag = False startdark = IsDark startRoom = PlayerRoom For dci = 0 To NumItems ' if still carried, try to drop it If (ItemCarried(dci)= True AND StrLength(xItemAutoGet(dci)) > 0) AND (xItemLoc(dci) = -1) Then dcflag = True AddTxtMsg (HX(xItemText(dci)) & ": ") LinkDrop = dci Dropping = "Y" nnum = WhichWord(xItemAutoGet(dci), "Nouns") getNoun = xItemAutoGet(dci) Dropping = "N" PerformCommand LinkDrop = 0 ' stop if we move or dark changes If ((PlayerRoom <> startRoom) OR (startdark <> IsDark)) Then Exit 'For End If Next dci ' If (dcflag = False) Then StillCarryingFromDrop = 0 For drii = 0 To NumItems If xItemLoc(drii) = CARRIED Then StillCarryingFromDrop = 1 End If Next drii If StillCarryingFromDrop = 0 Then AddTxtMsg ("I'm not carrying anything!
") Else AddTxtMsg ("I still appear to be carrying something - try dropping individually for these items.
") End If ' End If Return True End If ' --- end of drop all LinkDrop = 0 theItem = WhichItem(nnum, CARRIED) If (notYet AND theItem < 0) Then Return False DropItem (theItem) Return True End Sub Sub CheckForSpelling(cfsstr) Dim cfstemp Dim CFSL If StrLength(cfsstr) < 3 Then Return cfsstr cfsstr = StrReplace(cfsstr, " ", " ") cfsstr = StrReplace(cfsstr, ". " & Chr(10), "." & Chr(200)) cfsstr = StrReplace(cfsstr, "." & Chr(10), "." & Chr(200)) cfsstr = StrReplace(cfsstr, Chr(10), Chr(201)) cfsstr = StrReplace(cfsstr, Chr(200), "{BR}") cfsstr = StrReplace(cfsstr, " " & Chr(201), Chr(201)) cfsstr = StrReplace(cfsstr, Chr(201) & " ", Chr(201)) cfsstr = StrReplace(cfsstr, "." & Chr(201),".{BR}") cfsstr = StrReplace(cfsstr, "!" & Chr(201),"!{BR}") cfsstr = StrReplace(cfsstr, "?" & Chr(201),"?{BR}") cfsstr = StrReplace(cfsstr, Chr(201)," ") cfsstr = StrReplace(cfsstr, Chr(96), "'") Return cfsstr End Sub Sub LoadError(lemsg) Msgbox (lemsg,"Error",cMsgboxOK) AppClose End Sub Sub ClearScreen addtxtMSG ("") addtxtLOOK ("") addtxtEXITS ("") llClear = True End Sub Sub LoadFile(mydatfile) Dim mytmpstrfile Dim tmp1, tmp2 Dim ampatstart ResetGeneral ResetVars initial_load = 1 MyFileData = "" mytmpstrfile = "" txtLOOK = "" txtMSG = "" txtEXITS = "" myGETDROP = 0 myMAG = 0 myEL = 0 ' --- Read in contents of adventure file ErrorLabel (DATErrorHandler) FileOpen (myfo,mydatfile,cRead,,cASCII) MyFileData = FileReadToEnd (myfo) FileClose (myfo) ' --- strip out any CHR(13)s (found in Howarths games) MyFileData = StrReplace(MyFileData,Chr(13),"") ' --- load data into variables MagicHeader = ReadMyNo NumItems = ReadMyNo NumActions = ReadMyNo NumWords = ReadMyNo NumRooms = ReadMyNo If NumRooms >254 Then CarryingCanBe255 = "N" MaxCarry = ReadMyNo PlayerRoom = ReadMyNo Treasures = ReadMyNo WordLength = ReadMyNo LightTime = ReadMyNo If LightTime = 0 Then LightTime = 32000 LightRefill = LightTime NumMessages = ReadMyNo TreasureRoom = ReadMyNo Checksum = 0 Checksum = NumItems + NumActions + NumWords + NumRooms + MaxCarry + PlayerRoom + Treasures + NumMessages + TreasureRoom ResetVars For L = 0 To NumActions xActionVocab(L) = ReadMyNo xActionVerb(L) = xActionVocab(L) xActionNoun(L) = Int(xActionVerb(L) Mod 150) ' --- get the noun that is referred to from the actions vocab xActionVerb(L) = Int(xActionVerb(L) / 150) ' --- get the verb that is referred to from the actions vocab xActionCondition(L, 0) = ReadMyNo xActionCondition(L, 1) = ReadMyNo xActionCondition(L, 2) = ReadMyNo xActionCondition(L, 3) = ReadMyNo xActionCondition(L, 4) = ReadMyNo xActionAction(L, 0) = ReadMyNo xActionAction(L, 1) = ReadMyNo Next L For L = 0 To NumWords xVerbs(L) = ReadMyStr xNouns(L) = ReadMyStr Next L For L = 0 To NumRooms For X = 0 To 5 xRoomExit(L, X) = ReadMyNo Next X xRoomText(L) = ReadMyStr Next L For L = 0 To NumMessages xMessages(L) = ReadMyStr If StrIndexOf(xMessages(L),"&",0) > -1 Then ampatstart = 0 If StrIndexOf(xMessages(L),"&",0) = 0 Then ampatstart = 1 If ampatstart = 0 Then xMessages(L) = StrReplace(xMessages(L),"&", " and ") If ampatstart = 1 Then xMessages(L) = StrReplace(xMessages(L),"&", "and ") xMessages(L) = StrReplace(xMessages(L)," ", " ") ampatstart = 0 End If Next L For L = 0 To NumItems xItemText(L) = ReadItemText xItemAutoGet(L) = "" If StrLength(xItemText(L)) > 0 Then If SubString (xItemText(L), StrLength (xItemText(L)) - 1, 1) = "/" Then tmp1 = "" If StrLength(xItemText(L)) > 0 Then tmp1 = SubString (xItemText(L),0, StrLength(xItemText(L)) - 1) xItemAutoGet(L) = Trim(SubString(tmp1, StrIndexOf(tmp1,"/",0)+1,StrLength(tmp1)-StrIndexOf(tmp1,"/",0))) xItemText(L) = SubString (tmp1,0, StrIndexOf(tmp1,"/",0)) End If End If xItemLoc(L) = ReadItemLoc If CarryingCanBe255 = "Y" Then If xItemLoc(L) = 255 Then xItemLoc(L) = -1 End If xItemInitLoc(L) = xItemLoc(L) Next L For L = 0 To NumActions ' exhaust action notes ReadMyStr Next L AdvVersion = ReadMyNo AdvNo = ReadMyNo If LightTime > 5000 Then GameHasTorch = "N" ClearScreen Look AutoActions initial_load = 0 If Redraw = True Then Look If txtLOOK = "" Then Look Return DATErrorHandler: If OpeningOther = "Y" Then Msgbox("Error reading adventure file. (Correctly formatted?)") Else Msgbox("Error reading adventure file. Please reinstall this application.","Error",cMsgboxOK) End If OpeningOther = "N" AppClose End Sub Sub WhichWord(myword, mynorv) Dim n, ne Dim tp, w1, w2 n = 1 ne = 1 w1 = "" w2 = "" For ne = 1 To NumWords tp = "" If StrCompare(mynorv, "Verbs")=0 Then tp = xVerbs(ne) If StrCompare(mynorv, "Nouns")=0 Then tp = xNouns(ne) If StrCompare(xLeft(tp, 1),"*")=0 Then tp = SubString(tp, 1,StrLength(tp)-1) Else n = ne End If w1 = StrToUpper(myword) w2 = StrToUpper(tp) If (StrLength(w1) > WordLength) Then w1 = xLeft(w1, WordLength) If (StrLength(w2) > WordLength) Then w2 = xLeft(w2, WordLength) If StrCompare(w1, w2)=0 Then Return n End If Next ne Return -1 End Sub Sub ResetGeneral() ExitNames(0) = "North" ExitNames(1) = "South" ExitNames(2) = "East" ExitNames(3) = "West" ExitNames(4) = "Up" ExitNames(5) = "Down" GameHasTorch = "Y" For L = 0 To 29: param(L) = 0: Next L For L = 0 To 3: act(L) = 0: Next L done_intro_look = "N" CurrentCounter = 0 CurrentSavedRoom = 0 For L = 0 To 255: Counters(L) = 0: Next L For L = 0 To 40: xBitFlags(L) = 0: Next L For L = 0 To 255: RoomSaved(L) = 0: Next L MyFileDataPos = 0 MyFileData = "" End Sub Sub ResetVars addtxtMSG("") addtxtLOOK("") addtxtEXITS("") CarryingTooMuch = False ' --- reset variable dimensions on (re/)loading adventure Dim xActionVocab(NumActions+1) Dim xActionVerb(NumActions+1) Dim xActionNoun(NumActions+1) Dim xActionCondition(NumActions+1, 5) Dim xActionAction(NumActions+1, 2) ' --- room Dim xRoomText(NumRooms+1) Dim xRoomExit(NumRooms+1, 6) ' --- item Dim xItemText(NumItems+1) Dim xItemLoc(NumItems+1) Dim llItemLoc(NumItems+1) Dim xItemInitLoc(NumItems+1) Dim xItemAutoGet(NumItems+1) ' --- Dim xNouns(NumWords+1) Dim xVerbs(NumWords+1) Dim xMessages(NumMessages+1) For X = 0 To NumActions xActionVocab(X) = 0 xActionCondition(X, 0) = 0 xActionCondition(X, 1) = 0 xActionCondition(X, 2) = 0 xActionCondition(X, 3) = 0 xActionCondition(X, 4) = 0 xActionAction(X, 0) = 0 xActionAction(X, 1) = 0 Next X For L = 0 To 255: RoomSaved(L) = 0: Next L For L = 0 To NumWords: xVerbs(L) = "": xNouns(L) = "": Next L For L = 0 To NumRooms: For X = 0 To 5: xRoomExit(L, X) = 0: Next X: xRoomText(L) = "": Next L For L = 0 To NumMessages: xMessages(L) = "": Next L For L = 0 To NumItems: xItemText(L) = "": xItemLoc(L) = 0: xItemInitLoc(L) = 0: xItemAutoGet(L) = "": Next L ClearScreen End Sub Sub ReadMyNo Dim rmn, rmno DoEvents rmno = StrIndexOf (MyFileData,Chr(10),MyFileDataPos) - MyFileDataPos rmn = SubString(MyFileData, MyFileDataPos, rmno) MyFileDataPos = MyFileDataPos + rmno + 1 Return Trim(rmn) End Sub Sub ReadItemText Dim rit, ritno DoEvents If StrCompare(SubString(MyFileData, MyFileDataPos, 1),Chr(34))<>0 Then LoadError ("Read Item Text: Expected quotes. Found [" & SubString(MyFileData, MyFileDataPos, 1) & "]" & " {" & Asc(SubString(MyFileData, MyFileDataPos, 1)) & "}") End If MyFileDataPos = MyFileDataPos + 1 ' skip initial quote ritno = StrIndexOf (MyFileData,Chr(34),MyFileDataPos) - MyFileDataPos rit = SubString(MyFileData, MyFileDataPos, ritno) MyFileDataPos = MyFileDataPos + ritno MyFileDataPos = MyFileDataPos + 1 ' skip end quote Return CheckForSpelling(rit) End Sub Sub ReadItemLoc Dim rilno, ril DoEvents ril = "" ' perform check for adv13 LF char between item and its location If SubString(MyFileData, MyFileDataPos, 1) = Chr(10) Then MyFileDataPos = MyFileDataPos + 1 rilno = StrIndexOf (MyFileData,Chr(10),MyFileDataPos) - MyFileDataPos ril = SubString(MyFileData, MyFileDataPos, rilno) MyFileDataPos = MyFileDataPos + rilno + 1 Return Int(trim(ril)) End Sub Sub ReadMyStr Dim rmsno, rms rms = "" DoEvents MyFileDataPos = MyFileDataPos + 1 ' skip initial quote If StrCompare(SubString(MyFileData, MyFileDataPos-1, 1), Chr(34)) <> 0 Then LoadError ("Read String: Expected quotes. Found chr[" & Asc(SubString(MyFileData, MyFileDataPos-1, 1)) & "] at pos: " & MyFileDataPos & " {" & Asc(SubString(MyFileData, MyFileDataPos, 1)) & "}") End If rmsno = StrIndexOf (MyFileData,Chr(34),MyFileDataPos) - MyFileDataPos rms = SubString(MyFileData, MyFileDataPos, rmsno) MyFileDataPos = MyFileDataPos + rmsno MyFileDataPos = MyFileDataPos + 2 ' skip end quote Return CheckForSpelling(rms) End Sub Sub PlayerInRoom(myroom) If PlayerRoom = myroom Then Return True Else Return False End Sub Sub ItemHere(myitem) If xItemLoc(myitem) = PlayerRoom Then Return True Else Return False End Sub Sub ItemCarried(myitem) If xItemLoc(myitem) = CARRIED Then Return True Else Return False End Sub Sub ItemDestroyed(myitem) If xItemLoc(myitem) = DESTROYED Then Return True Else Return False End Sub Sub ItemAvailable(myitem) If (ItemHere(myitem) = True) OR (ItemCarried(myitem) = True) Then Return True Else Return False End Sub Sub ItemInOriginalRoom(myitem) If xItemLoc(myitem) = xItemInitLoc(myitem) Then Return True Else Return False End Sub Sub IsDark If ((GetFlag(DARKBIT) = True) AND (ItemAvailable(LIGHT_SOURCE) = False)) Then Return True Else Return False End Sub Sub Redraw 'return TRUE if we should Look() again Dim ri Dim chk1, chk2 If (llClear = True) Then Return True ' not sure I should redraw after clear. seems good though */ If (llDark <> IsDark) Then Return True If (IsDark = True) Then Return False ' since you can't see the change... If (llPlayerRoom <> PlayerRoom) Then Return True For ri = 0 To NumItems If llItemLoc(ri) = PlayerRoom Then chk1 = True Else chk1 = False If xItemLoc(ri) = PlayerRoom Then chk2 = True Else chk2 = False If (chk1 <> chk2) Then Return True Next ri Return False End Sub Sub RandomPercent(rndpc) Dim myrnd myrnd = Int(Rnd(1,101)) If (myrnd <= rndpc) Then Return True Else Return False End Sub Sub PerformActionLine(plct) Dim cc, pptr, pamsg, mytmp Dim cv, dv Dim pal Dim multimsg,SLPL pal = True pptr = 0 cc = 0 pamsg = 0 For cc = 0 To 4 cv = 0 dv = 0 cv = xActionCondition(plct, cc) dv = Int(cv / 20) cv = cv Mod 20 Select cv Case 0 param(pptr) = dv pptr = pptr + 1 Case 1 ' item carried If ItemCarried(dv) = False Then Return False Case 2 ' item in room with player If ItemHere(dv) = False Then Return False Case 3 ' item caried or in room with player If ItemAvailable(dv) = False Then Return False Case 4 ' player in room If PlayerInRoom(dv) = False Then Return False Case 5 ' item not in room with player If ItemHere(dv) = True Then Return False Case 6 ' item not carried If ItemCarried(dv) = True Then Return False Case 7 ' player not in room If PlayerInRoom(dv) = True Then Return False Case 8 ' bitflag is set If GetFlag(dv) = False Then Return False Case 9 ' bitflag is cleared If GetFlag(dv) = True Then Return False Case 10 ' carrying something If CountCarried = 0 Then Return False Case 11 ' carrying nothing If CountCarried > 0 Then Return False Case 12 ' item not carried nor in room with player If ItemAvailable(dv) = True Then Return False Case 13 ' item is in game (i.e. not in room 0) If ItemDestroyed(dv) = True Then Return False Case 14 ' item is not in game (i.e. in room 0) If ItemDestroyed(dv) = False Then Return False Case 15 ' currentcounter <= If (CurrentCounter > dv) Then Return False Case 16 ' currentcounter >= If CurrentCounter <= dv Then Return False Case 17 ' object still in initial room If ItemInOriginalRoom(dv) = False Then Return False Case 18 ' object not in initial room If ItemInOriginalRoom(dv) = True Then Return False Case 19: ' currentcounter = (Only seen in Brian Howarth games so far) If CurrentCounter <> dv Then Return False End Select Next cc ' --- Actions act(0) = xActionAction(plct, 0) act(2) = xActionAction(plct, 1) act(1) = act(0) Mod 150 act(3) = act(2) Mod 150 act(0) = Int(act(0) / 150) act(2) = Int(act(2) / 150) cc = 0 pptr = 0 ' cycle through all 4 actions multimsg = 0 For cc = 0 To 3 If ((act(cc) >= 1) AND (act(cc) <= 51)) OR (act(cc) >= 102) Then 'its a message pamsg = act(cc) If act(cc) >= 102 Then pamsg = pamsg - 50 If (word1 = "DROP" OR word1 = "GET") AND word2 = "ALL" AND trim(xMessages(pamsg)) = "O.K." Then DoEvents ' Do nothing :) ... needed for catering for double OK / O.K. msgs in Brian Howarths adventure if using get all / drop all Else If (multimsg > 0) AND ((StrToUpper(txtmsg)<>"OK
") AND (StrToUpper(txtmsg)<>"O.K.
")) Then If (Asc(SubString(xmessages(pamsg),0,1)) >= Asc("a") AND Asc(SubString(xmessages(pamsg),0,1)) <= Asc("z")) OR (Asc(SubString(xmessages(pamsg),0,1)) >= Asc("0") AND Asc(SubString(xmessages(pamsg),0,1)) <= Asc("9")) OR (Asc(SubString(xmessages(pamsg),0,1)) >= Asc(",")) Then If StrToLower(SubString(txtmsg,StrLength(txtmsg)-4,4)) = "
" Then txtmsg = xleft(txtmsg,StrLength(txtmsg)-4) & " " End If End If End If ' now check for end of line not punctuated ... If StrToLower(right(txtmsg,4)) = "
" Then If StrLength(txtmsg) > 4 Then txtmsg = xleft(txtmsg,StrLength(txtmsg)-4) If (((Asc(right(txtmsg,1)) >= Asc("a"))AND (Asc(right(txtmsg,1)) <= Asc("z"))) OR ((Asc(right(txtmsg,1)) >= Asc("A")) AND (Asc(right(txtmsg,1)) <= Asc("Z")))) OR (Asc(right(txtmsg,1)) = Asc("'")) Then txtmsg = txtmsg & ".
" Else txtmsg = txtmsg & "
" End If End If End If AddTxtMsg (HX(xMessages(pamsg)) & "
") multimsg = multimsg + 1 txtmsg = StrReplace(txtmsg," "," ") 'capitalise first char of msg If multimsg = 1 Then txtmsg = StrToUpper(SubString(txtmsg,0,1)) & SubString(txtmsg,1,StrLength(txtmsg)-1) End If End If Else ' its not a message, so ...... Select act(cc) Case 0 pamsg = 0 Case 52 ' Get item . Checks if you can carry it first If GetItem(param(pptr)) = False Then pptr = pptr + 1 Return False Else pptr = pptr + 1 End If Case 53 ' drops item xItemLoc(param(pptr)) = PlayerRoom pptr = pptr + 1 If word1 = "DROP" AND word2 = "ALL" Then If StrLength(txtMsg)> 5 Then If StrToUpper(right(txtMsg,6)) <> "OK
" Then AddTxtMsg ("OK
") Else addTxtMsg ("OK
") End If End If 'AddTxtMsg("OK
") ' needed for dropping certain items if dropping all (advland - DROP ALL with ROYAL HONEY) ' ... and no we dont need this for case 52 :) Case 54 ' moves to room PlayerRoom = param(pptr) pptr = pptr + 1 Case 55 ' Item is removed from the game (put in room 0) xItemLoc(param(pptr)) = DESTROYED pptr = pptr + 1 Case 56 ' The darkness flag is set (other drivers say this is buggy?) SetFlag (DARKBIT) Case 57 ' The darkness flag is cleared ClearFlag (DARKBIT) Case 58 ' Bitflag is set SetFlag (param(pptr)) pptr = pptr + 1 Case 59 ' The same as 55 (it seems - I'm cautious about this) xItemLoc(param(pptr)) = DESTROYED pptr = pptr + 1 Case 60 ' BitFlag is cleared ClearFlag (param(pptr)) pptr = pptr + 1 Case 61 ' Death KillPlayer Case 62 ' Item put in room xItemLoc(param(pptr)) = param(pptr + 1) pptr = pptr + 2 Case 63 ' Game over Quit Case 64 ' Describe room Look Case 65 ' Score Score Case 66 ' Inventory Inventory Case 67 ' Bitflag 0 is set SetFlag (0) Case 68 ' Bitflag 0 is cleared ClearFlag (0) Case 69 ' Refill lamp FillLamp Case 70 ' Screen is cleared. This varies by driver from no effect upwards DoEvents ' in our case, we Do Events Case 71 ' Save the game SaveMyGame Case 72 ' Swap item and item locations mytmp = xItemLoc(param(pptr)) xItemLoc(param(pptr)) = xItemLoc(param(pptr + 1)) xItemLoc(param(pptr + 1)) = mytmp pptr = pptr + 2 Case 73 ' Continue with next line (the next line starts verb 0 noun 0) continuation = True Case 74 ' "Superget" - Take item - no check is done too see if it can be carried. xItemLoc(param(pptr)) = CARRIED pptr = pptr + 1 Case 75 ' Put item with item - Not certain seems to do this from examination of Claymorgue xItemLoc(param(pptr)) = xItemLoc(param(pptr + 1)) pptr = pptr + 2 Case 76 ' Look (SW:same as 64 ?? - check) Look Case 77 ' Decrement current counter. Will not go below -1 ' This prevents Bonus scoring system working ! If CurrentCounter >= 0 Then CurrentCounter = CurrentCounter - 1 Case 78 ' Print current counter value. Some drivers only cope with 0-99 apparently ' This prints bonus score (albeit 0 or -1 currently) amongst others AddTxtMsg (trim(CurrentCounter) & " ") Case 79 ' Set current counter value CurrentCounter = param(pptr) pptr = pptr + 1 Case 80 ' Swap location with current location-swap flag mytmp = PlayerRoom PlayerRoom = CurrentSavedRoom CurrentSavedRoom = mytmp Case 81 ' Select a counter. Current counter is swapped with backup counter ' This is somewhat guessed. Claymorgue always ' seems to do select counter n, thing, select counter n, ' but uses one value that always seems to exist. Trying ' a few options I found this gave sane (same?) results on ageing mytmp = CurrentCounter CurrentCounter = Counters(param(pptr)) Counters(param(pptr)) = mytmp pptr = pptr + 1 Case 82 ' Add to current counter CurrentCounter = CurrentCounter + param(pptr) pptr = pptr + 1 Case 83 ' Subtract from current counter CurrentCounter = CurrentCounter - param(pptr) pptr = pptr + 1 If CurrentCounter < -1 Then CurrentCounter = -1 ' Note: This seems to be needed. I don't yet know if there is a maximum value to limit too Case 84 ' Echo noun player typed without CR/LF RemoveBRfromTXTMSG AddTxtMsg (HX(NounText) & " ") Case 85 ' Echo the noun the player typed with CR/LF RemoveBRfromTXTMSG AddTxtMsg (HX(NounText) & "
") Case 86 ' CR/LF AddTxtMsg ("[br]") Case 87 ' Swap current location value with ' backup location-swap value mytmp = PlayerRoom PlayerRoom = RoomSaved(param(pptr)) RoomSaved(param(pptr)) = mytmp pptr = pptr + 1 Case 88 ' wait (some drivers are 1.5, some are 2 - mine is 1.2s) Sleeping="Y" If txtLOOK & txtEXITS & txtMSG <> lastrefresh Then refreshweb For SLPL = 1 To 12 Sleep (100) DoEvents Next SLPL 'Sleeping="N" Case 89 ' saga - draw picture ' (actually , as each Look() draws picture automatically) ' Older spectrum driver - crashes ' Spectrum Seas of Blood - seems to start Fighting Fantasy combat mode pptr = pptr + 1 Case Else AddTxtMsg ("Unknown action " & act(cc) & "
") pptr = pptr + 1 End Select End If ' from elseif combo Next cc Return True End Sub Sub RemoveBRfromTXTMSG If StrLength(txtMSG) > 3 Then txtMSG = SubString (txtmsg,0,StrLength (txtMSG) - 4 ) End If End Sub Sub CountCarried Dim ccct Dim ccn ccct = 0 ccn = 0 For ccct = 0 To NumItems If xItemLoc(ccct) = CARRIED Then ccn = ccn + 1 If (xItemLoc(ccct) = CARRIED) AND (xItemAutoGet(ccct) = "") AND _ ( _ (StrIndexOf(StrToLower(xItemText(ccct)),"wearing", 0) > 0) OR _ (StrIndexOf(StrToLower(xItemText(ccct)),"worn", 0) > 0) OR _ (StrIndexOf(StrToLower(xItemText(ccct)),"activated", 0) > 0) OR _ (SubString(StrToLower(xItemText(ccct)),0, 6) = "which ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 5) = "that ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 5) = "with ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 5) = "they ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 8) = "they're ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 8) = "they`re ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 4) = "i'm ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 5) = "i am ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 3) = "it ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 5) = "it`s ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 3) = "im ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 4) = "its ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 5) = "it's ") OR _ (SubString(StrToLower(xItemText(ccct)),0, 5) = "it`s ") _ ) Then ccn = ccn - 1 Next ccct Return ccn End Sub Sub LoadMyGame Dim LMGL Dim myloadgame Dim d1 Dim tmpChecksum Dim tmpMagicHeader Dim tmpAdvNo myloadgame = "" LoadDialog1.Filter = "Save Files|*.sav" If LoadDialog1.Show <> cCancel Then myloadgame = LoadDialog1.File End If If myloadgame = "" Then Return End If ErrorLabel (LoadErrorHandler) FileOpen (d1,myloadgame,cRead,,cASCII) tmpChecksum = FileRead (d1) tmpMagicHeader = FileRead (d1) tmpAdvNo = FileRead (d1) If (tmpMagicHeader <> MagicHeader) OR (tmpAdvNo <> AdvNo) OR (tmpChecksum <> Checksum) Then Msgbox("Save file not from this adventure.","Error",cMsgboxOK,cMsgboxExclamation) FileClose (d1) Return End If For SMGL = 0 To 255 Counters(SMGL) = FileRead (d1) RoomSaved(SMGL) = FileRead (d1) xBitFlags(SMGL) = FileRead (d1) Next SMGL PlayerRoom = FileRead (d1) CurrentCounter = FileRead (d1) CurrentSavedRoom = FileRead (d1) LightTime = FileRead (d1) For SMGL = 0 To NumItems xItemLoc(SMGL) = FileRead (d1) Next SMGL FileClose (d1) myCMD.Text = "LOOK" myCMD_Keypress(Chr(13)) Return LoadErrorHandler: Msgbox ("Unable to load file.","Error",cMsgboxOK,cMsgboxExclamation) End Sub Sub SaveMyGame Dim SMGL Dim mysavegame Dim c1 mysavegame = "" SaveDialog1.Filter = "Save Files|*.sav" If SaveDialog1.Show <> cCancel Then mysavegame = SaveDialog1.File End If If mysavegame = "" Then AddTxtMsg ("Save cancelled.") Return End If ErrorLabel (SaveErrorHandler) FileOpen (c1,mysavegame,cWrite,,cASCII) FileWrite (c1, Checksum) FileWrite (c1, MagicHeader) FileWrite (c1, AdvNo) For SMGL = 0 To 255 FileWrite(c1, Counters(SMGL)) FileWrite(c1, RoomSaved(SMGL)) FileWrite(c1, xBitFlags(SMGL)) Next SMGL FileWrite(c1, PlayerRoom) FileWrite(c1, CurrentCounter) FileWrite(c1, CurrentSavedRoom) FileWrite(c1, LightTime) For SMGL = 0 To NumItems FileWrite(c1, xItemLoc(SMGL)) Next SMGL FileClose (c1) AddTxtMsg ("Game saved OK.") Return SaveErrorHandler: Msgbox ("Unable to save file.","Error",cMsgboxOK,cMsgboxExclamation) End Sub Sub KillPlayer AddTxtMsg ("I am DEAD!
") ClearFlag (DARKBIT) PlayerRoom = NumRooms Look End Sub Sub Score Dim si Dim scount scount = 0 For si = 0 To NumItems If ((xItemLoc(si) = TreasureRoom) AND (xLeft(xItemText(si), 1) = "*")) Then scount = scount + 1 End If Next si AddTxtMsg ("I've stored " & scount & " treasures.
") AddTxtMsg ("On a scale of 0 to 100, that's " & Int((scount * 100) / Treasures) & ".
") If scount >= Treasures Then ' was equal to ... added greater than ... just in case :) AddTxtMsg ("
YOU WON!") refreshweb Msgbox("Congratulations, you won!","Well done!",cMsgboxOK) Quit End If End Sub Sub treasurecheck(tcheck) Dim MyNewItemName If (xleft(tcheck,2) = "* ") AND (right(tcheck,2) = " *") Then MyNewItemName = "*" & SubString(tcheck,2,StrLength(tcheck)-4) & "*" Return MyNewItemName Else Return tcheck End If End Sub Sub Inventory Dim ii Dim mykit mykit = "" If StrIndexOf (txtmsg , "I am now carrying nothing.
",0) > -1 OR StrIndexOf (txtmsg , "I am now carrying: ",0) > -1 Then DoEvents Else For ii = 0 To NumItems If xItemLoc(ii) = CARRIED Then If StrLength(xItemAutoGet(ii)) > 0 Then If OptionsLinksOn = "Y" AND Sleeping <> "Y" Then mykit = mykit & "" & hx(treasurecheck(xItemText(ii))) & ". " Else mykit = mykit & "" & hx(treasurecheck(xItemText(ii))) & ". " End If Else mykit = mykit & treasurecheck(xItemText(ii)) & ". " End If End If Next ii If mykit = "" Then If QuickDropChk = "N" Then AddTxtMsg ("I am carrying: Nothing!
") If QuickDropChk = "Y" Then If ImCarrying <> CountCarrying Then AddTxtMsg ("I am now carrying nothing.
") End If Else If QuickDropChk = "N" Then AddTxtMsg ("I am carrying: " & mykit & "
") If QuickDropChk = "Y" Then If ImCarrying <> CountCarrying Then AddTxtMsg ("I am now carrying: " & mykit & "
") End If End If End If End Sub Sub FillLamp LightTime = LightRefill xItemLoc(LIGHT_SOURCE) = CARRIED ClearFlag (LIGHTOUTBIT) End Sub Sub Quit If redraw = True Then Look refreshweb Msgbox("Your adventure is over.","Game Over",cMsgboxOK) End Sub Sub SendLook(mylk) If LookCleared = 0 Then addtxtLOOK("") LookCleared = LookCleared + 1 addtxtLOOK(mylk) End Sub Sub Look Dim lastChar Dim li Dim tempexits Dim tempitems addtxtLOOK("") addtxtEXITS("") If initial_load = 1 AND done_intro_look = "Y" Then Return If initial_load = 1 Then done_intro_look = "Y" ' ------------------------------ ' --- Room and contents ' ------------------------------ myroomText = HTML_LOOK_START ' if too dark, say so If (IsDark = True) Then SendLook (myRoomText & "It's too dark to see!" & HTML_LOOK_END) SendLook (HTML_LINE) Else 'describe room myroomText = myroomText & "" If (xLeft(xRoomText(PlayerRoom),1) = "*") Then myroomText = myroomText & SubString(xRoomText(PlayerRoom), 1,StrLength(xRoomText(PlayerRoom))-1) Else If (StrToUpper(xLeft(xRoomText(PlayerRoom), 1)) = "A" OR _ StrToUpper(xLeft(xRoomText(PlayerRoom), 1)) = "E" OR _ StrToUpper(xLeft(xRoomText(PlayerRoom), 1)) = "I" OR _ StrToUpper(xLeft(xRoomText(PlayerRoom), 1)) = "O" OR _ StrToUpper(xLeft(xRoomText(PlayerRoom), 1)) = "U") Then myroomText = myroomText & "I'm in an " & xRoomText(PlayerRoom) Else myroomText = myroomText & "I'm in a " & xRoomText(PlayerRoom) End If End If ' punctuate if necessary myroomText = Trim(myroomText) If (right(myroomText,1) <> "." AND right(myroomText,1) <> "!" AND right(myroomText,1) <> "?") Then myroomText = myroomText & "." myroomText = myroomText & "" myroomText = myroomText & "
" myroomText = myroomText & HTML_LK_PROMPT_START & hx("I can see: ") & HTML_PROMPT_END tempitems = "" For li = 0 To NumItems If xItemLoc(li) = PlayerRoom Then If StrLength(xItemAutoGet(li)) > 0 Then If OptionsLinksOn = "Y" AND Sleeping <> "Y" Then tempitems = tempitems & "" tempitems = tempitems & "" & hx(treasurecheck(xItemText(li))) & ". " Else tempitems = tempitems & "" & hx(treasurecheck(xItemText(li))) & ". " End If Else tempitems = tempitems & "" & hx(treasurecheck(xItemText(li))) & ". " End If End If Next li If tempitems = "" Then myroomText = myroomText & " nothing special.
" Else myroomText = myroomText & xLeft(tempitems, StrLength(tempitems) - 1) & "
" End If myroomText = myroomText & HTML_LOOK_END SendLook (myroomText) ' ----------------------- ' --- Exits ' ----------------------- ' describe exits myroomExits = HTML_EX_PROMPT_START & hx("Obvious exits: ") & HTML_PROMPT_END tempexits = "" For li = 0 To 1 If xRoomExit(PlayerRoom, li) <> 0 Then If OptionsLinksOn = "Y" AND Sleeping <> "Y" Then tempexits = tempexits & "" & hx(ExitNames(li)) & ", " Else tempexits = tempexits & "" & hx(ExitNames(li)) & ", " End If End If Next li For li = 3 To 2 Step -1 If xRoomExit(PlayerRoom, li) <> 0 Then If OptionsLinksOn = "Y" AND Sleeping <> "Y" Then tempexits = tempexits & "" & hx(ExitNames(li)) & ", " Else tempexits = tempexits & "" & hx(ExitNames(li)) & ", " End If End If Next li For li = 4 To 5 If xRoomExit(PlayerRoom, li) <> 0 Then If OptionsLinksOn = "Y" AND Sleeping <> "Y" Then tempexits = tempexits & "" & hx(ExitNames(li)) & ", " Else tempexits = tempexits & "" & hx(ExitNames(li)) & ", " End If End If Next li If tempexits = "" Then myroomExits = myroomExits & hx("None.") & "
" Else myroomExits = myroomExits & xLeft(tempexits, StrLength(tempexits) - 2) & hx(".") & "
" End If myroomExits = HTML_EXIT_START & myroomExits & HTML_EXIT_END addtxtEXITS (myroomExits) ' store the current state in lastLook to determine if redraw needed llPlayerRoom = PlayerRoom For li = 0 To NumItems llItemLoc(li) = xItemLoc(li) Next li llDark = IsDark llClear = False End If End Sub Sub WorkLight ' countdown to dark If ((ItemDestroyed(LIGHT_SOURCE) = False) AND (LightTime <> -1)) Then LightTime = LightTime - 1 If LightTime < 1 Then SetFlag (LIGHTOUTBIT) If ItemAvailable(LIGHT_SOURCE) Then ' if torch is in room or carried AddTxtMsg ("
The light has run out!
") ' then tell user its just gone out Look End If xItemLoc(LIGHT_SOURCE) = DESTROYED Else If (LightTime < 25) Then If ItemAvailable(LIGHT_SOURCE) Then AddTxtMsg ("
The light runs out in " & LightTime & " turn") If LightTime > 1 Then AddTxtMsg ("s.
") Else AddTxtMsg (".
") End If End If End If End Sub Sub CheckInput Dim myinput Dim CIL Dim spccount vnum = -1 nnum = -1 Select StrToUpper(Trim(myCMD.Text)) Case "N" myinput = "GO NORTH" Case "E" myinput = "GO EAST" Case "W" myinput = "GO WEST" Case "S" myinput = "GO SOUTH" Case "U" myinput = "GO UP" Case "D" myinput = "GO DOWN" Case "I" myinput = "INVENTORY" Case "H" myinput = "HELP" Case "L" myinput = "LOOK" Case Else myinput = StrReplace(StrToUpper(Trim(myCMD.Text))," "," ") End Select If myinput = "NORTH" Then myinput = "GO " & myinput If myinput = "WEST" Then myinput = "GO " & myinput If myinput = "EAST" Then myinput = "GO " & myinput If myinput = "SOUTH" Then myinput = "GO " & myinput If myinput = "UP" Then myinput = "GO " & myinput If myinput = "DOWN" Then myinput = "GO " & myinput spccount = 0 word1 = "" word2 = "" For CIL = 1 To StrLength(myinput) If SubString(myinput, CIL-1, 1) = " " Then spccount = spccount + 1 If spccount = 0 Then word1 = word1 & SubString(myinput, CIL-1, 1) If (spccount = 1) AND (StrCompare(SubString(myinput, CIL-1, 1), " ") <> 0) Then word2 = word2 & SubString(myinput, CIL-1, 1) Next CIL myLASTWORD1 = word1 myLASTWORD2 = word2 NounText = StrToLower(word2) ImCarrying = 0 If word1 = "DROP" Then ImCarrying = CountCarrying If word1 = "SAVE" AND word2 = "" Then word2 = "GAME" spccount = 1 End If If spccount > 1 Then AddTxtMsg ("Use 1 or 2 words only!
") myCMD.Text = "" Return False End If If spccount = 1 Then vnum = WhichWord(word1, "Verbs") nnum = WhichWord(word2, "Nouns") End If If spccount = 0 Then vnum = WhichWord(word1, "Verbs") If (vnum = -1) Then FoundItem = -1 For CIL = 0 To NumItems If xItemAutoGet(CIL) = word1 Then FoundItem = CIL Next CIL If FoundItem = -1 Then AddTxtMsg ("I don't know how to '" & HX(word1) & "' something.
") Else AddTxtMsg ("Sorry, I don't understand you.") End If myCMD.Text = "" Return False End If ' Use -2 to refer to ALL If (nnum = -1 AND xLeft(word2, 3) = "ALL") Then nnum = -2 If (vnum >= 0) AND (nnum = -1) AND (StrLength(word2) > 0) Then If word1 = "SAY" Then If word2 = Chr(88)&Chr(89)&Chr(90)&Chr(90)&Chr(89) Then AddTxtMsg ("I know not of such dark magic!
") Else AddTxtMsg ("OK ... '" & HX(word2) & "' !!!
") End If Else AddTxtMsg ("I'n not sure what you mean...") End If myCMD.Text = "" Return False End If myCMD.Text = "" Return True End Sub Sub MoveCommand Dim mynext If (nnum = -1) Then AddTxtMsg ("I also need a direction.
") Return True End If If (nnum >= 1 AND nnum <= 6) Then If (IsDark = True) Then AddTxtMsg ("It's dangerous to move in the dark!
") End If mynext = xRoomExit(PlayerRoom, nnum - 1) If (mynext <> 0) Then PlayerRoom = mynext AddTxtMsg ("OK
") llClear = True Return True End If If (IsDark = True) Then AddTxtMsg ("I fell and broke my neck!
") KillPlayer Return True End If AddTxtMsg ("I can't go that way.
") Return True End If Return False End Sub Sub PerformCommand Dim pci Dim result Dim vv, nv Dim myres ' -1 = No action match, 0 = action match(conditions not met), 1 = done action If (vnum = GO_VERB) Then If MoveCommand Then Return End If result = -1 For pci = 0 To NumActions vv = 0 nv = 0 vv = xActionVocab(pci) nv = vv Mod 150 ' --- get the noun vv = Int(vv / 150) ' --- get the verb If (((vv <> 0) OR (nv <> 0)) AND continuation = True) Then Exit 'For End If If (vnum = vv AND ((nnum = nv) OR (nv = 0))) OR continuation = True Then If result = -1 Then result = 0 End If If PerformActionLine(pci) = True Then result = 1 If (continuation = False) Then Exit 'For End If End If End If Next pci continuation = False If (result = 1) Then Return ' auto get and drop If (vnum = GET_VERB) Then If result = 0 Then myres = True Else myres = False If (GetCommand(myres) = True) Then Return End If If (vnum = DROP_VERB) Then If result = 0 Then myres = True Else myres = False If (DropCommand(myres) = True) Then Return End If Select result Case -1 AddTxtMsg ("I don't understand you.
") Case 0 AddTxtMsg ("I can't do that... YET!
") End Select End Sub Sub myCMD_KeyPress(Key) If StrToUpper(myCMD.text) = "N" AND StrToUpper(Key) = "N" Then Key = Chr(13) If StrToUpper(myCMD.text) = "E" AND StrToUpper(Key) = "E" Then Key = Chr(13) If StrToUpper(myCMD.text) = "W" AND StrToUpper(Key) = "W" Then Key = Chr(13) If StrToUpper(myCMD.text) = "S" AND StrToUpper(Key) = "S" Then Key = Chr(13) If StrToUpper(myCMD.text) = "U" AND StrToUpper(Key) = "U" Then Key = Chr(13) If StrToUpper(myCMD.text) = "D" AND StrToUpper(Key) = "D" Then Key = Chr(13) If StrToUpper(myCMD.text) = "I" AND StrToUpper(Key) = "I" Then Key = Chr(13) If StrToUpper(myCMD.text) = "H" AND StrToUpper(Key) = "H" Then Key = Chr(13) If StrToUpper(myCMD.text) = "L" AND StrToUpper(Key) = "L" Then Key = Chr(13) If Key <> Chr(8) Then Key = StrToUpper(Key) DoEvents myCMD.Focus myCMD.SelectionStart = StrLength(myCMD.text) If (Key = Chr(13)) AND (StrLength(Trim(myCMD.Text)) > 0) Then addtxtMsg("") If CheckInput = True Then PerformCommand If GameHasTorch = "Y" Then WorkLight AutoActions Sleeping = "N" If (Redraw = True) Then LookCleared = 0 addtxtLOOK("") addtxtEXITS("") Look Else Look End If End If LinkGet = 0 LinkDrop = 0 Getting = "N" Dropping = "N" refreshweb myGETDROP = 0 myMAG = 0 myEL = 0 End If End If If Key = Chr(13) Then myCMD.IgnoreKey End Sub Sub AutoActions Dim aai For aai = 0 To NumActions If (xActionVerb(aai) <> 0) OR (xActionNoun(aai) <> 0) Then continuation = False If ((xActionVerb(aai) = 0) AND (RandomPercent(xActionNoun(aai))=True)) OR continuation=True Then PerformActionLine (aai) End If Next aai continuation = False End Sub Sub PDselect_SelectionChanged(selindex,selvalue) ButPlay.Enabled = True myAdventure = "adv" If selindex+1 < 10 Then myAdventure = myAdventure & "0" myAdventure = myAdventure & (selindex+1) ErrorLabel (SelectFileOpenError) ImgPic.Image = AppPath & "\images\scotts_games\" & myAdventure & ".gif" myAdventure = AppPath & "\data_scottadams\" & myAdventure & ".dat" If selindex = 0 Then AdvDesc.Text = "Wander through enchanted lands trying to recover the 13 lost treasures. You'll encounter wild animals, magical beings, and other perils and puzzles. Can you rescue the Blue Ox from the quicksand or find your way out of the maze of pits? Happy Adventuring!" If selindex = 1 Then AdvDesc.Text = "'Yo ho ho and a bottle of rum...' You'll meet up with the pirate and his daffy bird along with many strange sights as you attempt to go from your London flat to Treasure Island. Can you recover Long John Silver's lost treasures? Happy sailing, matey..." If selindex = 2 Then AdvDesc.Text = "Time is of the essence as you race the clock to complete your mission - if you fail, the world's first automated nuclear reactor is doomed. So, tread lightly and don't forget your bomb detector! If you survive this challenging mission, consider yourself a true Adventurer." If selindex = 3 Then AdvDesc.Text = "Count Cristo has had a fiendish curse put on him by his enemies. There he lies, with you his only hope. Will you be able to rescue him or is he forever doomed? Beware the Voodoo man..." If selindex = 4 Then AdvDesc.Text = "You wake up in a large brass bed in a castle somewhere in Transylvania. Who are you, what are you doing here, and why did the postman deliver a bottle of blood? You'll love this adventure, in fact, you might say it's Love at First Byte..." If selindex = 5 Then AdvDesc.Text = "Marooned at the edge of the galaxy, you've stumbled on the ruins of an ancient alien civilization complete with fabulous treasures and unearthly technologies. Can you collect the treasures and return or will you end up marooned forever?" If selindex = 6 Then AdvDesc.Text = "Can you find your way completely through the strangest Fun House in existence, or will you be kicked out when the park closes?" If selindex = 7 Then AdvDesc.Text = "An Egyptian Treasure Hunt leads you into the dark recesses of a recently uncovered Pyramid. Will you recover all the treasures or more likely will you join its denizens for that long eternal sleep?" If selindex = 8 Then AdvDesc.Text = "Explore a deserted western mining town in search of 13 treasures. From rattlesnakes to runaway horses, this Adventure's got them all! Just remember, Pardner, they don't call them Ghost Towns for nothing." If selindex = 9 Then AdvDesc.Text = "WARNING: for experienced adventurers only!"&CRLF&CRLF&"A small island in a remote ocean holds an awesome secret. Will you be the first to uncover it?" If selindex = 10 Then AdvDesc.Text = "After struggling through Part 1, you have the consolation of knowing its half over. This concludes this two part Adventure. You must have the password from Savage Island Part One to play this adventure!" If selindex = 11 Then AdvDesc.Text = "The King lies near death in the royal palace - you have only three days to bring back the elixir needed to rejuvenate him. Journey through the lands of magic fountains, sacred temples, stormy seas, and gold, gold, gold! Can you find the elixir in time?" If selindex = 12 Then AdvDesc.Text = "Tread carefully, O Beanwick! Would that I could assume this quest myself, but alas, I can only send with you these few spells. Claymorgue Castle harbours further spells, but beware: one unskilled in the arts cannot predict their outcome." If selindex = 13 Then AdvDesc.Text = "This game is as tricky and devious as the mind of Scott Adams gets. A treasure hunt in the same vein as its predecessor, it incorporates some of the more interesting effects Scott achieved using his system. Knowledge of 'Pirate Adventure' is essential." If selindex = 14 Then AdvDesc.Text = "Buckaroo Banzai, a neurosurgeon, rock star and more, must try to fix a jet car that can drive him into the 8th dimension." OptionsMyAdv = selindex Return SelectFileOpenError: ButPlay.Enabled = False Msgbox ("Could not locate this adventure's image. Please reinstall.","Error",cMsgboxOK) AppClose End Sub Sub ButPlay_Click Dim myProgress Cancel = False Webby.DocumentText = "
" Cancel = True webby.CancelNavigate = True For L = 1 To 5 DoEvents Sleep (100) Next L FAdventure.Show For L = 1 To 5 DoEvents Sleep (100) Next L myCMD.Text = "" myCMD.Focus SaveOptionsToFile LoadFile (myadventure) refreshweb ButEnter.Enabled = True ButDEL.Enabled = True ButGo.Enabled = True End Sub Sub ButGETDROP_Click If Sleeping = "Y" Then Return myGETDROP = myGETDROP + 1 If myGETDROP = 5 Then myGETDROP = 1 Select myGETDROP Case 1: myCMD.Text = "GET " Case 2: myCMD.Text = "DROP " Case 3: myCMD.Text = "GET ALL" Case 4: myCMD.Text = "DROP ALL" End Select myCMD.Focus myCMD.SelectionStart = StrLength(myCMD.text) End Sub Sub ButMAG_Click If Sleeping = "Y" Then Return myMAG = myMAG + 1 If myMAG = 4 Then myMAG = 1 If myMAG = 1 Then myCMD.Text = "EXAMINE " If myMAG = 2 Then myCMD.Text = "READ " If myMAG = 3 Then myCMD.Text = "LOOK " myCMD.Focus myCMD.SelectionStart = StrLength(myCMD.text) End Sub Sub ButELC_Click If Sleeping = "Y" Then Return myEL = myEL + 1 If myEL = 5 Then myEL = 1 Select myEL Case 1 myCMD.Text = "GO " Case 2 myCMD.Text = "CLIMB " Case 3 myCMD.Text = "SWIM " Case 4 myCMD.Text = "ENTER " End Select myCMD.Focus myCMD.SelectionStart = StrLength(myCMD.text) End Sub Sub addtxtLOOK(atlook) If atlook = "" Then txtLOOK = "" Else txtLOOK = txtLOOK & atlook End Sub Sub addtxtEXITS(atexits) If atexits = "" Then txtEXITS = "" Else txtEXITS = txtEXITS & atexits End Sub Sub AddTxtMsg(atmsg) If atmsg = "" Then txtMSG = "" Else txtMSG = txtMSG & atmsg End Sub Sub HX2(htmlreplace2) myHX2 = StrReplace(htmlreplace2,"{BR}","
") Return myHX2 End Sub Sub refreshWEB Dim txtLOOK2 Dim txtEXITS2 Dim txtMSG2 If Sleeping <> "Y" Then QuickDropChk = "Y" If txtmsg = "" Then txtmsg = "OK" If myLASTWORD1 = "DROP" AND WhichWord(word2,"Nouns") > 0 Then Inventory QuickDropChk = "N" End If ' ---------------------------- ' now check for end of line not punctuated ... txtmsg = trim(txtmsg) If StrLength(txtmsg) > 2 Then If StrLength(txtmsg) > 4 Then If StrToLower(SubString(txtmsg,StrLength(txtmsg)-4,4)) = "
" AND StrLength(txtmsg) > 4 Then txtmsg = xleft(txtmsg,StrLength(txtmsg)-4) End If If StrLength(txtmsg) > 4 Then If StrToLower(SubString(txtmsg,StrLength(txtmsg)-4,4)) = "
" AND StrLength(txtmsg) > 4 Then txtmsg = xleft(txtmsg,StrLength(txtmsg)-4) End If If (((Asc(right(txtmsg,1)) >= Asc("a")) AND (Asc(right(txtmsg,1)) <= Asc("z"))) OR ((Asc(right(txtmsg,1)) >= Asc("A")) AND (Asc(right(txtmsg,1)) <= Asc("Z")))) OR (Asc(right(txtmsg,1)) = Asc("'")) Then If right(txtmsg,2) <> "OK" Then txtmsg = txtmsg & "." End If End If ' greater than 2 txtmsg = txtmsg & " " txtmsg = StrReplace(txtmsg, ".
0", " 0") txtmsg = StrReplace(txtmsg, ".
1", " 1") txtmsg = StrReplace(txtmsg, ".
2", " 2") txtmsg = StrReplace(txtmsg, ".
3", " 3") txtmsg = StrReplace(txtmsg, ".
4", " 4") txtmsg = StrReplace(txtmsg, ".
5", " 5") txtmsg = StrReplace(txtmsg, ".
6", " 6") txtmsg = StrReplace(txtmsg, ".
7", " 7") txtmsg = StrReplace(txtmsg, ".
8", " 8") txtmsg = StrReplace(txtmsg, ".
9", " 9") ' ---------------------------- lastrefresh = txtLOOK & txtEXITS & txtMSG Cancel = False DoEvents DoEvents If OptionsAltHyperOn = "Y" Then Do Until webby.IsBusy = False DoEvents Loop DoEvents DoEvents End If If StrLength(txtMSG) > 0 Then txtMSG = Trim(txtMSG) If StrLength(txtMSG) > 2 Then If right(txtMSG,1) = "," Then txtMSG = SubString(txtMSG,0,StrLength(txtMSG)-1) & "." End If End If ' bold? If OptionsFontBold = 0 Then txtLOOK2 = hx2(txtLOOK) txtEXITS2 = txtEXITS txtMSG2 = StrReplace(txtmsg, "", "") txtMSG2 = StrReplace(txtmsg2, "", "") txtMSG2 = checkinvext(txtMSG2) Else txtLOOK2 = hx2(txtLOOK) txtEXITS2 = txtEXITS txtMSG2 = checkinvext(txtMSG) If OptionsFontBold = 1 Then txtLOOK2 = "" & txtLOOK2 & "" txtEXITS2 = "" & txtEXITS2 & "" txtMSG2 = "" & txtMSG2 & "" End If End If txtMSG2 = StrReplace(txtMSG2,"[br]","
") If OptionsRvsInfo = "N" Then webby.DocumentText = HTML_START & txtLOOK2 & HTML_LINE & txtEXITS2 & HTML_LINE & HTML_MESG_START & txtMSG2 & HTML_MESG_END & HTML_END Else webby.DocumentText = HTML_START & HTML_MESG_START & txtMSG2 & HTML_MESG_END & HTML_LINE & txtLOOK2 & HTML_LINE & txtEXITS2 & HTML_END End If DoEvents Cancel = True myCMD.Focus End Sub Sub checkinvext(cie) Dim cie2 cie2 = cie cie2 = StrReplace (cie2,". which ", " which ") cie2 = StrReplace (cie2,". that ", " that ") Return cie2 End Sub Sub webby_Navigating ' look If Cancel = True Then webby.CancelNavigate = True If webby.NavigatingURL = StrToUpper(hyper) OR webby.NavigatingURL = "" Then DoEvents Else If right(webby.NavigatingURL,1) = "x" Then ' exits myCMD.Text = SubString(webby.NavigatingURL,StrLength(hyper),StrLength(webby.NavigatingURL)-(StrLength(hyper)+1)) End If If right(webby.NavigatingURL,1) = "i" Then ' getting item If trim(myCMD.Text) = "" Then LinkGet = 0 + SubString(webby.NavigatingURL,(StrLength(hyper)+1),StrLength(webby.NavigatingURL)-(StrLength(hyper)+2)) myCMD.Text = "GET " & xItemAutoGet(LinkGet) Else LinkGet = 0 + SubString(webby.NavigatingURL,(StrLength(hyper)+1),StrLength(webby.NavigatingURL)-(StrLength(hyper)+2)) myCMD.Text = trim(myCMD.Text) & " " & xItemAutoGet(LinkGet) End If End If If right(webby.NavigatingURL,1) = "c" Then ' dropping item If trim(myCMD.Text) = "" Then LinkDrop = 0 + SubString(webby.NavigatingURL,(StrLength(hyper)+1),StrLength(webby.NavigatingURL)-(StrLength(hyper)+2)) myCMD.Text = "DROP " & xItemAutoGet(LinkDrop) Else LinkDrop = 0 + SubString(webby.NavigatingURL,(StrLength(hyper)+1),StrLength(webby.NavigatingURL)-(StrLength(hyper)+2)) myCMD.Text = trim(myCMD.Text) & " " & trim(xItemAutoGet(LinkDrop)) End If End If DoEvents Timer1.Enabled = True End If End If End Sub Sub Timer1_Tick timer1.Enabled = False myCMD_Keypress(Chr(13)) End Sub Sub InsertChar(mychar) If myCMD.SelectionLength > 0 Then ButDEL_Click myICpos = myCMD.SelectionStart myCMD.Text = StrInsert(myCMD.Text,myICpos,mychar) myCMD.Focus myCMD.Selectionstart = myICpos + 1 myCMD.SelectionLength = 0 End Sub Sub ButQ_Click:If ABCison = "Y" Then InsertChar("Q") Else InsertChar("1"): End Sub Sub ButR_Click:If ABCison = "Y" Then InsertChar("R") Else InsertChar("4"): End Sub Sub ButT_Click:If ABCison = "Y" Then InsertChar("T") Else InsertChar("5"): End Sub Sub ButY_Click:If ABCison = "Y" Then InsertChar("Y") Else InsertChar("6"): End Sub Sub ButO_Click:If ABCison = "Y" Then InsertChar("O") Else InsertChar("9"): End Sub Sub ButP_Click:If ABCison = "Y" Then InsertChar("P") Else InsertChar("0"): End Sub Sub ButA_Click:InsertChar("A"): End Sub Sub ButF_Click:InsertChar("F"): End Sub Sub ButG_Click:InsertChar("G"): End Sub Sub ButJ_Click:InsertChar("J"): End Sub Sub ButK_Click:InsertChar("K"): End Sub Sub ButZ_Click:InsertChar("Z"): End Sub Sub ButX_Click:InsertChar("X"): End Sub Sub ButC_Click:InsertChar("C"): End Sub Sub ButV_Click:InsertChar("V"): End Sub Sub ButB_Click:InsertChar("B"): End Sub Sub ButM_Click:InsertChar("M"): End Sub Sub ButSPACE_Click:InsertChar(" "): End Sub Sub ButDEL_Click Dim Ldel Dim DELtmp If mycmd.SelectionStart = 0 AND mycmd.SelectionLength = 0 Then Return mydeltmp = mycmd.SelectionStart mydelseltmp = mycmd.SelectionLength If mydelseltmp >0 Then DELtmp = "" For Ldel = 0 To StrLength(myCMD.Text) -1 If Ldel < mydeltmp OR Ldel > (mydeltmp+mydelseltmp)-1 Then DELtmp = DELtmp & SubString(myCMD.Text,Ldel,1) Next Ldel myCMD.Text = DELtmp If mydeltmp > 0 Then myCMD.SelectionStart = mydeltmp Else myCMD.SelectionStart = 0 Else myCMD.Text = SubString(myCMD.Text,0,mydeltmp -1) & right(myCMD.Text, StrLength(myCMD.Text) - (mydeltmp)) If mydeltmp > 0 Then myCMD.SelectionStart = mydeltmp - 1 Else myCMD.SelectionStart = 0 End If End Sub Sub ButENTER_Click If Sleeping = "Y" Then Return myCMD_Keypress(Chr(13)) End Sub Sub ButN_Click If Sleeping = "Y" AND StrToUpper(myCMD.Text) = "N" Then Return If StrToUpper(myCMD.Text) = "N" Then myCMD_Keypress(Chr(13)) Else InsertChar("N") End Sub Sub ButE_Click If Sleeping = "Y" AND StrToUpper(myCMD.Text) = "E" Then Return If StrToUpper(myCMD.Text) = "E" Then myCMD_Keypress(Chr(13)) Else If ABCison = "Y" Then InsertChar("E") Else InsertChar("3") End If End Sub Sub ButW_Click If Sleeping = "Y" AND StrToUpper(myCMD.Text) = "W" Then Return If StrToUpper(myCMD.Text) = "W" Then myCMD_Keypress(Chr(13)) Else If ABCison = "Y" Then InsertChar("W") Else InsertChar("2") End If End Sub Sub ButS_Click If Sleeping = "Y" AND StrToUpper(myCMD.Text) = "S" Then Return If StrToUpper(myCMD.Text) = "S" Then myCMD_Keypress(Chr(13)) Else InsertChar("S") End Sub Sub ButU_Click If StrToUpper(myCMD.Text) = "U" Then If Sleeping = "Y" AND StrToUpper(myCMD.Text) = "U" Then Return myCMD_Keypress(Chr(13)) Else If ABCison = "Y" Then InsertChar("U") Else InsertChar("7") End If End Sub Sub ButD_Click If Sleeping = "Y" AND StrToUpper(myCMD.Text) = "D" Then Return If StrToUpper(myCMD.Text) = "D" Then myCMD_Keypress(Chr(13)) Else InsertChar("D") End Sub Sub ButH_Click If Sleeping = "Y" AND StrToUpper(myCMD.Text) = "H" Then Return If StrToUpper(myCMD.Text) = "H" Then myCMD_Keypress(Chr(13)) Else InsertChar("H") End Sub Sub ButL_Click If Sleeping = "Y" AND StrToUpper(myCMD.Text) = "L" Then Return If StrToUpper(myCMD.Text) = "L" Then myCMD_Keypress(Chr(13)) Else InsertChar("L") End Sub Sub ButI_Click If StrToUpper(myCMD.Text) = "I" Then If Sleeping = "Y" AND StrToUpper(myCMD.Text) = "I" Then Return myCMD_Keypress(Chr(13)) Else If ABCison = "Y" Then InsertChar("I") Else InsertChar("8") End If End Sub Sub ButINV_Click If Sleeping = "Y" Then Return myCMD.Text = "INVENTORY" myCMD_Keypress(Chr(13)) End Sub Sub ButHELP_Click If Sleeping = "Y" Then Return myCMD.Text = "HELP" myCMD_Keypress(Chr(13)) End Sub Sub ButGo_Click If Sleeping = "Y" Then Return myCMD_Keypress(Chr(13)) End Sub Sub ReadOptionsFromFile Dim warntmp Dim FileIsOpen FileIsOpen = "N" ErrorLabel (INIErrorHandler) FileOpen (iniR,AppPath & "\advpda.ini",cRead,,cASCII) warntmp = FileRead (iniR) FileIsOpen = "Y" OptionsMyAdv = FileRead (iniR) OptionsTheme = FileRead (iniR) OptionsFontSize = FileRead (iniR) OptionsLinks = FileRead (iniR) SeeLMAgain = FileRead (iniR) OptionsRvsInfo = FileRead (iniR) If OptionsLinks = 0 Then OptionsLinksOn = "Y" Else OptionsLinksOn = "N" AltHyper = FileRead (iniR) If AltHyper = 0 Then OptionsAltHyperOn = "N" hyper = "about:" Linkfix.SelectedIndex = 0 Else OptionsAltHyperOn = "Y" hyper = "file:///advpda.htm%3F" Linkfix.SelectedIndex = 1 End If OptionsFontBold = FileRead (iniR) Fontbold.SelectedIndex = OptionsFontBold myKbdOnOff = FileRead (iniR) If myKbdOnOff = "Y" Then KbdOnOff.Text = "Kbd = Y" Else KbdOnOff.Text = "Kbd = N" ShowSoftKeyboard (False) KeyboardIsOff = "Y" End If FileClose (iniR) If DisableLinks = "N" Then PDLinks.SelectedIndex = OptionsLinks Else OptionsLinks = 1 OptionsLinksOn = "N" PDLinks.SelectedIndex = 1 PDLinks.Enabled = False End If If OptionsRvsInfo = "Y" Then PDOptRvs.SelectedIndex = 0 Else PDOptRvs.SelectedIndex = 1 If AltHyper = 1 Then CreateDummy Return INIErrorHandler: If FileIsOpen = "Y" Then FileClose (iniR) OptionsMyAdv = 0 OptionsTheme = "A Pastel Paradise" OptionsFontSize = 1 OptionsFontBold = 0 OptionsLinks = 0 OptionsLinksOn = "Y" AltHyper = 0 OptionsAltHyperOn = "N" hyper="about:" PDLinks.SelectedIndex = 0 OptionsFontBold = 0 Fontbold.SelectedIndex = OptionsFontBold SeeLMAgain = "Y" If DisableLinks = "N" Then PDLinks.SelectedIndex = OptionsLinks Else OptionsLinksOn = "N" OptionsLinks = 1 PDLinks.SelectedIndex = 1 PDLinks.Enabled = False End If OptionsRvsInfo = "N" PDOptRvs.SelectedIndex = 1 End Sub Sub HTML_Stuff FontFace = "MS Sans Serif" FontSize = OptionsFontSize HTML_START = "" HTML_START = HTML_START & "" HTML_LOOK_START = "
" HTML_LOOK_END = "
" HTML_EXIT_START = "
" HTML_EXIT_END = "
" HTML_MESG_START = "
" HTML_MESG_END = "
" HTML_LK_PROMPT_START = "" HTML_EX_PROMPT_START = "" HTML_PROMPT_END = "" HTML_LINE = "
" HTML_END = "" End Sub Sub SaveOptionsToFile 'ErrorLabel (INISaveErrorHandler) FileOpen (iniS,AppPath & "\advpda.ini",cWrite,,cASCII) FileWrite (iniS, OptionsWarning) FileWrite (iniS, OptionsMyAdv) FileWrite (iniS, OptionsTheme) FileWrite (iniS, OptionsFontSize) FileWrite (iniS, OptionsLinks) FileWrite (iniS, SeeLMAgain) FileWrite (iniS, OptionsRvsInfo) FileWrite (iniS, AltHyper) FileWrite (iniS, OptionsFontBold) FileWrite (inis, myKbdOnOff) FileClose (iniS) Return INISaveErrorHandler: Msgbox ("Error saving options to INI file.","Warning",cMsgboxOK) End Sub Sub FAdventure_Close If ComputerExit = False Then If Msgbox ("Exit current quest?" & CRLF & CRLF & "Are you sure?","Exit", cMsgboxYesNo,cMsgboxQuestion) = cNo Then FAdventure.CancelClose End If End If computerexit = False End Sub Sub MenuLoad_Click LoadMyGame End Sub Sub MenuSave_Click If Sleeping = "Y" Then Return SaveMyGame End Sub Sub MenuNew_Click If Msgbox ("Exit current quest?" & CRLF & CRLF & "Are you sure?","New Game", cMsgboxYesNo,cMsgboxQuestion) = cYes Then computerexit = True FSelect.Show End If End Sub Sub ButOther_click OpeningOther = "Y" OpenDialog1.Filter = "Data Files|*.dat" If OpenDialog1.Show <> cCancel Then cancel = False Webby.DocumentText = "
" cancel = True webby.CancelNavigate = True For L = 1 To 5 DoEvents Sleep (100) Next L FAdventure.Show For L = 1 To 5 DoEvents Sleep (100) Next L myadventure = OpenDialog1.File myCMD.Text = "" myCMD.Focus webby.CancelNavigate = True LoadFile (myadventure) refreshweb ButEnter.Enabled = True ButDEL.Enabled = True ButGo.Enabled = True OpeningOther = "N" Else OpeningOther = "N" End If End Sub Sub FAboutScott_Click AboutSA.show TxtScott.SelectionStart = 0 TxtScott.SelectionLength = 0 End Sub Sub FEngine_Click AboutEngine.show TxtAboutEngine.SelectionStart = 0 TxtAboutEngine.SelectionLength = 0 End Sub Sub ScreenSizeCheck Dim SW,SH Dim ButAdj ButAdj = 0 ScreenType = "240x240" SW = fselect.Width SH = fselect.Height If (SW > 500 AND SW < 650) AND (SH > 400 AND SH < 490) Then ScreenType = "640x480" If (SW > 400 AND SW < 490) AND (SH > 500 AND SH < 650) Then ScreenType = "480x640" If (SW > 180 AND SW < 250) AND (SH > 250 AND SH < 330) Then ScreenType = "240x320" If (SW > 180 AND SW < 250) AND (SH > 329 AND SH < 361) Then ScreenType = "240x400" If (SW > 250 AND SW < 330) AND (SH > 180 AND SH < 250) Then ScreenType = "320x240" If (SW > 380 AND SW < 420) AND (SH > 180 AND SH < 200) Then ScreenType = "400x240" If (SW > 250 AND SW < 330) AND (SH > 250 AND SH < 330) Then ScreenType = "320x320" If (SW > 730 AND SW < 820) AND (SH > 400 AND SH < 490) Then ScreenType = "800x480" If (SW > 400 AND SW < 490) AND (SH > 730 AND SH < 820) Then ScreenType = "480x800" ' default screen is set up for 240x240 ' if screen res is bigger on either side, it then resizes If ScreenType = "320x320" Then myCMD.Left = myCMD.Left + 40 ButGo.Left = butGo.Left + 40 ButGETDROP.Left = ButGETDROP.Left + 40 ' Get Drop ButELC.Left = ButELC.Left + 40 ' Go Climb Swim Enter ButMAG.Left = ButMAG.Left + 40 ' Look Examine ButINV.Left = ButINV.Left + 40 ' Inventory ButHELP.Left = ButHELP.Left + 40 ' Help ButABC123.Left = ButABC123.Left + 40 ButA.Left = ButA.Left + 40: ButB.Left = ButB.Left + 40: ButC.Left = ButC.Left + 40: ButD.Left = ButD.Left + 40 ButE.Left = ButE.Left + 40: ButF.Left = ButF.Left + 40: ButG.Left = ButG.Left + 40: ButH.Left = ButH.Left + 40 ButI.Left = ButI.Left + 40: ButJ.Left = ButJ.Left + 40: ButK.Left = ButK.Left + 40: ButL.Left = ButL.Left + 40 ButM.Left = ButM.Left + 40: ButN.Left = ButN.Left + 40: ButO.Left = ButO.Left + 40: ButP.Left = ButP.Left + 40 ButQ.Left = ButQ.Left + 40: ButR.Left = ButR.Left + 40: ButS.Left = ButS.Left + 40: ButT.Left = ButT.Left + 40 ButU.Left = ButU.Left + 40: ButV.Left = ButV.Left + 40: ButW.Left = ButW.Left + 40: ButX.Left = ButX.Left + 40 ButY.Left = ButY.Left + 40: ButZ.Left = ButZ.Left + 40: ButDEL.Left = ButDEL.Left + 40 ButENTER.Left = ButENTER.Left + 40: ButSPACE.Left = ButSPACE.Left + 40 End If ' ----------------------------------------------------------------------------- ' -------------------- 320 x 240 ----------------------------------- ' ----------------------------------------------------------------------------- If ScreenType = "320x240" Then txtAboutEngine.Height = 179 txtAboutEngine.Width = 311 txtScott.Height = 179 txtScott.Width = 311 myCMD.Top = 134 myCMD.Width = myCMD.Width - 8 myCMD.FontSize = 7 myCMD.Height = myCMD.Height - 4 myCMD.Left = 238 ButGo.Visible = False ButGETDROP.Top = 152: ButGETDROP.Left = 238 ' Get Drop ButELC.Top = 152: ButELC.Left = 269 ' Go Climb Swim Enter ButMAG.Top = 152: ButMAG.Left = 295 ' Look Examine ButINV.Top = 170: ButINV.Left = 255 ' Inventory ButHELP.Top = 170: ButHELP.Left = 282 ' Help If KeyboardIsOff = "Y" Then myCMD.Top = 166: myCMD.Left = 2: myCMD.Width = 150: myCMD.FontSize = 9 ButGETDROP.Top = 166: ButGETDROP.Left = 170 ' Get Drop ButELC.Top = 166: ButELC.Left = 200 ' Go Climb Swim Enter ButMAG.Top = 166: ButMAG.Left = 230 ' Look Examine ButINV.Top = 166: ButINV.Left = 260 ' Inventory ButHELP.Top = 166: ButHELP.Left = 290 ' Help End If AdvDesc.Height = 113 BUTPlay.Left = 275 AdvDesc.Top = AdvDesc.Top + 25 AdvDesc.Width = 220 PDSelect.Top = 50 PDSelect.left = 116 LOGO.Height = 42 ButABC123.Top = ButABC123.Top - 77 ButA.Top = ButA.Top - 77: ButB.Top = ButB.Top - 77: ButC.Top = ButC.Top - 77: ButD.Top = ButD.Top - 77 ButE.Top = ButE.Top - 77: ButF.Top = ButF.Top - 77: ButG.Top = ButG.Top - 77: ButH.Top = ButH.Top - 77 ButI.Top = ButI.Top - 77: ButJ.Top = ButJ.Top - 77: ButK.Top = ButK.Top - 77: ButL.Top = ButL.Top - 77 ButM.Top = ButM.Top - 77: ButN.Top = ButN.Top - 77: ButO.Top = ButO.Top - 77: ButP.Top = ButP.Top - 77 ButQ.Top = ButQ.Top - 77: ButR.Top = ButR.Top - 77: ButS.Top = ButS.Top - 77: ButT.Top = ButT.Top - 77 ButU.Top = ButU.Top - 77: ButV.Top = ButV.Top - 77: ButW.Top = ButW.Top - 77: ButX.Top = ButX.Top - 77 ButY.Top = ButY.Top - 77: ButZ.Top = ButZ.Top - 77: ButDEL.Top = ButDEL.Top - 77 ButENTER.Top = ButENTER.Top - 77: ButSPACE.Top = ButSPACE.Top - 77 ShowSoftKeyboard(True) End If ' ----------------------------------------------------------------------------- ' -------------------- 240 x 320 ----------------------------------- ' ----------------------------------------------------------------------------- If ScreenType = "240x320" Then If KeyboardIsOff = "Y" Then ButAdj = 53 txtAboutEngine.Height = 260 txtScott.Height = 260 myCMD.Top = 190 + ButAdj ButGo.Top = 191 + ButAdj ButGETDROP.Top = 190 + ButAdj ButMAG.Top = 190 + ButAdj ButINV.Top = 190 + ButAdj ButHELP.Top = 190 + ButAdj ButELC.Top = 190 + ButAdj AdvDesc.Height = 220 AdvDesc.Left = 133 AdvDesc.Width = 105 BackGnd.Height = 162 BackGnd.Width = 122 ImgPic.Height = 160 ImgPic.Width = 120 PDSelect.Top = 50 PDSelect.Width = 125 LOGO.Height = 42 ButOther.Top = 240 ButOther.Width = 122 ButOther.Text = "Open other..." ShowSoftKeyboard(True) End If ' ----------------------------------------------------------------------------- ' -------------------- 400 x 240 ----------------------------------- ' ----------------------------------------------------------------------------- If ScreenType = "400x240" Then txtAboutEngine.Width = 392 txtScott.Width = 392 myCMD.Left = 50: myCMD.Width = 110 ButGo.Left = 170 ButGETDROP.Left = 200 ButMAG.Left = 230 ButINV.Left = 260 ButHELP.Left = 290 ButELC.Left = 320 AdvDesc.Height = 113 BUTPlay.Left = 315 AdvDesc.Top = AdvDesc.Top + 25 AdvDesc.Width = 220 PDSelect.Top = 50 PDSelect.left = 156 LOGO.Height = 42 ShowSoftKeyboard(False) End If ' ----------------------------------------------------------------------------- ' --------------------640 x 480 ----------------------------------------------- ' ----------------------------------------------------------------------------- If ScreenType = "640x480" Then txtAboutEngine.Height = 365: txtAboutEngine.Width = 631 txtScott.Height = 365: txtScott.Width = 631 myCMD.Top = 257: myCMD.Width = 154: myCMD.Height = 40: myCMD.Left = 480: myCMD.FontSize = 7 ButGo.Visible = False ButGETDROP.Top = 294: ButGETDROP.Left = 476: BUTGETDROP.Width = 54: BUTGETDROP.Height = 42 ' Get Drop ButELC.Top = 294: ButELC.Left = 538: ButELC.Width = 40: ButELC.Height = 42 ' Go Climb Swim Enter ButMAG.Top = 294: ButMAG.Left = 590: ButMAG.Width = 42: ButMAG.Height = 42 ' Look Examine ButINV.Top = 334: ButINV.Left = 510: ButINV.Width = 42: ButINV.Height = 42 ' Inventory ButHELP.Top = 334: ButHELP.Left = 560: ButHELP.Width = 44: ButHELP.Height = 42 ' Help BUTPlay.Left = 550: BUTPlay.Top = 10: BUTPlay.Width = 80: BUTPlay.Height = 80 AdvDesc.Top = 150: AdvDesc.Left = 220: AdvDesc.Height = 226: AdvDesc.Width = 380 BackGnd.Top = 148: BackGnd.Height = 220: BackGnd.Width = 184 ImgPic.Top = 150: ImgPic.Height = 216: ImgPic.Width = 180 PDSelect.Top = 100: PDSelect.Left = 220: PDSelect.Width = 380: PDSelect.Height = 40 If KeyboardIsOff = "Y" Then myCMD.Top = 335: myCMD.Left = 30: myCMD.Width = 280: myCMD.FontSize = 9 ButGETDROP.Top = 335: ButGETDROP.Left = 330 ' Get Drop ButELC.Top = 335: ButELC.Left = 390 ' Go Climb Swim Enter ButMAG.Top = 335: ButMAG.Left = 450 ' Look Examine ButINV.Top = 335: ButINV.Left = 510 ' Inventory ButHELP.Top = 335: ButHELP.Left = 570 ' Help End If LOGO.Height = 84: LOGO.Width = 374 ButOther.Top = 90: ButOther.Width = 184: ButOther.Height = 50: ButOther.Left = 5 ButOther.Text = "Open other..." ButABC123.Top = 300: ButABC123.Left = 6: ButABC123.Width = 32: ButABC123.Height = 72 ButQ.Top = 265: ButQ.Left = 2 : ButQ.Width = 40: ButQ.Height = 36 ButW.Top = 265: ButW.Left = 42 : ButW.Width = 40: ButW.Height = 36 ButE.Top = 265: ButE.Left = 82 : ButE.Width = 40: ButE.Height = 36 ButR.Top = 265: ButR.Left = 122 : ButR.Width = 40: ButR.Height = 36 ButT.Top = 265: ButT.Left = 162 : ButT.Width = 40: ButT.Height = 36 ButY.Top = 265: ButY.Left = 202 : ButY.Width = 40: ButY.Height = 36 ButU.Top = 265: ButU.Left = 242 : ButU.Width = 40: ButU.Height = 36 ButI.Top = 265: ButI.Left = 282 : ButI.Width = 40: ButI.Height = 36 ButO.Top = 265: ButO.Left = 322 : ButO.Width = 40: ButO.Height = 36 ButP.Top = 265: ButP.Left = 362 : ButP.Width = 40: ButP.Height = 36 ButDEL.Top = 265: ButDEL.Left = 402 : ButDEL.Width = 72: ButDEL.Height = 36 ButA.Top = 300: ButA.Left = 42 : ButA.Width = 40: ButA.Height = 36 ButS.Top = 300: ButS.Left = 82 : ButS.Width = 40: ButS.Height = 36 ButD.Top = 300: ButD.Left = 122 : ButD.Width = 40: ButD.Height = 36 ButF.Top = 300: ButF.Left = 162 : ButF.Width = 40: ButF.Height = 36 ButG.Top = 300: ButG.Left = 202 : ButG.Width = 40: ButG.Height = 36 ButH.Top = 300: ButH.Left = 242 : ButH.Width = 40: ButH.Height = 36 ButJ.Top = 300: ButJ.Left = 282 : ButJ.Width = 40: ButJ.Height = 36 ButK.Top = 300: ButK.Left = 322 : ButK.Width = 40: ButK.Height = 36 ButL.Top = 300: ButL.Left = 362 : ButL.Width = 40: ButL.Height = 36 ButENTER.Top = 300: ButENTER.Left = 402 : ButENTER.Width = 72: ButENTER.Height = 72 ButZ.Top = 336: ButZ.Left = 42 : ButZ.Width = 40: ButZ.Height = 36 ButX.Top = 336: ButX.Left = 82 : ButX.Width = 40: ButX.Height = 36 ButC.Top = 336: ButC.Left = 122: ButC.Width = 40: ButC.Height = 36 ButV.Top = 336: ButV.Left = 242 : ButV.Width = 40: ButV.Height = 36 ButB.Top = 336: ButB.Left = 282 : ButB.Width = 40: ButB.Height = 36 ButN.Top = 336: ButN.Left = 322 : ButN.Width = 40: ButN.Height = 36 ButM.Top = 336: ButM.Left = 362 : ButM.Width = 40: ButM.Height = 36 ButSPACE.Top = 336 : ButSPACE.Left = 162 : ButSPACE.Width = 80 : ButSPACE.Height = 36 ShowSoftKeyboard(True) ExpandOptions End If ' ----------------------------------------------------------------------------- ' --------------------480 x 640 ----------------------------------------------- ' ----------------------------------------------------------------------------- If ScreenType = "480x640" Then txtAboutEngine.Height = 520: txtAboutEngine.Width = 468 txtScott.Height = 520: txtScott.Width = 468 BUTPlay.Left = 390: BUTPlay.Top = 10: BUTPlay.Width = 80: BUTPlay.Height = 80 AdvDesc.Top = 100: AdvDesc.Left = 266: AdvDesc.Height = 490: AdvDesc.Width = 210 BackGnd.Top = 148: BackGnd.Left = 12: BackGnd.Height = 324: BackGnd.Width = 244 ImgPic.Top = 150: ImgPic.Left = 14: ImgPic.Height = 320: ImgPic.Width = 240 PDSelect.Top = 100: PDSelect.Left = 9: PDSelect.Width = 249: PDSelect.Height = 40 LOGO.Height = 84: LOGO.Width = 374: LOGO.Top = 10: LOGO.Left = 10 ButOther.Top = 480: ButOther.Width = 244: ButOther.Height = 50: ButOther.Left = 13 ButOther.Text = "Open other..." ButABC123.Top = 460: ButABC123.Left = 6: ButABC123.Width = 32: ButABC123.Height = 72 myCMD.Top = 385: myCMD.Left = 2: myCMD.Width = 180: myCMD.Height = 40 ButGO.Top = 385: ButGo.Left = 184: ButGo.Width = 36: ButGo.Height = 36 ButGETDROP.Top = 382: ButGETDROP.Left = 224: BUTGETDROP.Width = 54: BUTGETDROP.Height = 42 ' Get Drop ButELC.Top = 382: ButELC.Left = 284: ButELC.Width = 40: ButELC.Height = 42 ' Go Climb Swim Enter ButMAG.Top = 382: ButMAG.Left = 330: ButMAG.Width = 42: ButMAG.Height = 42 ' Look Examine ButINV.Top = 382: ButINV.Left = 380: ButINV.Width = 42: ButINV.Height = 42 ' Inventory ButHELP.Top = 382: ButHELP.Left = 424: ButHELP.Width = 44: ButHELP.Height = 42 ' Help If KeyboardIsOff = "Y" Then myCMD.Top = 490: myCMD.Left = 2: myCMD.Width = 180: myCMD.Height = 40 ButGO.Top = 490: ButGo.Left = 184: ButGo.Width = 36: ButGo.Height = 36 ButGETDROP.Top = 487: ButGETDROP.Left = 224: BUTGETDROP.Width = 54: BUTGETDROP.Height = 42 ' Get Drop ButELC.Top = 487: ButELC.Left = 284: ButELC.Width = 40: ButELC.Height = 42 ' Go Climb Swim Enter ButMAG.Top = 487: ButMAG.Left = 330: ButMAG.Width = 42: ButMAG.Height = 42 ' Look Examine ButINV.Top = 487: ButINV.Left = 380: ButINV.Width = 42: ButINV.Height = 42 ' Inventory ButHELP.Top = 487: ButHELP.Left = 424: ButHELP.Width = 44: ButHELP.Height = 42 ' Help End If ButQ.Top = 425: ButQ.Left = 2 : ButQ.Width = 40: ButQ.Height = 36 ButW.Top = 425: ButW.Left = 42 : ButW.Width = 40: ButW.Height = 36 ButE.Top = 425: ButE.Left = 82 : ButE.Width = 40: ButE.Height = 36 ButR.Top = 425: ButR.Left = 122 : ButR.Width = 40: ButR.Height = 36 ButT.Top = 425: ButT.Left = 162 : ButT.Width = 40: ButT.Height = 36 ButY.Top = 425: ButY.Left = 202 : ButY.Width = 40: ButY.Height = 36 ButU.Top = 425: ButU.Left = 242 : ButU.Width = 40: ButU.Height = 36 ButI.Top = 425: ButI.Left = 282 : ButI.Width = 40: ButI.Height = 36 ButO.Top = 425: ButO.Left = 322 : ButO.Width = 40: ButO.Height = 36 ButP.Top = 425: ButP.Left = 362 : ButP.Width = 40: ButP.Height = 36 ButDEL.Top = 425: ButDEL.Left = 404 : ButDEL.Width = 72: ButDEL.Height = 36 ButA.Top = 460: ButA.Left = 42 : ButA.Width = 40: ButA.Height = 36 ButS.Top = 460: ButS.Left = 82 : ButS.Width = 40: ButS.Height = 36 ButD.Top = 460: ButD.Left = 122 : ButD.Width = 40: ButD.Height = 36 ButF.Top = 460: ButF.Left = 162 : ButF.Width = 40: ButF.Height = 36 ButG.Top = 460: ButG.Left = 202 : ButG.Width = 40: ButG.Height = 36 ButH.Top = 460: ButH.Left = 242 : ButH.Width = 40: ButH.Height = 36 ButJ.Top = 460: ButJ.Left = 282 : ButJ.Width = 40: ButJ.Height = 36 ButK.Top = 460: ButK.Left = 322 : ButK.Width = 40: ButK.Height = 36 ButL.Top = 460: ButL.Left = 362 : ButL.Width = 40: ButL.Height = 36 ButENTER.Top = 460: ButENTER.Left = 404 : ButENTER.Width = 72: ButENTER.Height = 72 ButZ.Top = 496: ButZ.Left = 42 : ButZ.Width = 40: ButZ.Height = 36 ButX.Top = 496: ButX.Left = 82 : ButX.Width = 40: ButX.Height = 36 ButC.Top = 496: ButC.Left = 122: ButC.Width = 40: ButC.Height = 36 ButV.Top = 496: ButV.Left = 242 : ButV.Width = 40: ButV.Height = 36 ButB.Top = 496: ButB.Left = 282 : ButB.Width = 40: ButB.Height = 36 ButN.Top = 496: ButN.Left = 322 : ButN.Width = 40: ButN.Height = 36 ButM.Top = 496: ButM.Left = 362 : ButM.Width = 40: ButM.Height = 36 ButSPACE.Top = 496 : ButSPACE.Left = 162 : ButSPACE.Width = 80 : ButSPACE.Height = 36 ShowSoftKeyboard(True) ExpandOptions End If ' ----------------------------------------------------------------------------- ' --------------------240 x 400 ----------------------------------------------- ' ----------------------------------------------------------------------------- If ScreenType = "240x400" Then ButAdj = 0 If KeyboardIsOff = "Y" Then ButAdj = 54 txtAboutEngine.Height = 330 txtScott.Height = 330 myCMD.Top = 270 + ButAdj ButGo.Top = 271 + ButAdj ButGETDROP.Top = 270 + ButAdj ButMAG.Top = 270 + ButAdj ButINV.Top = 270 + ButAdj ButHELP.Top = 270 + ButAdj ButELC.Top = 270 + ButAdj AdvDesc.Height = 220: AdvDesc.Left = 133: AdvDesc.Width = 105 BackGnd.Height = 162: BackGnd.Width = 122 ImgPic.Height = 160: ImgPic.Width = 120 PDSelect.Top = 50: PDSelect.Width = 125 LOGO.Height = 42 ButOther.Top = 240: ButOther.Width = 122 ButOther.Text = "Open other..." ButQ.Top = 292: ButQ.Left = 2 ButW.Top = 292: ButW.Left = 22 ButE.Top = 292: ButE.Left = 42 ButR.Top = 292: ButR.Left = 62 ButT.Top = 292: ButT.Left = 82 ButY.Top = 292: ButY.Left = 102 ButU.Top = 292: ButU.Left = 122 ButI.Top = 292: ButI.Left = 142 ButO.Top = 292: ButO.Left = 162 ButP.Top = 292: ButP.Left = 182 ButDEL.Top = 292: ButDEL.Left = 202 ButABC123.Top = 310 ButA.Top = 310: ButA.Left = 22 ButS.Top = 310: ButS.Left = 42 ButD.Top = 310: ButD.Left = 62 ButF.Top = 310: ButF.Left = 82 ButG.Top = 310: ButG.Left = 102 ButH.Top = 310: ButH.Left = 122 ButJ.Top = 310: ButJ.Left = 142 ButK.Top = 310: ButK.Left = 162 ButL.Top = 310: ButL.Left = 182 ButENTER.Top = 310: ButENTER.Left = 202 ButZ.Top = 328: ButZ.Left = 22 ButX.Top = 328: ButX.Left = 42 ButC.Top = 328: ButC.Left = 62 ButV.Top = 328: ButV.Left = 122 ButB.Top = 328: ButB.Left = 142 ButN.Top = 328: ButN.Left = 162 ButM.Top = 328: ButM.Left = 182 ButSPACE.Top = 328 : ButSPACE.Left = 82 ShowSoftKeyboard(True) End If ' ----------------------------------------------------------------------------- ' --------------------800 x 480 / 480 x 800 ----------------------------------- ' ----------------------------------------------------------------------------- If ScreenType = "800x480" Then ' --- landscape txtAboutEngine.Height = 365: txtAboutEngine.Width = 791 txtScott.Height = 365: txtScott.Width = 791 myCMD.Top = 257: myCMD.Width = 154: myCMD.Height = 40: myCMD.Left = 560: myCMD.FontSize = 7 ButGo.Visible = False ButGETDROP.Top = 294: ButGETDROP.Left = 566: BUTGETDROP.Width = 54: BUTGETDROP.Height = 42 ' Get Drop ButELC.Top = 294: ButELC.Left = 618: ButELC.Width = 40: ButELC.Height = 42 ' Go Climb Swim Enter ButMAG.Top = 294: ButMAG.Left = 670: ButMAG.Width = 42: ButMAG.Height = 42 ' Look Examine ButINV.Top = 334: ButINV.Left = 590: ButINV.Width = 42: ButINV.Height = 42 ' Inventory ButHELP.Top = 334: ButHELP.Left = 650: ButHELP.Width = 44: ButHELP.Height = 42 ' Help If KeyboardIsOff = "Y" Then myCMD.Top = 334: myCMD.Width = 154: myCMD.Height = 40: myCMD.Left = 170: myCMD.FontSize = 7 ButGETDROP.Top = 334: ButGETDROP.Left = 350: BUTGETDROP.Width = 54: BUTGETDROP.Height = 42 ' Get Drop ButELC.Top = 334: ButELC.Left = 400: ButELC.Width = 40: ButELC.Height = 42 ' Go Climb Swim Enter ButMAG.Top = 334: ButMAG.Left = 450: ButMAG.Width = 42: ButMAG.Height = 42 ' Look Examine ButINV.Top = 334: ButINV.Left = 500: ButINV.Width = 42: ButINV.Height = 42 ' Inventory ButHELP.Top = 334: ButHELP.Left = 550: ButHELP.Width = 44: ButHELP.Height = 42 ' Help End If BUTPlay.Left = 630: BUTPlay.Top = 10: BUTPlay.Width = 80: BUTPlay.Height = 80 AdvDesc.Top = 150: AdvDesc.Left = 300: AdvDesc.Height = 226: AdvDesc.Width = 380 BackGnd.Top = 148: BackGnd.Height = 220: BackGnd.Width = 184: BackGnd.Left = BackGnd.Left + 80 ImgPic.Top = 150: ImgPic.Height = 216: ImgPic.Width = 180: ImgPic.Left = ImgPic.Left + 80 PDSelect.Top = 100: PDSelect.Left = 300: PDSelect.Width = 380: PDSelect.Height = 40 LOGO.Height = 84: LOGO.Width = 374: LOGO.Left = LOGO.Left + 80 ButOther.Top = 90: ButOther.Width = 184: ButOther.Height = 50: ButOther.Left = 85 ButOther.Text = "Open other..." ButQ.Top = 265: ButQ.Left = 82 : ButQ.Width = 40: ButQ.Height = 36 ButW.Top = 265: ButW.Left = 122 : ButW.Width = 40: ButW.Height = 36 ButE.Top = 265: ButE.Left = 162 : ButE.Width = 40: ButE.Height = 36 ButR.Top = 265: ButR.Left = 202 : ButR.Width = 40: ButR.Height = 36 ButT.Top = 265: ButT.Left = 242 : ButT.Width = 40: ButT.Height = 36 ButY.Top = 265: ButY.Left = 282 : ButY.Width = 40: ButY.Height = 36 ButU.Top = 265: ButU.Left = 322 : ButU.Width = 40: ButU.Height = 36 ButI.Top = 265: ButI.Left = 362 : ButI.Width = 40: ButI.Height = 36 ButO.Top = 265: ButO.Left = 402 : ButO.Width = 40: ButO.Height = 36 ButP.Top = 265: ButP.Left = 442 : ButP.Width = 40: ButP.Height = 36 ButDEL.Top = 265: ButDEL.Left = 482 : ButDEL.Width = 72: ButDEL.Height = 36 ButABC123.Top = 300: ButABC123.Left = 86: ButABC123.Width = 32: ButABC123.Height = 72 ButA.Top = 300: ButA.Left = 122 : ButA.Width = 40: ButA.Height = 36 ButS.Top = 300: ButS.Left = 162 : ButS.Width = 40: ButS.Height = 36 ButD.Top = 300: ButD.Left = 202 : ButD.Width = 40: ButD.Height = 36 ButF.Top = 300: ButF.Left = 242 : ButF.Width = 40: ButF.Height = 36 ButG.Top = 300: ButG.Left = 282 : ButG.Width = 40: ButG.Height = 36 ButH.Top = 300: ButH.Left = 322 : ButH.Width = 40: ButH.Height = 36 ButJ.Top = 300: ButJ.Left = 362 : ButJ.Width = 40: ButJ.Height = 36 ButK.Top = 300: ButK.Left = 402 : ButK.Width = 40: ButK.Height = 36 ButL.Top = 300: ButL.Left = 442 : ButL.Width = 40: ButL.Height = 36 ButENTER.Top = 300: ButENTER.Left = 482 : ButENTER.Width = 72: ButENTER.Height = 72 ButZ.Top = 336: ButZ.Left = 122 : ButZ.Width = 40: ButZ.Height = 36 ButX.Top = 336: ButX.Left = 162 : ButX.Width = 40: ButX.Height = 36 ButC.Top = 336: ButC.Left = 202 : ButC.Width = 40: ButC.Height = 36 ButV.Top = 336: ButV.Left = 322 : ButV.Width = 40: ButV.Height = 36 ButB.Top = 336: ButB.Left = 362 : ButB.Width = 40: ButB.Height = 36 ButN.Top = 336: ButN.Left = 402 : ButN.Width = 40: ButN.Height = 36 ButM.Top = 336: ButM.Left = 442 : ButM.Width = 40: ButM.Height = 36 ButSPACE.Top = 336 : ButSPACE.Left = 242 : ButSPACE.Width = 80 : ButSPACE.Height = 36 ShowSoftKeyboard(True) ExpandOptions End If If ScreenType = "480x800" Then If KeyboardIsOff = "Y" Then ButAdj = 106 txtAboutEngine.Height = 684: txtAboutEngine.Width = 468 ' DONE txtScott.Height = 684: txtScott.Width = 468 ' DONE BUTPlay.Left = 390: BUTPlay.Top = 10: BUTPlay.Width = 80: BUTPlay.Height = 80 AdvDesc.Top = 100: AdvDesc.Left = 266: AdvDesc.Height = 490: AdvDesc.Width = 210 BackGnd.Top = 148: BackGnd.Left = 12: BackGnd.Height = 324: BackGnd.Width = 244 ImgPic.Top = 150: ImgPic.Left = 14: ImgPic.Height = 320: ImgPic.Width = 240 PDSelect.Top = 100: PDSelect.Left = 9: PDSelect.Width = 249: PDSelect.Height = 40 LOGO.Height = 84: LOGO.Width = 374: LOGO.Top = 10: LOGO.Left = 10 ButOther.Top = 480: ButOther.Width = 244: ButOther.Height = 50: ButOther.Left = 13 ButOther.Text = "Open other..." myCMD.Top = 543 + ButAdj: myCMD.Left = 2: myCMD.Width = 180: myCMD.Height = 40 ' DONE ButGO.Top = 543 + ButAdj: ButGo.Left = 184: ButGo.Width = 36: ButGo.Height = 36 ' DONE ButGETDROP.Top = 541 + ButAdj: ButGETDROP.Left = 224: BUTGETDROP.Width = 54: BUTGETDROP.Height = 42 ' Get Drop ButELC.Top = 541 + ButAdj: ButELC.Left = 284: ButELC.Width = 40: ButELC.Height = 42 ' Go Climb Swim Enter ButMAG.Top = 541 + ButAdj: ButMAG.Left = 330: ButMAG.Width = 42: ButMAG.Height = 42 ' Look Examine ButINV.Top = 541 + ButAdj: ButINV.Left = 380: ButINV.Width = 42: ButINV.Height = 42 ' Inventory ButHELP.Top = 541 + ButAdj: ButHELP.Left = 424: ButHELP.Width = 44: ButHELP.Height = 42 ' Help ButQ.Top = 584: ButQ.Left = 2 : ButQ.Width = 40: ButQ.Height = 36 ButW.Top = 584: ButW.Left = 42 : ButW.Width = 40: ButW.Height = 36 ButW.Top = 584: ButW.Left = 42 : ButW.Width = 40: ButW.Height = 36 ButE.Top = 584: ButE.Left = 82 : ButE.Width = 40: ButE.Height = 36 ButR.Top = 584: ButR.Left = 122 : ButR.Width = 40: ButR.Height = 36 ButT.Top = 584: ButT.Left = 162 : ButT.Width = 40: ButT.Height = 36 ButY.Top = 584: ButY.Left = 202 : ButY.Width = 40: ButY.Height = 36 ButU.Top = 584: ButU.Left = 242 : ButU.Width = 40: ButU.Height = 36 ButI.Top = 584: ButI.Left = 282 : ButI.Width = 40: ButI.Height = 36 ButO.Top = 584: ButO.Left = 322 : ButO.Width = 40: ButO.Height = 36 ButP.Top = 584: ButP.Left = 362 : ButP.Width = 40: ButP.Height = 36 ButDEL.Top = 584: ButDEL.Left = 404 : ButDEL.Width = 72: ButDEL.Height = 36 ButABC123.Top = 620: ButABC123.Left = 6: ButABC123.Width = 32: ButABC123.Height = 72 ButA.Top = 620: ButA.Left = 42 : ButA.Width = 40: ButA.Height = 36 ButS.Top = 620: ButS.Left = 82 : ButS.Width = 40: ButS.Height = 36 ButD.Top = 620: ButD.Left = 122 : ButD.Width = 40: ButD.Height = 36 ButF.Top = 620: ButF.Left = 162 : ButF.Width = 40: ButF.Height = 36 ButG.Top = 620: ButG.Left = 202 : ButG.Width = 40: ButG.Height = 36 ButH.Top = 620: ButH.Left = 242 : ButH.Width = 40: ButH.Height = 36 ButJ.Top = 620: ButJ.Left = 282 : ButJ.Width = 40: ButJ.Height = 36 ButK.Top = 620: ButK.Left = 322 : ButK.Width = 40: ButK.Height = 36 ButL.Top = 620: ButL.Left = 362 : ButL.Width = 40: ButL.Height = 36 ButENTER.Top = 620: ButENTER.Left = 404 : ButENTER.Width = 72: ButENTER.Height = 72 ButZ.Top = 656: ButZ.Left = 42 : ButZ.Width = 40: ButZ.Height = 36 ButX.Top = 656: ButX.Left = 82 : ButX.Width = 40: ButX.Height = 36 ButC.Top = 656: ButC.Left = 122: ButC.Width = 40: ButC.Height = 36 ButV.Top = 656: ButV.Left = 242 : ButV.Width = 40: ButV.Height = 36 ButB.Top = 656: ButB.Left = 282 : ButB.Width = 40: ButB.Height = 36 ButN.Top = 656: ButN.Left = 322 : ButN.Width = 40: ButN.Height = 36 ButM.Top = 656: ButM.Left = 362 : ButM.Width = 40: ButM.Height = 36 ButSPACE.Top = 656 : ButSPACE.Left = 162 : ButSPACE.Width = 80 : ButSPACE.Height = 36 ShowSoftKeyboard(True) ExpandOptions End If End Sub Sub ExpandOptions LabOptFontSize.Top = 30: LabOptFontSize.Left = 20: LabOptFontSize.Width = 130: LabOptFontSize.Height = 40 PDFontSize.Top = 26: PDFontSize.Left = 148: PDFontSize.Width = 100: PDFontSize.Height = 44 BUTAPPLY.Top = 214: BUTAPPLY.Left = 352: BUTAPPLY.Width = 110: BUTAPPLY.Height = 50 LabOptTheme.Top = 90: LabOptTheme.Left = 20: LabOptTheme.Width = 100: LabOptTheme.Height = 40 PDTheme.Top = 88: PDTheme.Left = 150: PDTheme.Width = 310: PDTheme.Height = 42 LabOptLink.Top = 148: LabOptLink.Left = 20: LabOptLink.Width = 130: LabOptLink.Height = 40 PDLinks.Top = 148: PDLinks.Left = 150: PDLinks.Width = 100: PDLinks.Height = 44 LabOptMsgs.Top = 210: LabOptMsgs.Left = 20: LabOptMsgs.Width = 230: LabOptMsgs.Height = 40 PDOptRvs.Top = 210: PDOptRvs.Left = 148: PDOptRvs.Width = 100: PDOptRvs.Height = 44 labLinkfix.Top = 150: labLinkfix.Left = 260: labLinkfix.Width = 100: labLinkfix.Height = 50 Linkfix.Top = 150: Linkfix.Left = 360: Linkfix.Width = 100: Linkfix.Height = 44 labFontbold.Top = 30: labFontbold.Left = 280: labFontbold.Width = 70: labFontbold.Height = 40 Fontbold.Top = 30: Fontbold.Left = 360: Fontbold.Width = 100: Fontbold.Height = 44 KbdOnOff.Top = 210: KbdOnOff.Left = 250: KbdOnOff.Width = 100: KbdOnOff.Height = 44 End Sub Sub ShowSoftKeyboard(sksh) ButABC123.Visible = sksh ButA.Visible = sksh: ButB.Visible = sksh: ButC.Visible = sksh: ButD.Visible = sksh: ButE.Visible = sksh ButF.Visible = sksh: ButG.Visible = sksh: ButH.Visible = sksh: ButI.Visible = sksh: ButJ.Visible = sksh ButK.Visible = sksh: ButL.Visible = sksh: ButM.Visible = sksh: ButN.Visible = sksh: ButO.Visible = sksh ButP.Visible = sksh: ButQ.Visible = sksh: ButR.Visible = sksh: ButS.Visible = sksh: ButT.Visible = sksh ButU.Visible = sksh: ButV.Visible = sksh: ButW.Visible = sksh: ButX.Visible = sksh: ButY.Visible = sksh ButZ.Visible = sksh: ButDEL.Visible = sksh: ButENTER.Visible = sksh: ButSPACE.Visible = sksh End Sub Sub App_Start ReadOptionsFromFile bdi.New1 If SeeLMAgain <> "N" Then If (StrIndexOf(bdi.GetOSVersionString," 2.",0) > -1) OR (StrIndexOf(bdi.GetOSVersionString," 4.",0) > -1) OR (StrIndexOf(bdi.GetOSVersionString," 3.",0) > -1) Then DisableLinks = "Y" If Msgbox ("Your PDA does not support in-game links, but don't worry, these are optional for game play anyway." & CRLF & CRLF & "Do you want to see this message again?", "Info", cMsgboxYesNo,cMsgboxQuestion) = cNo Then SeeLMAgain = "N" Else SeeLMAgain = "Y" End If End If End If SaveOptionsToFile LoadThemes ScreenSizeCheck OptionsWarning = "' Do not change anything in this file." OptionsMyAdv = 0 OptionsTheme = "" OptionsFontSize = 1 OptionsLinks = 0 OptionsLinksOn = "Y" OptionsFontBold = 0 AltHyper = 0 OptionsAltHyperOn = "N" ReadOptionsFromFile ReadMyTheme (OptionsTheme) HTML_Stuff If KeyboardIsOff = "Y" Then If ScreenType = "320x320" Then webby.New1("FAdventure",0,0,320,188) If ScreenType = "400x240" Then webby.New1("FAdventure",0,0,400,165) If ScreenType = "240x240" Then webby.New1("FAdventure",0,0,240,165) If ScreenType = "320x240" Then webby.New1("FAdventure",0,0,320,163) If ScreenType = "240x320" Then webby.New1("FAdventure",0,0,240,240) If ScreenType = "240x400" Then webby.New1("FAdventure",0,0,240,320) If ScreenType = "640x480" Then webby.New1("FAdventure",0,0,640,331) If ScreenType = "480x640" Then webby.New1("FAdventure",0,0,480,483) If ScreenType = "800x480" Then webby.New1("FAdventure",0,0,800,324) If ScreenType = "480x800" Then webby.New1("FAdventure",0,0,480,640) End If If KeyboardIsOff = "N" Then If ScreenType = "320x320" Then webby.New1("FAdventure",0,0,320,188) If ScreenType = "400x240" Then webby.New1("FAdventure",0,0,400,165) If ScreenType = "240x240" Then webby.New1("FAdventure",0,0,240,165) If ScreenType = "320x240" Then webby.New1("FAdventure",0,0,320,133) If ScreenType = "240x320" Then webby.New1("FAdventure",0,0,240,188) If ScreenType = "240x400" Then webby.New1("FAdventure",0,0,240,268) If ScreenType = "640x480" Then webby.New1("FAdventure",0,0,640,254) If ScreenType = "480x640" Then webby.New1("FAdventure",0,0,480,377) If ScreenType = "800x480" Then webby.New1("FAdventure",0,0,800,254) If ScreenType = "480x800" Then webby.New1("FAdventure",0,0,480,537) End If ComputerExit = False myAdventure = "" FSelect.Show PDselect.SelectedIndex = OptionsMyAdv End Sub Sub KbdOnOff_Click If myKbdOnOff = "Y" Then KbdOnOff.Text = "Kbd = N" myKbdOnOff = "N" Else KbdOnOff.Text = "Kbd = Y" myKbdOnOff = "Y" End If Msgbox ("To take effect, you must restart AdvPDA after applying this setting.") End Sub Sub LoadThemes Dim XL Dim MyFileCount Dim MyPathLength Dim xctr, xctr2 MyFileCount = 0 'ErrorLabel (GETFILES) MyFileCount = FileSearch (ArrayList1, AppPath & "\themes", "*.thm") MyPathLength = StrLength (AppPath & "\themes") If MyFileCount = 0 Then Msgbox ("No themes found! Please reinstall the application!") Return End If For XL = 0 To MyFileCount -1 PDTheme.Add (SubString(ArrayList1.Item(XL),MyPathLength+1,StrLength(ArrayList1.Item(XL)) - MyPathLength - 5)) Next XL ' --- bubblesort the themes For xctr = 0 To MyFileCount -1 For xctr2 = xctr + 1 To MyFileCount -1 If StrCompare (PDTheme.item(xctr),PDTheme.item(xctr2)) > 0 Then Temp = PDTheme.Item(xctr) PDTheme.Item(xctr) = PDTheme.Item(xctr2) PDTheme.Item(xctr2) = Temp End If Next xctr2 Next xctr Return GETFILES: Msgbox ("Error finding themes! Please reinstall the application.") End Sub Sub MenuOptions_Click Dim XXL ReadOptionsFromFile PDFontSize.SelectedIndex = OptionsFontSize - 1 For XXL = 0 To PDTheme.Count - 1 If OptionsTheme = PDTheme.Item(XXL) Then PDTheme.SelectedIndex = XXL Next XXL FOptions.Show End Sub Sub BUTAPPLY_Click LastMsgHLColor = HTML_MESG_HYPERLINK OptionsTheme = PDTheme.Item(PDTheme.SelectedIndex) OptionsFontSize = PDFontSize.SelectedIndex + 1 OptionsLinks = PDLinks.SelectedIndex OptionsFontBold = Fontbold.SelectedIndex AltHyper = Linkfix.SelectedIndex If AltHyper = 0 Then OptionsAltHyperOn = "N" hyper = "about:" Linkfix.SelectedIndex = 0 Else OptionsAltHyperOn = "Y" hyper = "file:///advpda.htm%3F" Linkfix.SelectedIndex = 1 CreateDummy End If If (StrIndexOf(bdi.GetOSVersionString,"Windows NT",0) > -1) OR (StrIndexOf(bdi.GetOSVersionString,"Vista",0) > -1) Then OptionsAltHyperOn = "N" hyper = "about:" Linkfix.SelectedIndex = 0 End If OptionsLinksOn = SubString(PDLinks.Item(PDLinks.SelectedIndex),0,1) OptionsRvsInfo = SubString(PDOptRvs.Item(PDOptRvs.SelectedIndex),0,1) ReadMyTheme (PDTheme.Item(PDTheme.SelectedIndex)) HTML_Stuff Look txtMSG = StrReplace (txtMSG, LastMsgHLColor, HTML_MESG_HYPERLINK) refreshweb SaveOptionsToFile FOptions.Close FAdventure.Show End Sub Sub ReadMyTheme(themefile) Dim mythmline Dim mythmlineno Dim myfld, myval ErrorLabel (ThmErrorHandler) FileOpen (thmR, AppPath & "\themes\" & themefile & ".thm",cRead,,cASCII) mythemeline = FileRead(thmR) Do Until mythemeline = EOF If StrLength(mythemeline) > 0 Then mythemelineno = StrIndexOf(mythemeline, "=", 0) If mythemelineno > 0 Then myfld = SubString(mythemeline,0,mythemelineno) myval = SubString(mythemeline,mythemelineno + 1,StrLength(mythemeline)-mythemelineno-1) If StrLength(myval) = 7 AND SubString(myval,0,1) = "#" Then If StrToUpper(myfld) = "HTML_BODY_BACKGROUND" Then HTML_BODY_BACKGROUND = myval If StrToUpper(myfld) = "HTML_LOOK_BACKGROUND" Then HTML_LOOK_BACKGROUND = myval If StrToUpper(myfld) = "HTML_EXIT_BACKGROUND" Then HTML_EXIT_BACKGROUND = myval If StrToUpper(myfld) = "HTML_MESG_BACKGROUND" Then HTML_MESG_BACKGROUND = myval If StrToUpper(myfld) = "HTML_ROOM_TEXT" Then HTML_ROOM_TEXT = myval If StrToUpper(myfld) = "HTML_LOOK_TEXT" Then HTML_LOOK_TEXT = myval If StrToUpper(myfld) = "HTML_EXIT_TEXT" Then HTML_EXIT_TEXT = myval If StrToUpper(myfld) = "HTML_MESG_TEXT" Then HTML_MESG_TEXT = myval If StrToUpper(myfld) = "HTML_LOOK_PROMPT" Then HTML_LOOK_PROMPT = myval If StrToUpper(myfld) = "HTML_EXIT_PROMPT" Then HTML_EXIT_PROMPT = myval If StrToUpper(myfld) = "HTML_LOOK_HYPERLINK" Then HTML_LOOK_HYPERLINK = myval If StrToUpper(myfld) = "HTML_EXIT_HYPERLINK" Then HTML_EXIT_HYPERLINK = myval If StrToUpper(myfld) = "HTML_MESG_HYPERLINK" Then HTML_MESG_HYPERLINK = myval If StrToUpper(myfld) = "HTML_LINE_BREAK" Then HTML_LINE_BREAK = myval End If End If ' mythemelineno End If 'strlength mythemeline = FileRead (thmR) Loop FileClose (thmR) Return ThmErrorHandler: Msgbox ("Error whilst reading theme '" & AppPath & "\themes\" & themefile & ".thm'") OptionsMyAdv = 0 OptionsTheme = "A Pastel Paradise" OptionsFontSize = 1 End Sub Sub ButABC123_Click If ABCison = "N" Then ABCison = "Y" Else ABCison = "N" If ABCison = "Y" Then ButQ.Text = "Q" ButW.Text = "W" ButE.Text = "E" ButR.Text = "R" ButT.Text = "T" ButY.Text = "Y" ButU.Text = "U" ButI.Text = "I" ButO.Text = "O" ButP.Text = "P" Else ButQ.Text = "1" ButW.Text = "2" ButE.Text = "3" ButR.Text = "4" ButT.Text = "5" ButY.Text = "6" ButU.Text = "7" ButI.Text = "8" ButO.Text = "9" ButP.Text = "0" End If End Sub Sub CreateDummy FileOpen (c1,"\advpda.htm",cWrite,,cASCII) FileWrite (c1, " ") FileClose (c1) End Sub Sub CountCarrying Dim ccnum ccnum = 0 For ccii = 0 To NumItems If xItemLoc(ccii) = CARRIED Then ccnum = ccnum + 1 Next ccii Return ccnum End Sub