Core VBS

1Option Explicit 2Const VPinMAMEDriverVer = 3.57 3'======================= 4' VPinMAME driver core. 5'======================= 6' New in 3.57 (Update by nFozzy, DJRobX, chepas, Gaston) 7' - Beta 1 NF fastflips 2 8' - Add UsePdbLeds(top of script)/ChangedPDLEDs(controller)/PDLedCallback(callback) support and PDB.vbs especially for VP-PROC 9' - Added LTD3.vbs (LTD System III) 10' - Added FPVPX.vbs (1.01, helpers for Future Pinball conversions) 11' 12' New in 3.56 (Update by nFozzy, DJRobX, Fuzzel) 13' - Add specialized sega2.vbs for Apollo 13 and GoldenEye 14' - Update gts1.vbs and hankin.vbs so that the common coin keys (e.g. "5") also add coins on Gottlieb System 1 and Hankin tables 15' - vpmFlips fixes / improvements 16' - Fixed vpmFlips execute script error 17' - Added extra error check for detecting outdated system vbs files when UseSolenoids = 2 18' - Change GameOnSolenoid from 16 to 19 for Hankin 19' - Fixed an execute script issue that was causing dead flippers for some system languages 20' - S.A.M. fast flips support: To activate, add InitVpmFFlipsSAM to the table init. 21' Should work for most games (see PinMAME whatsnew for supported sets). May need additional configuration for two-stage flipper support. 22' - Whitestar fast flips support 23' - Capcom fast flips support 24' - Fix WPC tables that use 'cSingleLFlip' (regression from 3.55) 25' - Fix script errors if using NudgePlugIn.vbs 26' - Add Rubber, Ramp, Flasher, Primitive and HitTarget support to vpmToggleObj 27' - Add Rubber, Primitive and HitTarget support to vpmCreateEvents 28' 29' New in 3.55 (Update by nFozzy) 30' - Prevent 'object not a collection' errors if vpmNudge.TiltObj isn't set 31' - Support for double leaf flipper switches 32' - For now, keybinds for these staged flippers are defined in VPMKeys.vbs. By default they are set to LeftFlipperKey and RightFlipperKey, disabling them. 33' - Adapting older tables requires vpmFlips: Create upper flipper subs and point SolCallback(sULFlipper) and SolCallback(sURFlipper) to them. 34' - This may break compatibility with some older WPC tables that use the 'cSingleLFlip' method (More info in WPC.vbs), note that close to no 'modern' (e.g. VP8/VP9/VPX) table uses this anyway 35' - Integrated FastFlips, (new object vpmFlips): Low latency flipper response for games with pre-solid state flippers 36' - Ensure 'vpmInit me' is called in the table init section 37' - UseSolenoids = 2 enables and auto sets the game-on solenoid (based on GameOnSolenoid in the system .vbs script) 38' - Important info on supported WPC games is documented in WPC.vbs 39' - Pre-solid-state flipper games (except Zaccaria and LTD) should work perfectly. This includes Bally/Williams WPCs up to Terminator 2 / Party Zone 40' - Data East / early Segas will work perfectly, unless they have ROM-controlled flipper effects 41' - Fliptronics and WPC-S games (Addams Family through Jack Bot / WHO Dunnit) will work with caveats (no ROM controlled flipper effects, beware stuck balls. More info in WPC.vbs) 42' - Sega Whitestar (Apollo 13 / Goldeneye / etc), WPC95 (Congo / AFM / etc), and Capcom and everything onward will not work 43' - There's also a debug test command which may be useful if it's not working properly. Open the debug window (Accessible from the VP-escape menu, press the ">" button to bring up the text field) and type in 'vpmFlips.DebugTest' 44' 45' New in 3.54 (Update by mfuegemann & nFozzy & Ninuzzu/Tom Tower & Toxie) 46' - Added UltraDMD_Options.vbs to configure Ultra DMD based tables globally (see the file itself for detailed descriptions) 47' - Added sam.vbs 48' - Added Class1812.vbs 49' - Added inder_centaur.vbs 50' - Restore basic functionality of cvpmDropTarget.CreateEvents for drop targets with an animation time (e.g. VP10 and newer) 51' - Minor cleanups and code unifications for all machines 52' - Add keyConfigurations to VPMKeys.vbs for Taito and also remap the hardcoded keycode '13' to keySoundDiag 53' 54' New in 3.53 (Update by Toxie) 55' - Add more key mappings to help dialog 56' 57' New in 3.52 (Update by DJRobX & Toxie) 58' - Change default interval of the PinMAME timer to -1 (frame-sync'ed) if VP10.2 (or newer) is running 59' - Add modulated solenoids to support ROM controlled fading flashers: 60' To use, add "UseVPMModSol=True" to the table script 61' Also use SolModCallback instead of SolCallback to receive level changes as input: It will be a level from 0 to 255. 62' Just continue to use SolCallback if you only care about boolean values though, as it will only fire if level changes from on to off. 63' Note: vpmInit MUST BE CALLED or VPM will not switch modes (if you are only getting 0 and 1 from SolModCallback then that may be the issue) 64' 65' New in 3.51 (Update by mfuegemann & Arngrim & Toxie) 66' - gts1.vbs dip fix 67' - Add comments to cvpmDropTarget.CreateEvents: do not use this anymore in VP10 and above, as drop targets have an animation time nowadays 68' - Change default interval of the PinMAME timer to 3 if VP10 (or newer) is running, and leave it at 1 for everything else 69' - Fix missing SlingshotThreshold() when using VP8.X 70' - (Controller.vbs changes) 71' - now its allowed to have each toy to be set to 0 (sound effect), 1 (DOF) or 2 (both) 72' - new DOF types: DOFFlippers, DOFTargets, DOFDropTargets 73' - all values are now stored in the registry (HKEY_CURRENT_USER\SOFTWARE\Visual Pinball\Controller\), and can also be changed from within VP10.2 and above 74' - InitializeOptions call added to the controller init, for tables that want to use this functionality during gameplay (options menu via F6) 75' 76' New in 3.50 (Update by Toxie & mfuegemann & Arngrim) 77' - Added MAC.vbs & IronBalls.vbs & Lancelot.vbs & Antar.vbs 78' - (Core changes) 79' - Increased NVOffset limit from 10 to 32 80' - Use temporary variables for Switch() calls to workaround current PROC issues 81' - Controller.vbs user-folder detection fix, and add simple PROC usage via LoadPROC (see Controller.vbs for details) 82' - Add UseVPMNVRAM = true to the table script (place before LoadVPM, or otherwise calling core.vbs) 83' to make changed content of NVRAM available (since last update) via the NVRAMCallback (delivers a three dimensional array with: location, new value, old value) 84' (requires VPM 2.7 or newer) 85' 86' New in 3.49 (Update by Arngrim) 87' - Add new Controller.vbs to abstract DOF, B2S, VPM and EM controller loading, usage and sound/effect handling, 88' see Controller.vbs header on how to use it exactly 89' 90' New in 3.48 (Update by JimmyFingers) 91' - (Core changes) 92' - Changed vpmNudge.TiltObj handling to use Bumper.Threshold / Wall.SlingshotThreshold temporary value changes rather than force / SlingshotStrength changes to disable tiltobj array objects 93' - There existed a bug in VP since at least the 9.x versions where the Wall.SlingshotStrength value being set by scripting during game play did change the value but the slingshot behaviour / "Slingshot Force" (from the editor) of the wall object did not change (i.e. did not have an effect); As a result the attempted disabling of bumpers and slingshots after a tilt event on supported games (that can send a relay for vpmNudge.SolGameOn ) would only work for the bumper objects 94' - Using thresholds instead also now has added benefit by not actually triggering the related _Hit or _Slingshot routines so animations, sound processing, and other potential nested subroutine calls will also not activate resulting in a better tilt simulation 95' Note: NudgePlugin option .vbs files were also updated as they contain and are reassigned the vpmNudge routines when invoked 96' 97' New in 3.47 (Update by Toxie) 98' - (Core changes) 99' - Add UseVPMColoredDMD = true to the table script (place before LoadVPM, or otherwise calling core.vbs) 100' to automatically pass the raw colored DMD data (RGB from 0..255) from VPM to VP (see VP10+ for details on how to display it) 101' 102' New in 3.46 (Update by KieferSkunk) 103' - (Core changes) 104' - Added two new classes: cvpmTrough and cvpmSaucer 105' - cvpmTrough takes over for cvpmBallStack in non-Saucer mode. 106' - Can handle any number of balls (no more "out of bounds" errors with lots of balls) 107' - Accurately simulates ball movement and switch interaction in a real trough 108' - cvpmSaucer takes over for cvpmBallStack in Saucer mode. 109' - cvpmBallStack is now considered "legacy" - kept for compatibility with existing tables. (No changes) 110' - Updated vbsdoc.html with these new classes. 111' - Added two helper functions, vpMin(a, b) and vpMax(a, b). 112' - These each take two numbers (or strings) and return the lower or higher of the two (respectively). 113' 114' New in 3.45 (Update by KieferSkunk) 115' - (Core changes) 116' - Rewrote cvpmDictionary as a wrapper around Microsoft's Scripting.Dictionary object. 117' This provides two major benefits: 118' (1) Improved performance: Keys are stored by hash/reference, not by index, and existence checks and key location are now O(1) instead of O(N) operations. 119' (2) Keys and Items can now both be primitive types or objects. You can use integers, strings, etc. as keys, and you can use any object as an Item. 120' Note: The only restriction is that a Key cannot be a Scripting.Dictionary or an Array. 121' - cvpmTurnTable now smoothly changes speeds and directions. You can adjust the following properties to change the turntable's behavior: 122' - MaxSpeed: Sets new maximum spin speed. If motor is on, turntable will smoothly accelerate to new speed. 123' - SpinUp: Sets new spin-up rate. If currently accelerating, turntable will accelerate at the new rate. 124' - SpinDown: Sets new spin-down rate. If currently slowing to a stop, turntable will decelerate at the new rate. 125' - SpinCW: True for clockwise rotation, False for counter-clockwise. If motor is on, switching this will smoothly reverse the turntable's direction. 126' 127' New in 3.44 (Update by Toxie) 128' - (Core changes) 129' - Added ability to define default ball mass (in VP Units) inside table script. 130' Defaults to 1 unit if undefined. Example... 131' Const BallMass = 2 '(place before LoadVPM, or otherwise calling core.vbs) 132' Note that this should be used if changing the ball size via BallSize, 133' as the mass is of course proportional to the radius of the ball: m=k*r^3. 134' One can also use the diameter/size like in VP, so BallMass=k*BallSize^3 with k=1/125000. 135' Example: BallSize = 55, so BallMass = (55*55*55)/125000 = 1.331. 136' - Add UseVPMDMD = true to the table script (place before LoadVPM, or otherwise calling core.vbs) 137' to automatically pass the raw DMD data (levels from 0..100) from VPM to VP (see VP10+ for details on how to display it) 138' - Add toggleKeyCoinDoor in VPMKeys.vbs to choose between a real coindoor setup (e.g. cabinets) and the 'classic' on/off behaviour (e.g desktops/keyboards) 139' - Add inverseKeyCoinDoor in VPMKeys.vbs to in addition choose between the behaviour of a real coindoor switch (key pressed = closed, key not pressed = open) 140' or the inverted behaviour (key pressed = open, key not pressed = closed) 141' - Increase maximum number of balls/conMaxBalls to 13 and conStackSw to 8 (for Apollo 13), use InitSw8() then instead of InitSw() 142' - Deprecate vpmSolFlip2, as VP10 does not feature speed on flippers anymore 143' 144' New in 3.43 (Update by Koadic) 145' - (Core Changes) 146' - Minor adjustment to vbs loading via LoadScript to account for files in nonstandard locations 147' - Fix minor bugs when loading some tables 148 149' New in 3.42 (Update by Koadic) 150' - (Core Changes) 151' - Minor adjustment to vpmInit to unpause controller before stopping controller 152' 153' New in 3.41 (Update by Koadic) 154' - (Core Changes) 155' - Modified vpmInit routine: 156' Added creation of _Exit routine to vpmInit to perform Controller.Stop (will retroactively effect all tables using vpmInit call) 157' Modified vpmInit to create _Paused, _UnPaused, and _Exit separately, so if any don't exit, they will be created individually 158' Modified Error handling to fix bug where vmpInit might throw "Invalid procedure call or argument" error 159' and cause table not to work due to improper Table_Init scripting. 160' - Added 2 functions: CheckScript(file) and LoadScript(file) that can return True/False as well as the latter loading the script if true. 161' These check for existance in either the Tables and Scripts directory and can return a boolean value as well as the LoadScript autoloading 162' the file, as opposed to my previous methods only checking the local folder containing the table being run. 163' CheckScript(file) checks for existance, and if found returns a True value 164' LoadScript(file) checks for existance, and if found, loads specified file (via ExecuteGlobal GetTextFile(file)) and returns a True value 165' Examples: 166' If LoadScript("thefile.vbs") Then DoThisOtherThing ' If Loadscript found 'thefile' and loaded it (returned true) then do this other thing 167' LoadScript("somefile.vbs") ' Checks for 'somefile' and loads it if it exists 168' - Reworked CheckLEDWiz routine into generic LoadScript(file) routine to allow for better detection of script in the VP tables 169' or scripts directory, not just current directory containing the table. 170' - Added ability to load NudgePlugIn.vbs and if found, it will be loaded and replace current default nudging class. 171' - This detection and autoloading can allow for 'on demand' replacement of other core components as well in the future. 172' - Added ability to load GlobalPlugIn.vbs containing any custom scripting the user wants loaded with the core.vbs (instead of modifying the core) 173' -(Other Additions) 174' - Updated B2BCollision.vbs with vpmBallCreate method and renamed new file to B2B.vbs (to maintain compatiblity with tables using old file). 175' 176' New in 3.40 (Update by Koadic) 177' - (Core Changes) 178' - Modified NVOffset routine to allow use of alternative controllers (like dB2S B2S.Server) 179' New in 3.39 (Update by Koadic) 180' - (Core Changes) 181' - Hopefully fixed bug introduced in 3.37 when using a VP version older than 9.0.10 182' New in 3.38 (Update by Koadic) 183' - (Core Changes) 184' - Added automatic detection of ledcontrol.vbs and enabling for LedWiz use, allowing concurrent use by both users and non users of an LedWiz 185' New in 3.37 (Update by Koadic) 186' - (Core Changes) 187' - Added ability to define default ballsize (in VP Units) inside table script. 188' Defaults to 50 vp units if undefined. Example... 189' Const BallSize = 47 '(place before LoadVPM, or otherwise calling core.vbs) 190' New in 3.36 (update courtesy of Koadic) 191' - (Core Changes) 192' - Added VPMVol routine for allowing setting of Global VPM Volume (normally adjustable from '~' key, but otherwise unsaveable without this) 193' - (System VBS Alterations) 194' - Added keyVPMVolume in VPMKeys.vbs, set to use the F12 key 195' - Added call to VPMVol routine in each system's .vbs file, allowing end-user to access the new routine 196' New in 3.35 (Update courtesy of Koadic) 197' - (Core Changes) 198' - Added NVOffset routine for allowing use of multiple nvram files per romset name 199' New in 3.34 (Update by Destruk) 200' - (System VBS Additions) 201' - Added Play2.vbs 202' New in 3.33 (Update by Destruk) 203' - (System VBS Additions) 204' - Added LTD.vbs 205' New in 3.32 (Update by Destruk) 206' - (System VBS Alterations) 207' - Added Playmatic Replay setting switches 208' New in 3.31 (Update by Destruk) 209' - (System VBS Additions) 210' - Added play1.vbs 211' New in 3.30 (Update by Destruk) 212' - (System VBS Additions) 213' - Added zacproto.vbs 214' New in 3.29 (Update by Noah) 215' - (System VBS Additions) 216' - Added jvh.vbs and ali.vbs by Destruk for Jac van Ham and Allied Leisure 217' Corrected VPBuild Number for slingshots/bumpers and ball decals - Seeker 218' New in 3.27 (Update by PD) 219' - (System VBS Additions) 220' - Added gts1.vbs by Inkochnito for Gottlieb System 1 221' New in 3.26 (Update by PD) 222' - (Core Changes) 223' - Added "GICallback2" function to support Steve Ellenoff's new support in VPM for Dimming GI in WMS games 224' GICallback returns numeric values 0-8 instead of a boolean 0 or 1 (on/off) like GICallback does. 225' Existing tables will need to be altered to support dimming levels and need to use GICallback2 instead. 226' The old GICallback is left intact so older tables are not broken by the new code 227' 228' New in 3.25 (release 2) (Update by PD) 229' - (Core Changes) 230' - Restored former flipper speed due to complaints about some tables having BTTF problem returned and a resolution 231' of arguments over the settings 232' - New Optional Flipper Code Added (vpmSolFlip2) that let's you specify both up and down-swing speeds in the script 233' plus the ability to turn flipper sounds on or off for that call 234' Format: vpmSolFlip2 (Flip1obj, Flip2obj, UpSpeed, DownSpeed, SoundOn, Enable) 235' 236' New in 3.24 (Update by PD) 237' - (Core Changes) 238' - Altered flipper code so the upswing defaults to your downswing (i.e. VBS no longer adds a different value) 239' (This change was done due to arguments over issues now resolved) 240' - I have decreased the return strength setting to be very low, though. So any downswing hits (say from a ball 241' heading to the trough) won't get hit with any real power. So, assuming you have a reasonably fast upswing, 242' you won't get any balls through the flipper and any balls hit by the underside won't get pegged anymore, which 243' is a more realistic behavior. 244' 245' New in 3.23 (Update by PD) 246' - (System.vbs Additions) 247' - SlamtTilt definitions added to AlvinG and Capcom systems 248' - High Score Reset Switch Added to Williams System7 (S7.vbs) 249' - Sleic.vbs system added (courtesy of Destruk) 250' - Peper.vbs system added (courtesy of Destruk) 251' - Juegos.vbs system added (courtesy of Destruk) 252' 253' New in 3.22 (Update by PD) 254' - (Core Changes) 255' - Outhole switch handling updated so it resets correctly with an F3 reset. 256' This affects mostly Gottlieb System3 games (Thanks Racerxme for pointing this out) 257' - Flipper handling modified to have a low return strength setting so any balls under such flippers 258' won't get hit hard. This allows the higher 'flipper fix' return speed without the associated hard hit issue. 259' - (System.vbs Additions) 260' -Inder.vbs test switches updated (Thanks Peter) 261' -Bally.vbs swSoundDiag value changed to -6 (Thanks Racerxme) 262' 263' New in 3.21 (Update by PD) 264' -(Core Changes) 265' - Attemped bug fix in the Impulse Plunger object that could cause weak plunges sometimes on full pulls 266' 267' -(System.vbs Additions) 268' -Zac1.vbs has the program enable switch added to it (Thanks TomB) 269' -GamePlan.vbs has the accounting reset switch added to it (Thanks Incochnito) 270' 271' -(Other Additions) 272' -PD Light System VBS file updated to V5.5 (adds fading reel pop bumper handler and checklight function) 273' 274' New in 3.20 (Update by PD) 275' -(System.vbs Additions) 276' -Apparently Atari2.vbs uses 81/83 for the flipper switches and Atar1.vbs uses 82/84 so this repairs 277' the Atari2.vbs file. 278' 279' New in 3.19 (Update by PD) 280' -(System.vbs Additions) 281' - Fixed the swLLFlip and swLRFlip switch numbers in the Atari1.vbs, Atari2.vbs and Atari.vbs files 282' SolFlipper should now work with Atari tables using the updated file 283' 284' New in 3.18 (Update by PD) 285' -(System.vbs Additions) 286' - Added Atari1.vbs and Atari2.vbs files (Thanks to Inkochnito). 287' -The old Atari.vbs file is now obsolete, but included for backwards compatability with any existing tables 288' that may have used it. New Tables should use the appropriate Atari1.vbs or Atari2.vbs files. 289' 290' New in 3.17 (Update by PD) 291' -(System.vbs Additions) 292' -Fixed wrong switch definition in Sys80.vbs for the self-test switch. The operator menus should work now. 293' (Thanks to Inkochnito for pointing it out). 294' -Added inder.vbs, nuova.vbs, spinball.vbs and mrgame.vbs files (Thanks to Destruk) 295' 296' New in 3.16 (Update by PD) 297' -(System.vbs Additions) 298' -Added "BeginModal" and "EndModal" statements to each system (required for latest versions of VP ( >V6.1) to 299' avoid problems during the VPM "F3" reset. 300' -(Other Additions) 301' - PDLightSystem Core updated to version 5.4 302' 303' New in 3.15 (Update by PD) 304' -(Core Additions) 305' - Added a new higher resolution Impulse Plunger Object 306' (It uses a trigger to plunge the ball. It can be a variable Manual Plunger or function as an Automatic Plunger) 307' (It also features random variance options and optional pull / plunge sounds) 308' 309' -(System.vbs Additions) 310' - Fixed wrong switch number for Tilt & Slam Tilt in Sega.vbs 311' - Added Master CPU Enter switch to S7.vbs for Dip Switch control in Williams System7 312' 313' -(Other Additions) 314' - Added PDLightSystem.vbs (V5.3) file to archive 315' (open it with a text editor to see how to use it; it's called separately like the core file) 316' 317' New in 3.14 (Update by PD) 318' -(System.vbs Additions) 319' - Added latest Zac1.vbs and Zac2.vbs files to archive 320' 321' New in 3.13 (Update by PD) 322' -(Core Additions) 323' - Added Destruk's code to "Add" or "Remove" a ball from the table when "B" is pressed. 324' - Added "AutoplungeS" call which is the same as "Autoplunger" except it will play a specified sound when fired 325' 326' -(System.vbs Additions) 327' - Taito.vbs updated to fix service menu keys and default dip switch menu added 328' - Dip Switch / Option Menu "class" code added to all table VBS scripts to ease menu coding for table authors 329' - Fixed some labeling errors and organization and added a "Last Updated" version comment at the start of each file 330' 331' New in 3.12 332' - Made flipper return speed a constant conFlipRetSpeed 333' - set conFlipRetSpeed to 0.137 to reduce ball thru flipper problem 334' 335' New in 3.11 336' - Added a short delay between balls in the ballstacks to ensure 337' that the game registers the switches as off when balls are rolling 338' in the trough. All balls should probably move at the same time but it is 339' a bit tricky to implement without changing a lot of code. 340' - Removed support for the wshltdlg.dll since funtionality is in VPM now 341' New in 3.10 342' - Public release 343' Put this at the top of the table file 344'LoadVPM "02000000", "xxx.VBS", 3.57 ' adapt 02000000 and 3.57 to the actually required minimum VPinMAME- and core scripts versions 345'Const cGameName = "xxxx" ' PinMAME short game name 346'Const UseSolenoids = True 347'Const UseLamps = True 348''Standard sound 349'Const SSolenoidOn = "SolOn" 'Solenoid activates 350'Const SSolenoidOff = "SolOff" 'Solenoid deactivates 351'Const SFlipperOn = "FlipperUp" 'Flipper activated 352'Const SFlipperOff = "FlipperDown" 'Flipper deactivated 353'Const SCoin = "Quarter" 'Coin inserted 354''Callbacks 355'Set LampCallback = GetRef("UpdateMultipleLamps") 356'Set GICallback = GetRef("UpdateGI") ' Original GI Callback (returns boolean on and off values only) 357'Set GICallback2 = GetRef("UpdateGI") ' New GI Callback supports Newer VPM Dimming GI and returns values numeric 0-8) 358'Set MotorCallback = GetRef("UpdateMotors") 359' 360'Sub LoadVPM(VPMver, VBSfile, VBSver) 361' On Error Resume Next 362' If ScriptEngineMajorVersion < 5 Then MsgBox "VB Script Engine 5.0 or higher required" 363' ExecuteGlobal GetTextFile(VBSfile) 364' If Err Then MsgBox "Unable to open " & VBSfile & ". Ensure that it is in the Scripts folder of Visual Pinball. " & vbNewLine & Err.Description : Err.Clear 365' Set Controller = CreateObject("VPinMAME.Controller") 366' If Err Then MsgBox "Can't Load VPinMAME." & vbNewLine & Err.Description 367' If VPMver>"" Then If Controller.Version < VPMver Or Err Then MsgBox "VPinMAME ver " & VPMver & " required." : Err.Clear 368' If VPinMAMEDriverVer < VBSver Or Err Then MsgBox VBSFile & " ver " & VBSver & " or higher required." 369'End Sub 370' 371'Sub Table_KeyDown(ByVal keycode) 372' If vpmKeyDown(keycode) Then Exit Sub 373' If keycode = PlungerKey Then Plunger.Pullback 374'End Sub 375'Sub Table_KeyUp(ByVal keycode) 376' If vpmKeyUp(keycode) Then Exit Sub 377' If keycode = PlungerKey Then Plunger.Fire 378'End Sub 379' 380'Const cCredits = "" 381'Sub Table_Init 382' vpmInit Me 383' On Error Resume Next 384' With Controller 385' .GameName = cGameName 386' If Err Then MsgBox "Can't start Game " & cGameName & vbNewLine & Err.Description : Exit Sub 387' .SplashInfoLine = cCredits 388' .HandleMechanics = 0 389' .ShowDMDOnly = True : .ShowFrame = False : .ShowTitle = False 390' .Run : If Err Then MsgBox Err.Description 391' End With 392' On Error Goto 0 393'' Nudging 394' vpmNudge.TiltSwitch = swTilt 395' vpmNudge.Sensitivity = 5 396' vpmNudge.TiltObj = Array(Bumper1,Bumper2,LeftslingShot,RightslingShot) 397'' Map switches and lamps 398' vpmCreateEvents colSwObjects ' collection of triggers etc 399' vpmMapLights colLamps ' collection of all lamps 400'' Trough handler 401' Set bsTrough = New cvpmBallStack 402' bsTrough.InitNoTrough BallRelease, swOuthole, 90, 2 403' 'or 404' bsTrough.InitSw swOuthole,swTrough1,swTrough2,0,0,0,0 405'--------------------------------------------------------------- 406Dim Controller ' VPinMAME Controller Object 407Dim vpmTimer ' Timer Object 408Dim vpmNudge ' Nudge handler Object 409Dim Lights(200) ' Put all lamps in an array for easier handling 410' If more than one lamp is connected, fill this with an array of each light 411Dim vpmMultiLights() : ReDim vpmMultiLights(0) 412Private gNextMechNo : gNextMechNo = 0 ' keep track of created mech handlers (would be nice with static members) 413 414' Callbacks 415Dim SolCallback(68) ' Solenoids (parsed at Runtime) 416Dim SolModCallback(68) ' Solenoid modulated callbacks (parsed at Runtime) 417Dim SolPrevState(68) ' When modulating solenoids are in use, needed to keep positive value levels from changing boolean state 418Dim LampCallback ' Called after lamps are updated 419Dim PDLedCallback ' Called after leds are updated 420Dim GICallback ' Called for each changed GI String 421Dim GICallback2 ' Called for each changed GI String 422Dim MotorCallback ' Called after solenoids are updated 423Dim vpmCreateBall ' Called whenever a vpm class needs to create a ball 424Dim BSize:If IsEmpty(Eval("BallSize"))=true Then BSize=25 Else BSize = BallSize/2 425Dim BMass:If IsEmpty(Eval("BallMass"))=true Then BMass=1 Else BMass = BallMass 426Dim UseDMD:If IsEmpty(Eval("UseVPMDMD"))=true Then UseDMD=false Else UseDMD = UseVPMDMD 427Dim UseModSol:If IsEmpty(Eval("UseVPMModSol"))=true Then UseModSol=false Else UseModSol = UseVPMModSol 428Dim UseColoredDMD:If IsEmpty(Eval("UseVPMColoredDMD"))=true Then UseColoredDMD=false Else UseColoredDMD = UseVPMColoredDMD 429Dim UseNVRAM:If IsEmpty(Eval("UseVPMNVRAM"))=true Then UseNVRAM=false Else UseNVRAM = UseVPMNVRAM 430Dim NVRAMCallback 431 432' Assign Null Default Sub so script won't error if only one is defined in a script (should redefine in your script) 433Set GICallback = GetRef("NullSub") 434Set GICallback2 = GetRef("NullSub") 435 436' Game specific info 437Dim ExtraKeyHelp ' Help string for game specific keys 438Dim vpmShowDips ' Show DIPs function 439'----------------------------------------------------------------------------- 440' These helper functions require the following objects on the table: 441' PinMAMETimer : Timer object 442' PulseTimer : Timer object 443 444 445' Available classes: 446' ------------------ 447' cvpmTimer (Object = vpmTimer) 448' (Public) .PulseSwitch - pulse switch and call callback after delay (default) 449' (Public) .PulseSw - pulse switch 450' (Public) .AddTimer - call callback after delay 451' (Public) .Reset - Re-set all ballStacks 452' (Friend) .InitTimer - initialise fast or slow timer 453' (Friend) .EnableUpdate - Add/remove automatic update for an instance 454' (Private) .Update - called from slow timer 455' (Private) .FastUpdate - called from fast timer 456' (Friend) .AddResetObj - Add object that needs to catch reset 457' 458' cvpmTrough (Create as many as needed) 459' (Public) .IsTrough - Get or Set whether this trough is the default trough (first trough sets this by default) 460' (Public) .Size - Get or Set total number of balls trough can hold 461' (Public) .EntrySw - Set switch number for trough entry (if any) - eg. Outhole 462' (Public) .AddSw - Assign a switch at a specific slot 463' (Public) .InitSwitches - Set trough switches using an array, from exit slot back toward entrance. 464' (Public) .InitExit - Setup exit kicker, force and direction 465' (Public) .InitExitVariance - Modify exit kick direction and force (+/-, min force = 1) 466' (Public) .InitEntrySounds - Sounds to play when a ball enters the trough 467' (Public) .InitExitSounds - Sounds to play when the exit kicker fires 468' (Public) .CreateEvents - Auto-generate hit events for VP entry kicker(s) associated with this trough 469' (Public) .MaxBallsPerKick - Set maximum number of balls to kick out (default 1) 470' (Public) .MaxSlotsPerKick - Set maximum slots from which to get balls when kicking out (default 1) 471' (Public) .Balls - Get current balls in trough, or set initial number of balls in trough 472' (Public) .BallsPending - Get number of balls waiting in trough entry 473' (Public) .Reset - Reset and update all trough switches 474' (Friend) .Update - Called from vpmTimer to update ball positions and switches 475' (Public) .AddBall - Add a ball to the trough from a kicker. If kicker is the exit kicker, stacks ball at exit. 476' (Public) .SolIn - Solenoid handler for entry solenoid 477' (Public) .SolOut - Solenoid handler for exit solenoid 478' 479' cvpmSaucer (Create as many as needed) 480' (Public) .InitKicker - Setup main kicker, switch, exit direction and force (including Z force) 481' (Public) .InitExitVariance - Modify kick direction and force (+/-, min force = 1) 482' (Public) .InitAltKick - Set alternate direction and force (including Z force) - for saucers with two kickers 483' (Public) .InitSounds - Sounds to play when a ball enters the saucer or the kicker fires 484' (Public) .CreateEvents - Auto-generate hit event for VP kicker(s) associated with this saucer 485' (Public) .AddBall - Add a ball to the saucer from a kicker. 486' (Public) .HasBall - True if the saucer is occupied. 487' (Public) .solOut - Fire the primary exit kicker. Ejects ball if one is present. 488' (Public) .solOutAlt - Fire the secondary exit kicker. Ejects ball with alternate forces if present. 489' 490' cvpmBallStack (DEPRECATED, but create as many as needed) 491' (Public) .InitSw - init switches used in stack 492' (Public) .InitSaucer - init saucer 493' (Public) .InitNoTrough - init a single ball, no trough handler 494' (Public) .InitKick - init exit kicker 495' (Public) .InitAltKick - init second kickout direction 496' (Public) .CreateEvents - Create addball events for kickers 497' (Public) .KickZ - Z axis kickout angle (radians) 498' (Public) .KickBalls - Maximum number of balls kicked out at the same time 499' (Public) .KickForceVar - Initial ExitKicker Force value varies by this much (+/-, minimum force = 1) 500' (Public) .KickAngleVar - ExitKicker Angle value varies by this much (+/-) 501' (Public) .BallColour - Set ball colour 502' (Public) .TempBallImage - Set ball image for next ball only 503' (Public) .TempBallColour - Set ball colour for next ball only 504' (Public) .BallImage - Set ball image 505' (Public) .InitAddSnd - Sounds when ball enters stack 506' (Public) .InitEntrySnd - Sounds for Entry kicker 507' (Public) .InitExitSnd - Sounds for Exit kicker 508' (Public) .AddBall - add ball in "kicker" to stack 509' (Public) .SolIn - Solenoid handler for entry solenoid 510' (Public) .EntrySol_On - entry solenoid fired 511' (Public) .SolOut - Solenoid handler for exit solenoid 512' (Public) .SolOutAlt - Solenoid handler for exit solenoid 2nd direction 513' (Public) .ExitSol_On - exit solenoid fired 514' (Public) .ExitAltSol_On - 2nd exit solenoid fired 515' (Public) .Balls - get/set number of balls in stack (default) 516' (Public) .BallsPending - get number of balls waiting to come in to stack 517' (Public) .IsTrough - Specify that this is the main ball trough 518' (Public) .Reset - reset and update all ballstack switches 519' (Friend) .Update - Update ball positions (from vpmTimer class) 520' Obsolete 521' (Public) .SolExit - exit solenoid handler 522' (Public) .SolEntry - Entry solenoid handler 523' (Public) .InitProxy - Init proxy switch 524 525' cvpmNudge (Object = vpmNudge) 526' Hopefully we can add a real pendulum simulator in the future 527' (Public) .TiltSwitch - set tilt switch 528' (Public) .Senitivity - Set tiltsensitivity (0-10) 529' (Public) .TiltObj - Set objects affected by tilt 530' (Public) .DoNudge dir,power - Nudge table 531' (Public) .SolGameOn - Game On solenoid handler 532' (Private) .Update - Handle tilting 533' 534' cvpmDropTarget (create as many as needed) 535' (Public) .InitDrop - initialise DropTarget bank 536' (Public) .CreateEvents - Create Hit events 537' (Public) .InitSnd - sound to use for targets 538' (Public) .AnyUpSw - Set AnyUp switch 539' (Public) .AllDownSw - Set all down switch 540' (Public) .AllDown - All targets down? 541' (Public) .Hit - A target had been hit 542' (Public) .SolHit - Solenoid handler for dropping a target 543' (Public) .SolUnHit - Solenoid handler for raising a target 544' (Public) .SolDropDown - Solenoid handler for Bank down 545' (Public) .SolDropUp - Solenoid handler for Bank reset 546' (Public) .DropSol_On - Reset target bank 547' (Friend) .SetAllDn - check alldown & anyup switches 548' 549' cvpmMagnet (create as many as needed) 550' (Public) .InitMagnet - initialise magnet 551' (Public) .CreateEvents - Create Hit/Unhit events 552' (Public) .Solenoid - Set solenoid that controls magnet 553' (Public) .GrabCenter - Magnet grabs ball at center 554' (Public) .MagnetOn - Turn magnet on and off 555' (Public) .X - Move magnet 556' (Public) .Y - Move magnet 557' (Public) .Strength - Change strength 558' (Public) .Size - Change magnet reach 559' (Public) .AddBall - A ball has come within range 560' (Public) .RemoveBall - A ball is out of reach for the magnet 561' (Public) .Balls - Balls currently within magnets reach 562' (Public) .AttractBall - attract ball to magnet 563' (Private) .Update - update all balls (called from timer) 564' (Private) .Reset - handle emulation reset 565' Obsolete 566' (Public) .Range - Change magnet reach 567 568' cvpmTurnTable (create as many as needed) 569' (Public) .InitTurnTable - initialise turntable 570' (Public) .CreateEvents - Create Hit/Unhit events 571' (Public) .MaxSpeed - Maximum speed 572' (Public) .SpinUp - Speedup acceleration 573' (Public) .SpinDown - Retardation 574' (Public) .Speed - Current speed 575' (Public) .MotorOn - Motor On/Off 576' (Public) .SpinCW - Control direction 577' (Public) .SolMotorState - Motor on/off solenoid handler 578' (Public) .AddBall - A ball has come withing range 579' (Public) .RemoveBall - A ball is out of reach for the magnet 580' (Public) .Balls - Balls currently within magnets reach 581' (Public) .AffectBall - affect a ball 582' (Private) .Update - update all balls (called from timer) 583' (Private) .Reset - handle emulation reset 584 585' cvpmMech (create as many as needed) 586' (Public) .Sol1, Sol2 - Controlling solenoids 587' (Public) .MType - type of mechanics 588' (Public) .Length, Steps 589' (Public) .Acc, Ret - Acceleration, retardation 590' (Public) .AddSw - Automatically controlled switches 591' (Public) .AddPulseSw - Automatically pulsed switches 592' (Public) .Callback - Update graphics function 593' (Public) .Start - Start mechanics handler 594' (Public) .Position - Current position 595' (Public) .Speed - Current Speed 596' (Private) .Update 597' (Private) .Reset 598' 599' cvpmCaptiveBall (create as many as needed) 600' (Public) .InitCaptive - Initialise captive balls 601' (Public) .CreateEvents - Create events for captive ball 602' (Public) .ForceTrans - Amount of force tranferred to captive ball (0-1) 603' (Public) .MinForce - Minimum force applied to the ball 604' (Public) .NailedBalls - Number of "nailed" balls infront of captive ball 605' (Public) .RestSwitch - Switch activated when ball is in rest position 606' (Public) .Start - Create moving ball etc. 607' (Public) .TrigHit - trigger in front of ball hit (or unhit) 608' (Public) .BallHit - Wall in front of ball hit 609' (Public) .BallReturn - Captive ball has returned to kicker 610' (Private) .Reset 611' 612' cvpmVLock (create as many as needed) 613' (Public) .InitVLock - Initialise the visible ball stack 614' (Public) .ExitDir - Balls exit angle (like kickers) 615' (Public) .ExitForce - Force of balls kicked out 616' (Public) .KickForceVar - Vary kickout force 617' (Public) .InitSnd - Sounds to make on kickout 618' (Public) .Balls - Number of balls in Lock 619' (Public) .SolExit - Solenoid event 620' (Public) .CreateEvents - Create events needed 621' (Public) .TrigHit - called from trigger hit event 622' (Public) .TrigUnhit - called from trigger unhit event 623' (Public) .KickHit - called from kicier hit event 624' 625' cvpmDips (create as many as needed) => (Dip Switch And/Or Table Options Menu) 626' (Public) .AddForm - create a form (AKA dialogue) 627' (Public) .AddChk - add a chckbox 628' (Public) .AddChkExtra - - "" - for non-dip settings 629' (Public) .AddFrame - add a frame with checkboxes or option buttons 630' (Public) .AddFrameExtra - - "" - for non-dip settings 631' (Public) .AddLabel - add a label (text string) 632' (Public) .ViewDips - Show form 633' (Public) .ViewDipsExtra - - "" - with non-dip settings 634' 635' cvpmImpulseP (create as many as needed) => (Impulse Plunger Object using a Trigger to Plunge Manual/Auto) 636' (Public) .InitImpulseP - Initialise Impulse Plunger Object (Trigger, Plunger Power, Time to Full Plunge [0 = Auto]) 637' (Public) .CreateEvents - Create Hit/Unhit events 638' (Public) .Strength - Change plunger strength 639' (Public) .Time - Change plunger time (in seconds) to full plunger strength (0 = Auto Plunger) 640' (Public) .Pullback - Pull the plunger back 641' (Public) .Fire - Fires / Releases the Plunger (Manual or Auto depending on Timing Value given) 642' (Public) .AutoFire - Fires / Releases the Plunger at Maximum Strength +/- Random variation (i.e. Instant Auto) 643' (Public) .Switch - Switch Number to activate when ball is sitting on plunger trigger (if any) 644' (Public) .Random - Sets the multiplier level of random variance to add (0 = No Variance / Default) 645' (Public) .InitEntrySnd - Plays Sound as Plunger is Pulled Back 646' (Public) .InitExitSnd - Plays Sound as Plunger is Fired (WithBall,WithoutBall) 647' 648' Generic solenoid handlers: 649' -------------------------- 650' vpmSolFlipper flipObj1, flipObj2 - "flips flippers". Set unused to Nothing 651' vpmSolFlip2 flipObj1, flipObj2, flipSpeedUp, flipSpeedDn, sndOn). Set unused to Nothing 652' vpmSolDiverter divObj, sound - open/close diverter (flipper) with/without sound 653' vpmSolWall wallObj, sound - Raise/Drop wall with/without sound 654' vpmSolToggleWall wall1, wall2, sound - Toggle between two walls 655' vpmSolToggleObj obj1,obj2,sound - Toggle any objects 656' vpmSolAutoPlunger plungerObj, var, enabled - Autoplunger/kickback 657' vpmSolAutoPlungeS plungerObj, sound, var, enabled - Autoplunger/kickback With Specified Sound To Play 658' vpmSolGate obj, sound - Open/close gate 659' vpmSolSound sound - Play sound only 660' vpmFlasher flashObj - Flashes flasher 661' 662' Generating events: 663' ------------------ 664' vpmCreateEvents 665' cpmCreateLights 666' 667' Variables declared (to be filled in): 668' --------------------------------------- 669' SolCallback() - handler for each solenoid 670' Lights() - Lamps 671' 672' Constants used (must be defined): 673' --------------------------------- 674' UseSolenoids - Update solenoids 675' MotorCallback - Called once every update for mechanics or custom sol handler 676' UseLamps - Update lamps 677' LampCallback - Sub to call after lamps are updated 678' (or every update if UseLamps is false) 679' GICallback - Sub to call to update GI strings 680' GICallback2 - Sub to call to update GI strings 681' SFlipperOn - Flipper activate sound 682' SFlipperOff - Flipper deactivate sound 683' SSolenoidOn - Solenoid activate sound 684' SSolenoidOff - Solenoid deactivate sound 685' SCoin - Coin Sound 686' ExtraKeyHelp - Game specific keys in help window 687' 688' Exported variables: 689' ------------------- 690' vpmTimer - Timer class for PulseSwitch etc 691' vpmNudge - Class for table nudge handling 692'----------------------------------------------------- 693Private Function PinMAMEInterval 694 If VPBuildVersion >= 10200 Then 695 PinMAMEInterval = -1 ' VP10.2 introduced special frame-sync'ed timers 696 Else 697 If VPBuildVersion >= 10000 Then 698 PinMAMEInterval = 3 ' as old VP9 timers pretended to run at 1000Hz but actually did only a max of 100Hz (e.g. corresponding nowadays to interval=10), we do something inbetween for VP10+ by default 699 Else 700 PinMAMEInterval = 1 701 End If 702 End If 703End Function 704 705Private Const conStackSw = 8 ' Stack switches 706Private Const conMaxBalls = 13 ' Because of Apollo 13 707Private Const conMaxTimers = 20 ' Spinners can generate a lot of timers 708Private Const conTimerPulse = 40 ' Timer runs at 25Hz 709Private Const conFastTicks = 4 ' Fast is 4 times per timer pulse 710Private Const conMaxSwHit = 5 ' Don't stack up more than 5 events for each switch 711 712' DEPRECATED Flipper constants: 713Private Const conFlipRetStrength = 0.01 ' Flipper return strength 714Private Const conFlipRetSpeed = 0.137 ' Flipper return speed 715 716Function CheckScript(file) 'Checks Tables and Scripts directories for specified vbs file, and if it exitst, will load it. 717 CheckScript = False 718 On Error Resume Next 719 Dim TablesDirectory:TablesDirectory = Left(UserDirectory,InStrRev(UserDirectory,"\",InStrRev(UserDirectory,"\")-1))&"Tables\" 720 Dim ScriptsDirectory:ScriptsDirectory = Left(UserDirectory,InStrRev(UserDirectory,"\",InStrRev(UserDirectory,"\")-1))&"Scripts\" 721 Dim check:Set check = CreateObject("Scripting.FileSystemObject") 722 If check.FileExists(tablesdirectory & file) Or check.FileExists(scriptsdirectory & file) Or check.FileExists(file) Then CheckScript = True 723 On Error Goto 0 724End Function 725 726Function LoadScript(file) 'Checks Tables and Scripts directories for specified vbs file, and if it exitst, will load it. 727 LoadScript = False 728 On Error Resume Next 729 If CheckScript(file) Then ExecuteGlobal GetTextFile(file):LoadScript = True 730 On Error Goto 0 731End Function 732 733' Dictionary 734' At one point, Microsoft had made Scripting.Dictionary "unsafe for scripting", but it's 735' been a long time since that was true. So now, to maintain compatibility with all tables 736' and scripts that use cvpmDictionary, this class is now a simple wrapper around Microsoft's 737' more efficient implementation. 738Class cvpmDictionary 739 Private mDict 740 Private Sub Class_Initialize : Set mDict = CreateObject("Scripting.Dictionary") : End Sub 741 742 ' DEPRECATED: MS Dictionaries are not index-based. Use "Exists" method instead. 743 Private Function FindKey(aKey) 744 Dim ii, key : FindKey = -1 745 If mDict.Count > 0 Then 746 ii = 0 747 For Each key In mDict.Keys 748 If key = aKey Then FindKey = ii : Exit Function 749 Next 750 End If 751 End Function 752 753 Public Property Get Count : Count = mDict.Count : End Property 754 755 Public Property Get Item(aKey) 756 Item = Empty 757 If mDict.Exists(aKey) Then 758 If IsObject(mDict(aKey)) Then 759 Set Item = mDict(aKey) 760 Else 761 Item = mDict(aKey) 762 End If 763 End If 764 End Property 765 766 Public Property Let Item(aKey, aData) 767 If IsObject(aData) Then 768 Set mDict(aKey) = aData 769 Else 770 mDict(aKey) = aData 771 End If 772 End Property 773 774 Public Property Set Key(aKey) 775 ' This function is (and always has been) a no-op. Previous definition 776 ' just looked up aKey in the keys list, and if found, set the key to itself. 777 End Property 778 779 Public Sub Add(aKey, aItem) 780 If IsObject(aItem) Then 781 Set mDict(aKey) = aItem 782 Else 783 mDict(aKey) = aItem 784 End If 785 End Sub 786 787 Public Sub Remove(aKey) : mDict.Remove(aKey) : End Sub 788 Public Sub RemoveAll : mDict.RemoveAll : End Sub 789 Public Function Exists(aKey) : Exists = mDict.Exists(aKey) : End Function 790 Public Function Items : Items = mDict.Items : End Function 791 Public Function Keys : Keys = mDict.Keys : End Function 792End Class 793 794'-------------------- 795' Timer 796'-------------------- 797Class cvpmTimer 798 Private mQue, mNow, mTimers 799 Private mSlowUpdates, mFastUpdates, mResets, mFastTimer 800 801 Private Sub Class_Initialize 802 ReDim mQue(conMaxTimers) : mNow = 0 : mTimers = 0 803 Set mSlowUpdates = New cvpmDictionary 804 Set mFastUpdates = New cvpmDictionary 805 Set mResets = New cvpmDictionary 806 End Sub 807 808 Public Sub InitTimer(aTimerObj, aFast) 809 If aFast Then 810 Set mFastTimer = aTimerObj 811 aTimerObj.TimerInterval = conTimerPulse \ conFastTicks 812 aTimerObj.TimerEnabled = False 813 vpmBuildEvent aTimerObj, "Timer", "vpmTimer.FastUpdate" 814 Else 815 aTimerObj.Interval = conTimerPulse : aTimerObj.Enabled = True 816 vpmBuildEvent aTimerObj, "Timer", "vpmTimer.Update" 817 End If 818 End Sub 819 820 Sub EnableUpdate(aClass, aFast, aEnabled) 821 On Error Resume Next 822 If aFast Then 823 If aEnabled Then mFastUpdates.Add aClass, 0 : Else mFastUpdates.Remove aClass 824 mFastTimer.TimerEnabled = mFastUpdates.Count > 0 825 Else 826 If aEnabled Then mSlowUpdates.Add aClass, 0 : Else mSlowUpdates.Remove aClass 827 End If 828 End Sub 829 830 Public Sub Reset 831 Dim obj : For Each obj In mResets.Keys : obj.Reset : Next 832 End Sub 833 834 Public Sub FastUpdate 835 Dim obj : For Each obj In mFastUpdates.Keys : obj.Update : Next 836 End Sub 837 838 Public Sub Update 839 Dim ii, jj, sw, obj, mQuecopy 840 841 For Each obj In mSlowUpdates.Keys : obj.Update : Next 842 If mTimers = 0 Then Exit Sub 843 mNow = mNow + 1 : ii = 1 844 845 Do While ii <= mTimers 846 If mQue(ii)(0) <= mNow Then 847 If mQue(ii)(1) = 0 Then 848 If isObject(mQue(ii)(3)) Then 849 Call mQue(ii)(3)(mQue(ii)(2)) 850 ElseIf varType(mQue(ii)(3)) = vbString Then 851 If mQue(ii)(3) > "" Then Execute mQue(ii)(3) & " " & mQue(ii)(2) & " " 852 End If 853 mTimers = mTimers - 1 854 For jj = ii To mTimers : mQue(jj) = mQue(jj+1) : Next : ii = ii - 1 855 ElseIf mQue(ii)(1) = 1 Then 856 mQuecopy = mQue(ii)(2) 857 Controller.Switch(mQuecopy) = False 858 mQue(ii)(0) = mNow + mQue(ii)(4) : mQue(ii)(1) = 0 859 Else '2 860 mQuecopy = mQue(ii)(2) 861 Controller.Switch(mQuecopy) = True 862 mQue(ii)(1) = 1 863 End If 864 End If 865 ii = ii + 1 866 Loop 867 End Sub 868 869 Public Sub AddResetObj(aObj) : mResets.Add aObj, 0 : End Sub 870 871 Public Sub PulseSw(aSwNo) : PulseSwitch aSwNo, 0, 0 : End Sub 872 873 Public Default Sub PulseSwitch(aSwNo, aDelay, aCallback) 874 Dim ii, count, last 875 count = 0 876 For ii = 1 To mTimers 877 If mQue(ii)(1) > 0 And mQue(ii)(2) = aSwNo Then count = count + 1 : last = ii 878 Next 879 If count >= conMaxSwHit Or mTimers = conMaxTimers Then Exit Sub 880 mTimers = mTimers + 1 : mQue(mTimers) = Array(mNow, 2, aSwNo, aCallback, aDelay\conTimerPulse) 881 If count Then mQue(mTimers)(0) = mQue(last)(0) + mQue(last)(1) 882 End Sub 883 884 Public Sub AddTimer(aDelay, aCallback) 885 If mTimers = conMaxTimers Then Exit Sub 886 mTimers = mTimers + 1 887 mQue(mTimers) = Array(mNow + aDelay \ conTimerPulse, 0, 0, aCallback) 888 End Sub 889 890 Public Sub AddTimer2(aDelay, aCallback, aID) 891 If mTimers = conMaxTimers Then Exit Sub 892 mTimers = mTimers + 1 893 mQue(mTimers) = Array(mNow + aDelay \ conTimerPulse, 0, aID, aCallback) 894 End Sub 895End Class 896 897'-------------------- 898' Trough 899'-------------------- 900Class cvpmTrough 901 ' Takes over for older cvpmBallStack in "trough mode". Theory of operation: 902 ' A trough can hold up to N balls, and has N*2 "slots". A ball effectively takes 903 ' up two slots, so no two adjacent slots (0 and 1) can be occupied at the same time. 904 ' Switches are assigned to even slots only, which means that as balls move through 905 ' the trough, each switch is allowed to flip between open and closed. 906 ' Slot 0 is the exit, and can have additional balls "stacked" on it, simulating balls 907 ' falling onto the exit kicker instead of coming in from the entrance. Extra balls 908 ' can be queued up at the entrance, and will enter the trough only if there's room 909 ' for them. 910 911 Private mSlot(), mSw(), mEntrySw 912 Private mBallsInEntry, mMaxBallsPerKick, mStackExitBalls 913 Private mExitKicker, mExitDir, mExitForce, mDirVar, mForceVar 914 Private mSounds 915 916 ' If you want to see what the trough is doing internally, add a TextBox to your table 917 ' named "DebugBox" (recommend Courier New or FixedSys at a small font size) and set 918 ' this variable to true via .isDebug = True. 919 Private mDebug 920 921 Private Sub Class_Initialize 922 Dim ii 923 924 ReDim mSw(conMaxBalls), mSlot(conMaxBalls * 2) 925 For ii = 0 to UBound(mSlot) : mSlot(ii) = 0 : Next ' All slots empty to start 926 For ii = 0 to UBound(mSw) : mSw(ii) = 0 : Next ' All switches unassigned to start. 927 mEntrySw = 0 928 929 Set mExitKicker = Nothing 930 mExitDir = 0 : mExitForce = 1 : mDirVar = 0 : mForceVar = 0 931 mBallsInEntry = 0 : mMaxBallsPerKick = 1 : mStackExitBalls = 1 932 933 Set mSounds = New cvpmDictionary 934 935 mDebug = False 936 937 If Not IsObject(vpmTrough) Then Set vpmTrough = Me 938 End Sub 939 940 Public Property Let IsTrough(aYes) 941 If aYes Then 942 Set vpmTrough = Me 943 ElseIf Me Is vpmTrough Then 944 Set vpmTrough = Nothing 945 End If 946 End Property 947 948 Public Property Get IsTrough 949 IsTrough = (Me Is vpmTrough) 950 End Property 951 952 ' Initialization 953 954 Public Property Let isDebug(enabled) : mDebug = enabled : End Property 955 956 Public Property Let Size(aSize) 957 Dim oldSize, newSize, ii 958 oldSize = UBound(mSw) 959 newSize = vpMax(1, aSize) 960 961 ReDim Preserve mSlot(newSize * 2) 962 ReDim Preserve mSw(newSize) 963 For ii = oldSize+1 To newSize : mSw(ii) = 0 : Next 964 For ii = (oldSize*2) + 1 to (newSize*2) : mSlot(ii) = 0 : Next 965 End Property 966 Public Property Get Size : Size = UBound(mSw) : End Property 967 968 ' Set EntrySw = 0 if you want balls to just fall into the trough automatically. 969 ' Set it to a real switch number to indicate that a ball is occupying an entry kicker. 970 ' The ROM in the controller is then responsible for kicking the ball into the trough. 971 Public Property Let EntrySw(swNo) : mEntrySw = swNo : End Property 972 973 ' Assign switches, starting from slot 0 and going to entrance. 974 ' This sub allows you to pass in as many switches as you wish. 975 Public Sub InitSwitches(switchArray) 976 If Not IsArray(switchArray) Then 977 Err.Raise 17, "cvpmTrough.InitSwitches: Input must be an array." 978 End If 979 980 Dim ii 981 For ii = 0 to UBound(mSw) 982 If ii > UBound(switchArray) Then 983 mSw(ii) = 0 984 Else 985 mSw(ii) = switchArray(ii) 986 End If 987 Next 988 End Sub 989 990 ' Alternative: Assign a switch to a specific slot. 991 Public Sub AddSw(slotNo, swNo) 992 If slotNo < 0 OR slotNo > UBound(mSw) Then Exit Sub 993 mSw(slotNo) = swNo 994 End Sub 995 996 ' MaxBallsPerKick: Kick up to N balls total per exit kick. Balls are only kicked from Slot 0. 997 ' StackExitBalls: Automatically stack up to N balls in Slot 0 regardless of where they came from. 998 999 ' Example: Subway where exit kicker is on the same level as the trough and a ball can 1000 ' come in from the exit: StackExitBalls = 1, MaxBallsPerKick = 2. If Slot 0 has 1 1001 ' ball and Slot 1 is occupied, only one ball will be kicked. If Slot 0 has 2 or more 1002 ' balls, it'll kick out 2 balls. 1003 1004 ' Example: Twilight Zone Slot Kicker: Kicker is below trough, so if a ball is in the 1005 ' exit chute, another ball can fall into the chute as well whether it came in from the 1006 ' exit (Slot Machine) or any other entrance (Piano, Camera). In both cases, the kicker 1007 ' will eject 2 balls at once. Set StackExitBalls = 2, maxBallsPerKick = 2 to simulate. 1008 1009 Public Property Let MaxBallsPerKick(n) : mMaxBallsPerKick = vpMax(1, n) : End Property 1010 Public Property Let StackExitBalls(n) : mStackExitBalls = vpMax(1, n) : End Property 1011 1012 Public Sub InitExit(aKicker, aDir, aForce) 1013 If TypeName(aKicker) <> "Kicker" Then 1014 Err.Raise 17, "cvpmTrough.InitExit: Cannot use object of type '" & TypeName(aKicker) & "'." 1015 End If 1016 1017 Set mExitKicker = aKicker 1018 mExitDir = aDir 1019 mExitForce = vpMax(1, aForce) 1020 End Sub 1021 1022 Public Sub InitExitVariance(aDirVar, aForceVar) 1023 mDirVar = aDirVar 1024 mForceVar = aForceVar 1025 End Sub 1026 1027 ' Setup sounds 1028 Public Sub InitEntrySounds(addSound, entrySoundEmpty, entrySoundBall) 1029 mSounds.Item("add") = addSound 1030 mSounds.Item("entry") = entrySoundEmpty 1031 mSounds.Item("entryBall") = entrySoundBall 1032 End Sub 1033 1034 Public Sub InitExitSounds(exitSoundEmpty, exitSoundBall) 1035 mSounds.Item("exit") = exitSoundEmpty 1036 mSounds.Item("exitBall") = exitSoundBall 1037 End Sub 1038 1039 ' Start trough with this many balls 1040 Public Property Let Balls(numBalls) 1041 Dim ii, ballsAdded 1042 1043 ' First clear all slots. 1044 For ii = 0 to UBound(mSlot) : mSlot(ii) = 0 : Next 1045 1046 ' Now put a ball in each even-numbered slot up to the number requested. 1047 ' First, stack exit slot. (Note, we may get a negative number. vpMin/vpMax prevent that.) 1048 mSlot(0) = vpMax(0, vpMin(mStackExitBalls, numBalls)) 1049 ballsAdded = mSlot(0) 1050 1051 ' Fill remaining slots. 1052 For ii = 1 to vpMin(numBalls - mSlot(0), UBound(mSw)) 1053 mSlot(ii*2) = 1 1054 ballsAdded = ballsAdded + 1 1055 Next 1056 1057 ' If we asked to put more balls in the trough than it can handle, queue up the rest. 1058 mBallsInEntry = vpMax(0, numBalls-ballsAdded) 1059 1060 UpdateTroughSwitches 1061 End Property 1062 1063 Public Property Get Balls 1064 Balls = 0 1065 Dim ii : For ii = 0 to UBound(mSlot) : Balls = Balls + mSlot(ii) : Next 1066 End Property 1067 1068 Public Property Get BallsPending : BallsPending = mBallsInEntry : End Property 1069 1070 ' Auto-generate events for any entry kickers (eg. outhole, TZ Camera and Piano, etc.) 1071 ' Accepts a single kicker, an Array, or a Collection. 1072 Public Sub CreateEvents(aName, aKicker) 1073 Dim obj, tmp 1074 If Not vpmCheckEvent(aName, Me) Then Exit Sub 1075 vpmSetArray tmp, aKicker 1076 For Each obj In tmp 1077 If isObject(obj) Then 1078 vpmBuildEvent obj, "Hit", aName & ".AddBall Me" 1079 Else 1080 vpmBuildEvent mKicker, "Hit", aName & ".AddBall Me" 1081 End If 1082 Next 1083 End Sub 1084 1085 ' VPM Update management 1086 1087 Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, False, aEnabled : End Property 1088 1089 Public Sub Reset 1090 Dim mEntrySwcopy 1091 UpdateTroughSwitches 1092 If mEntrySw Then 1093 mEntrySwcopy = mEntrySw 1094 Controller.Switch(mEntrySwcopy) = (mBallsInEntry > 0) 1095 End If 1096 End Sub 1097 1098 Public Sub Update 1099 NeedUpdate = AdvanceBalls 1100 UpdateTroughSwitches 1101 End Sub 1102 1103 ' Switch and slot management 1104 1105 Private Sub setSw(slotNo, enabled) 1106 Dim mSwcopy 1107 If mSw(slotNo) Then 1108 mSwcopy = mSw(slotNo) 1109 Controller.Switch(mSwcopy) = enabled 1110 End If 1111 End Sub 1112 1113 Private Sub UpdateTroughSwitches 1114 Dim ii, mSwcopy 1115 For ii = 0 to UBound(mSw) 1116 If mSw(ii) Then 1117 mSwcopy = mSw(ii) 1118 Controller.Switch(mSwcopy) = (mSlot(ii*2) > 0) 1119 End If 1120 Next 1121 If mDebug Then UpdateDebugBox 1122 End Sub 1123 1124 Private Sub UpdateDebugBox ' Requires a textbox named DebugBox 1125 Dim str, ii, mSwcopy 1126 str = "Entry: " & mBallsInEntry & " (sw" & mEntrySw & " = " 1127 If mEntrySw > 0 Then 1128 mSwcopy = mEntrySw 1129 str = str & Controller.Switch(mSwcopy) 1130 Else 1131 str = str & "n/a" 1132 End If 1133 str = str & ")" & vbNewLine 1134 1135 str = str & "[" 1136 For ii = UBound(mSlot) To 0 Step -1 : str = str & mSlot(ii) : Next 1137 str = str & "]" & vbNewLine 1138 1139 str = str & "[" 1140 For ii = UBound(mSlot) To 0 Step -1 1141 If ii Mod 2 = 0 Then 1142 If mSw(ii\2) Then 1143 mSwcopy = mSw(ii\2) 1144 If Controller.Switch(mSwcopy) Then 1145 str = str & "1" 1146 Else 1147 str = str & "0" 1148 End If 1149 Else 1150 str = str & "-" 1151 End If 1152 Else 1153 str = str & " " 1154 End If 1155 Next 1156 str = str & "]" 1157 1158 DebugBox.Text = str 1159 End Sub 1160 1161 Private Function AdvanceBalls 1162 Dim ii, canMove, maxSlot 1163 maxSlot = UBound(mSlot) 1164 AdvanceBalls = False 1165 1166 ' Move balls through slots, one slot at a time. 1167 For ii = 0 to maxSlot 1168 If mSlot(ii) Then ' Ball in this slot. 1169 canMove = False 1170 1171 ' Can this ball move? (Slot 0 = no) 1172 If ii = 0 Then 1173 ' Slot 0 never moves (except when ejected) 1174 canMove = False 1175 ElseIf ii = 1 Then 1176 ' Slot 1 automatically moves to Slot 0 1177 canMove = True 1178 ElseIf ii = 2 Then 1179 ' Slot 2 moves if the number of balls in slot 0 is less than the stack target. 1180 canMove = (mSlot(0) < mStackExitBalls) 1181 Else 1182 ' Only move if there is no ball in ii-1 or ii-2. 1183 canMove = (mSlot(ii-2) = 0) AND (mSlot(ii-1) = 0) 1184 End If 1185 1186 If canMove Then 1187 mSlot(ii) = mSlot(ii) - 1 1188 mSlot(ii-1) = mSlot(ii-1) + 1 1189 AdvanceBalls = True ' Mark balls as having moved. 1190 End If 1191 End If 1192 Next 1193 1194 ' If balls are supposed to fall into the trough without going through a kicker, 1195 ' see if any balls are pending and try to add one automatically if so. 1196 If mBallsInEntry > 0 AND mEntrySw <= 0 Then 1197 AdvanceBalls = AddBallAtEntrance OR AdvanceBalls 1198 End If 1199 End Function 1200 1201 ' Ball management 1202 1203 Private Function AddBallAtEntrance 1204 Dim mSwcopy 1205 Dim maxSlot : maxSlot = UBound(mSlot) 1206 AddBallAtEntrance = False 1207 1208 ' Only add a ball if there's room for it at the entrance. 1209 ' If the trough is full (or the entrance is occupied), the ball will remain 1210 ' in the entry queue. In a kicker-gated trough, the entry switch will remain 1211 ' pressed down, usually resulting in the machine retrying the load. In a fall-in 1212 ' trough, the ball will just remain queued until the entrance opens up. 1213 If mSlot(maxSlot) = 0 AND mSlot(maxSlot-1) = 0 Then 1214 mSlot(maxSlot) = 1 1215 mBallsInEntry = vpMax(0, mBallsInEntry - 1) 1216 If mBallsInEntry = 0 AND mEntrySw Then 1217 mSwcopy = mEntrySw 1218 Controller.Switch(mSwcopy) = False 1219 End If 1220 AddBallAtEntrance = True 1221 End If 1222 End Function 1223 1224 Public Sub AddBall(aKicker) 1225 Dim mSwcopy 1226 Dim addDone : addDone = False 1227 If IsObject(aKicker) Then 1228 aKicker.DestroyBall 1229 If aKicker Is mExitKicker Then 1230 ' Ball fell in from exit. Stack it up on Slot 0. 1231 mSlot(0) = mSlot(0) + 1 1232 NeedUpdate = True 1233 UpdateTroughSwitches 1234 addDone = True 1235 End If 1236 End If 1237 1238 If Not addDone Then 1239 ' Ball came in from entrance. Queue it up for entry. 1240 mBallsInEntry = mBallsInEntry + 1 1241 If mEntrySw > 0 Then 1242 mSwcopy = mEntrySw 1243 ' Trough has an entry kicker. Ball will not enter trough 1244 ' until the entry solenoid is fired. 1245 Controller.Switch(mSwcopy) = True 1246 End If 1247 NeedUpdate = True 1248 End If 1249 1250 PlaySound mSounds.Item("add") 1251 End Sub 1252 1253 ' Use solCallback(solNo) on the trough entry kicker solenoid. 1254 Public Sub solIn(aEnabled) 1255 If aEnabled Then 1256 If mBallsInEntry > 0 Then 1257 NeedUpdate = AddBallAtEntrance 1258 PlaySound mSounds.Item("entryBall") 1259 Else 1260 PlaySound mSounds.Item("entry") 1261 End If 1262 End If 1263 End Sub 1264 Public Sub EntrySol_On : solIn(true) : End Sub 1265 1266 ' Use solCallback(solNo) on the trough exit kicker solenoid. 1267 Public Sub solOut(aEnabled) 1268 Dim iiBall, kDir, kForce, kBaseDir, ballsEjected 1269 ballsEjected = 0 1270 1271 If aEnabled Then 1272 For iiBall = 0 to (mMaxBallsPerKick - 1) 1273 kDir = (mExitDir + (Rnd - 0.5) * mDirVar) 1274 kForce = vpMax(1, mExitForce + (Rnd - 0.5) * mForceVar * (0.8 * iiBall)) ' Dampen force a bit on subsequent balls. 1275 1276 If mSlot(0) > 0 Then 1277 ' Remove ball from this slot. 1278 mSlot(0) = mSlot(0) - 1 1279 If isObject(mExitKicker) Then 1280 vpmTimer.AddTimer ballsEjected*200, "vpmCreateBall(" & mExitKicker.Name & ").Kick " &_ 1281 CInt(kDir) & "," & Replace(kForce,",",".") & ", 0 '" 1282 End If 1283 1284 ballsEjected = ballsEjected + 1 1285 End If 1286 Next 1287 1288 If ballsEjected > 0 Then 1289 PlaySound mSounds.Item("exitBall") 1290 UpdateTroughSwitches 1291 NeedUpdate = True 1292 Else 1293 PlaySound mSounds.Item("exit") 1294 End If 1295 End If 1296 End Sub 1297 Public Sub ExitSol_On : solOut(true) : End Sub 1298End Class 1299 1300'-------------------- 1301' Saucer 1302'-------------------- 1303Class cvpmSaucer 1304 ' Takes over for older cvpmBallStack in "saucer mode". 1305 1306 Private mSw, mKicker, mExternalKicker 1307 Private mDir(1), mForce(1), mZForce(1), mDirVar, mForceVar 1308 Private mSounds 1309 1310 Private Sub Class_Initialize 1311 mSw = 0 1312 1313 mKicker = 0 1314 mExternalKicker = 0 1315 mDir(0) = 0 : mForce(0) = 1 : mZForce(0) = 0 1316 mDir(1) = 0 : mForce(1) = 1 : mZForce(1) = 0 1317 mDirVar = 0 : mForceVar = 0 1318 1319 Set mSounds = New cvpmDictionary 1320 End Sub 1321 1322 ' Initialization 1323 1324 Public Sub InitKicker(aKicker, aSw, aDir, aForce, aZForce) 1325 If TypeName(aKicker) <> "Kicker" Then 1326 Err.Raise 17, "cvpmSaucer.InitKicker: Cannot use object of type '" & TypeName(aKicker) & "'." 1327 End If 1328 1329 Set mKicker = aKicker 1330 mSw = aSw 1331 mDir(0) = aDir 1332 mForce(0) = vpMax(1, aForce) 1333 mZForce(0) = vpMax(0, aZForce) 1334 End Sub 1335 1336 Public Sub InitExitVariance(aDirVar, aForceVar) 1337 mDirVar = aDirVar 1338 mForceVar = aForceVar 1339 End Sub 1340 1341 ' Alternate kick params (simulates a saucer with two kickers) 1342 Public Sub InitAltKick(aDir, aForce, aZForce) 1343 mDir(1) = aDir 1344 mForce(1) = vpMax(1, aForce) 1345 mZForce(1) = vpMax(0, aZForce) 1346 End Sub 1347 1348 ' Setup sounds 1349 Public Sub InitSounds(addSound, exitSoundEmpty, exitSoundBall) 1350 mSounds.Item("add") = addSound 1351 mSounds.Item("exit") = exitSoundEmpty 1352 mSounds.Item("exitBall") = exitSoundBall 1353 End Sub 1354 1355 ' Generate hit event for the kicker(s) associated with this saucer. 1356 ' Accepts a single kicker, an Array, or a Collection. 1357 Public Sub CreateEvents(aName, aKicker) 1358 Dim obj, tmp 1359 If Not vpmCheckEvent(aName, Me) Then Exit Sub 1360 vpmSetArray tmp, aKicker 1361 For Each obj In tmp 1362 If isObject(obj) Then 1363 vpmBuildEvent obj, "Hit", aName & ".AddBall Me" 1364 Else 1365 vpmBuildEvent mKicker, "Hit", aName & ".AddBall Me" 1366 End If 1367 Next 1368 End Sub 1369 1370 ' Ball management 1371 1372 Public Sub AddBall(aKicker) 1373 Dim mSwcopy 1374 If isObject(aKicker) Then 1375 If aKicker Is mKicker Then 1376 mKicker.Enabled = False 1377 mExternalKicker = 0 1378 Else 1379 aKicker.Enabled = False 1380 Set mExternalKicker = aKicker 1381 End If 1382 Else 1383 mKicker.Enabled = False 1384 mExternalKicker = 0 1385 End If 1386 1387 If mSw Then 1388 mSwcopy = mSw 1389 Controller.Switch(mSwcopy) = True 1390 End If 1391 PlaySound mSounds.Item("add") 1392 End Sub 1393 1394 Public Property Get HasBall 1395 HasBall = False 1396 If IsObject(mExternalKicker) Then 1397 HasBall = True 1398 Else 1399 HasBall = Not mKicker.Enabled 1400 End If 1401 End Property 1402 1403 ' SolCallback solNo, "mySaucer.solOut" 1404 Public Sub solOut(aEnabled) : If aEnabled Then KickOut 0 : End If : End Sub 1405 Public Sub ExitSol_On : KickOut 0 : End Sub 1406 1407 ' SolCallback solNo, "mySaucer.solOutAlt" 1408 Public Sub solOutAlt(aEnabled) : If aEnabled Then KickOut 1 : End If : End Sub 1409 Public Sub ExitAltSol_On : KickOut 1 : End Sub 1410 1411 Private Sub KickOut(kickIndex) 1412 Dim mSwcopy 1413 If HasBall Then 1414 Dim kDir, kForce, kZForce 1415 1416 kDir = mDir(kickIndex) + (Rnd - 0.5)*mDirVar 1417 kForce = vpMax(1, mForce(kickIndex) + (Rnd - 0.5)*mForceVar) 1418 kZForce = mZForce(kickIndex) 1419 1420 If IsObject(mExternalKicker) Then 1421 ' Transfer ball to internal kicker and remove relationship 1422 vpmCreateBall mKicker 1423 mExternalKicker.DestroyBall 1424 mExternalKicker.Enabled = True 1425 Else 1426 mKicker.Enabled = True 1427 End If 1428 1429 mKicker.Kick kDir, kForce, kZForce 1430 If mSw Then 1431 mSwcopy = mSw 1432 Controller.Switch(mSwcopy) = False 1433 End If 1434 PlaySound mSounds.Item("exitBall") 1435 Else 1436 PlaySound mSounds.Item("exit") 1437 End If 1438 End Sub 1439End Class 1440 1441'-------------------- 1442' BallStack (DEPRECATED/LEGACY) 1443' Known issues: 1444' - Adding more balls than conMaxBalls will crash the script. 1445' - If there are more balls in trough than are ever used in a game (eg. Bride of Pinbot), 1446' one or more trough switches will be permanently stuck down and may result in a ROM test report. 1447' - Trough does not handle stacking balls at exit. 1448' - Saucer mode is essentially a hack on top of the trough logic. 1449'-------------------- 1450Class cvpmBallStack 1451 Private mSw(), mEntrySw, mBalls, mBallIn, mBallPos(), mSaucer, mBallsMoving 1452 Private mInitKicker, mExitKicker, mExitDir, mExitForce 1453 Private mExitDir2, mExitForce2 1454 Private mEntrySnd, mEntrySndBall, mExitSnd, mExitSndBall, mAddSnd 1455 Public KickZ, KickBalls, KickForceVar, KickAngleVar 1456 1457 Private Sub Class_Initialize 1458 ReDim mSw(conStackSw), mBallPos(conMaxBalls) 1459 mBallIn = 0 : mBalls = 0 : mExitKicker = 0 : mInitKicker = 0 : mBallsMoving = False 1460 KickBalls = 1 : mSaucer = False : mExitDir = 0 : mExitForce = 0 1461 mExitDir2 = 0 : mExitForce2 = 0 : KickZ = 0 : KickForceVar = 0 : KickAngleVar = 0 1462 mAddSnd = 0 : mEntrySnd = 0 : mEntrySndBall = 0 : mExitSnd = 0 : mExitSndBall = 0 1463 vpmTimer.AddResetObj Me 1464 End Sub 1465 1466 Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, False, aEnabled : End Property 1467 1468 Private Function SetSw(aNo, aStatus) 1469 Dim mSwcopy 1470 SetSw = False 1471 If HasSw(aNo) Then 1472 mSwcopy = mSw(aNo) 1473 Controller.Switch(mSwcopy) = aStatus 1474 SetSw = True 1475 End If 1476 End Function 1477 1478 Private Function HasSw(aNo) 1479 HasSw = False : If aNo <= conStackSw Then If mSw(aNo) Then HasSw = True 1480 End Function 1481 1482 Public Sub Reset 1483 Dim mSwcopy 1484 Dim ii : If mBalls Then For ii = 1 to mBalls : SetSw mBallPos(ii), True : Next 1485 If mEntrySw And mBallIn > 0 Then 1486 mSwcopy = mEntrySw 1487 Controller.Switch(mSwcopy) = True 1488 End If 1489 End Sub 1490 1491 Public Sub Update 1492 Dim BallQue, ii, mSwcopy 1493 NeedUpdate = False : BallQue = 1 1494 For ii = 1 To mBalls 1495 If mBallpos(ii) > BallQue Then ' next slot available 1496 NeedUpdate = True 1497 If HasSw(mBallPos(ii)) Then ' has switch 1498 mSwcopy = mSw(mBallPos(ii)) 1499 If Controller.Switch(mSwcopy) Then 1500 SetSw mBallPos(ii), False 1501 Else 1502 mBallPos(ii) = mBallPos(ii) - 1 1503 SetSw mBallPos(ii), True 1504 End If 1505 Else ' no switch. Move ball to first switch or occupied slot 1506 Do 1507 mBallPos(ii) = mBallPos(ii) - 1 1508 Loop Until SetSw(mBallPos(ii), True) Or mBallPos(ii) = BallQue 1509 End If 1510 End If 1511 BallQue = mBallPos(ii) + 1 1512 Next 1513 End Sub 1514 1515 Public Sub AddBall(aKicker) 1516 Dim mSwcopy 1517 If isObject(aKicker) Then 1518 If mSaucer Then 1519 If aKicker Is mExitKicker Then 1520 mExitKicker.Enabled = False : mInitKicker = 0 1521 Else 1522 aKicker.Enabled = False : Set mInitKicker = aKicker 1523 End If 1524 Else 1525 aKicker.DestroyBall 1526 End If 1527 ElseIf mSaucer Then 1528 mExitKicker.Enabled = False : mInitKicker = 0 1529 End If 1530 If mEntrySw Then 1531 mSwcopy = mEntrySw 1532 Controller.Switch(mSwcopy) = True : mBallIn = mBallIn + 1 1533 Else 1534 mBalls = mBalls + 1 : mBallPos(mBalls) = conStackSw + 1 : NeedUpdate = True 1535 End If 1536 PlaySound mAddSnd 1537 End Sub 1538 1539 ' A bug in the script engine forces the "End If" at the end 1540 Public Sub SolIn(aEnabled) : If aEnabled Then KickIn : End If : End Sub 1541 Public Sub SolOut(aEnabled) : If aEnabled Then KickOut False : End If : End Sub 1542 Public Sub SolOutAlt(aEnabled) : If aEnabled Then KickOut True : End If : End Sub 1543 Public Sub EntrySol_On : KickIn : End Sub 1544 Public Sub ExitSol_On : KickOut False : End Sub 1545 Public Sub ExitAltSol_On : KickOut True : End Sub 1546 1547 Private Sub KickIn 1548 Dim mSwcopy 1549 If mBallIn Then PlaySound mEntrySndBall Else PlaySound mEntrySnd : Exit Sub 1550 mBalls = mBalls + 1 : mBallIn = mBallIn - 1 : mBallPos(mBalls) = conStackSw + 1 : NeedUpdate = True 1551 If mEntrySw And mBallIn = 0 Then 1552 mSwcopy = mEntrySw 1553 Controller.Switch(mSwcopy) = False 1554 End If 1555 End Sub 1556 1557 Private Sub KickOut(aAltSol) 1558 Dim ii,jj, kForce, kDir, kBaseDir 1559 If mBalls Then PlaySound mExitSndBall Else PlaySound mExitSnd : Exit Sub 1560 If aAltSol Then kForce = mExitForce2 : kBaseDir = mExitDir2 Else kForce = mExitForce : kBaseDir = mExitDir 1561 kForce = kForce + (Rnd - 0.5)*KickForceVar 1562 If mSaucer Then 1563 SetSw 1, False : mBalls = 0 : kDir = kBaseDir + (Rnd - 0.5)*KickAngleVar 1564 If isObject(mInitKicker) Then 1565 vpmCreateBall mExitKicker : mInitKicker.Destroyball : mInitKicker.Enabled = True 1566 Else 1567 mExitKicker.Enabled = True 1568 End If 1569 mExitKicker.Kick kDir, kForce, KickZ 1570 Else 1571 For ii = 1 To kickballs 1572 If mBalls = 0 Or mBallPos(1) <> ii Then Exit For ' No more balls 1573 For jj = 2 To mBalls ' Move balls in array 1574 mBallPos(jj-1) = mBallPos(jj) 1575 Next 1576 mBallPos(mBalls) = 0 : mBalls = mBalls - 1 : NeedUpdate = True 1577 SetSw ii, False 1578 If isObject(mExitKicker) Then 1579 If kForce < 1 Then kForce = 1 1580 kDir = kBaseDir + (Rnd - 0.5)*KickAngleVar 1581 vpmTimer.AddTimer (ii-1)*200, "vpmCreateBall(" & mExitKicker.Name & ").Kick " &_ 1582 CInt(kDir) & "," & Replace(kForce,",",".") & "," & Replace(KickZ,",",".") & " '" 1583 End If 1584 kForce = kForce * 0.8 1585 Next 1586 End If 1587 End Sub 1588 1589 Public Sub InitSaucer(aKicker, aSw, aDir, aPower) 1590 InitKick aKicker, aDir, aPower : mSaucer = True 1591 If aSw Then mSw(1) = aSw Else mSw(1) = aKicker.TimerInterval 1592 End Sub 1593 1594 Public Sub InitNoTrough(aKicker, aSw, aDir, aPower) 1595 InitKick aKicker, aDir, aPower : Balls = 1 1596 If aSw Then mSw(1) = aSw Else mSw(1) = aKicker.TimerInterval 1597 If Not IsObject(vpmTrough) Then Set vpmTrough = Me 1598 End Sub 1599 1600 Public Sub InitSw(aEntry, aSw1, aSw2, aSw3, aSw4, aSw5, aSw6, aSw7) 1601 mEntrySw = aEntry : mSw(1) = aSw1 : mSw(2) = aSw2 : mSw(3) = aSw3 : mSw(4) = aSw4 1602 mSw(5) = aSw5 : mSw(6) = aSw6 : mSw(7) = aSw7 : mSw(8) = 0 1603 If Not IsObject(vpmTrough) Then Set vpmTrough = Me 1604 End Sub 1605 1606 Public Sub InitSw8(aEntry, aSw1, aSw2, aSw3, aSw4, aSw5, aSw6, aSw7, aSw8) 1607 mEntrySw = aEntry : mSw(1) = aSw1 : mSw(2) = aSw2 : mSw(3) = aSw3 : mSw(4) = aSw4 1608 mSw(5) = aSw5 : mSw(6) = aSw6 : mSw(7) = aSw7 : mSw(8) = aSw8 1609 If Not IsObject(vpmTrough) Then Set vpmTrough = Me 1610 End Sub 1611 1612 Public Sub InitKick(aKicker, aDir, aForce) 1613 Set mExitKicker = aKicker : mExitDir = aDir : mExitForce = aForce 1614 End Sub 1615 1616 Public Sub CreateEvents(aName, aKicker) 1617 Dim obj, tmp 1618 If Not vpmCheckEvent(aName, Me) Then Exit Sub 1619 vpmSetArray tmp, aKicker 1620 For Each obj In tmp 1621 If isObject(obj) Then 1622 vpmBuildEvent obj, "Hit", aName & ".AddBall Me" 1623 Else 1624 vpmBuildEvent mExitKicker, "Hit", aName & ".AddBall Me" 1625 End If 1626 Next 1627 End Sub 1628 1629 Public Property Let IsTrough(aIsTrough) 1630 If aIsTrough Then 1631 Set vpmTrough = Me 1632 ElseIf IsObject(vpmTrough) Then 1633 If vpmTrough Is Me Then vpmTrough = 0 1634 End If 1635 End Property 1636 1637 Public Property Get IsTrough : IsTrough = vpmTrough Is Me : End Property 1638 1639 Public Sub InitAltKick(aDir, aForce) 1640 mExitDir2 = aDir : mExitForce2 = aForce 1641 End Sub 1642 1643 Public Sub InitEntrySnd(aBall, aNoBall) : mEntrySndBall = aBall : mEntrySnd = aNoBall : End Sub 1644 Public Sub InitExitSnd(aBall, aNoBall) : mExitSndBall = aBall : mExitSnd = aNoBall : End Sub 1645 Public Sub InitAddSnd(aSnd) : mAddSnd = aSnd : End Sub 1646 1647 Public Property Let Balls(aBalls) 1648 Dim ii 1649 For ii = 1 To conStackSw 1650 SetSw ii, False : mBallPos(ii) = conStackSw + 1 1651 Next 1652 If mSaucer And aBalls > 0 And mBalls = 0 Then vpmCreateBall mExitKicker 1653 mBalls = aBalls : NeedUpdate = True 1654 End Property 1655 1656 Public Default Property Get Balls : Balls = mBalls : End Property 1657 Public Property Get BallsPending : BallsPending = mBallIn : End Property 1658 1659 ' Obsolete stuff 1660 Public Sub SolEntry(aSnd1, aSnd2, aEnabled) 1661 If aEnabled Then mEntrySndBall = aSnd1 : mEntrySnd = aSnd2 : KickIn 1662 End Sub 1663 Public Sub SolExit(aSnd1, aSnd2, aEnabled) 1664 If aEnabled Then mExitSndBall = aSnd1 : mExitSnd = aSnd2 : KickOut False 1665 End Sub 1666 Public Sub InitProxy(aProxyPos, aSwNo) : End Sub 1667 Public TempBallColour, TempBallImage, BallColour 1668 Public Property Let BallImage(aImage) : vpmBallImage = aImage : End Property 1669End Class 1670 1671'-------------------- 1672' Nudge 1673'-------------------- 1674class cvpmNudge 1675 Private mCount, mSensitivity, mNudgeTimer, mSlingBump, mForce 1676 Public TiltSwitch 1677 1678 Private Sub Class_Initialize 1679 mCount = 0 : TiltSwitch = 0 : mSensitivity = 5 : vpmTimer.AddResetObj Me 1680 End sub 1681 1682 Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, False, aEnabled : End Property 1683 1684 Public Property Let TiltObj(aSlingBump) 1685 Dim ii 1686 ReDim mForce(vpmSetArray(mSlingBump, aSlingBump)) 1687 For ii = 0 To UBound(mForce) 1688 If TypeName(mSlingBump(ii)) = "Bumper" Then mForce(ii) = mSlingBump(ii).Threshold 1689 If vpmVPVer >= 90 and TypeName(mSlingBump(ii)) = "Wall" Then mForce(ii) = mSlingBump(ii).SlingshotThreshold 1690 Next 1691 End Property 1692 1693 Public Property Let Sensitivity(aSens) : mSensitivity = (10-aSens)+1 : End property 1694 1695 Public Sub DoNudge(ByVal aDir, ByVal aForce) 1696 aDir = aDir + (Rnd-0.5)*15*aForce : aForce = (0.6+Rnd*0.8)*aForce 1697 Nudge aDir, aForce 1698 If TiltSwitch = 0 Then Exit Sub ' If no switch why care 1699 mCount = mCount + aForce * 1.2 1700 If mCount > mSensitivity + 10 Then mCount = mSensitivity + 10 1701 If mCount >= mSensitivity Then vpmTimer.PulseSw TiltSwitch 1702 NeedUpdate = True 1703 End sub 1704 1705 Public Sub Update 1706 If mCount > 0 Then 1707 mNudgeTimer = mNudgeTimer + 1 1708 If mNudgeTimer > 1000\conTimerPulse Then 1709 If mCount > mSensitivity+1 Then mCount = mCount - 1 : vpmTimer.PulseSw TiltSwitch 1710 mCount = mCount - 1 : mNudgeTimer = 0 1711 End If 1712 Else 1713 mCount = 0 : NeedUpdate = False 1714 End If 1715 End Sub 1716 1717 Public Sub Reset : mCount = 0 : End Sub 1718 1719 Public Sub SolGameOn(aEnabled) 1720 if IsEmpty(mForce) then exit sub 'prevent errors if vpmNudge.TiltObj isn't set 1721 Dim obj, ii 1722 If aEnabled Then 1723 ii = 0 1724 For Each obj In mSlingBump 1725 If TypeName(obj) = "Bumper" Then obj.Threshold = mForce(ii) 1726 If vpmVPVer >= 90 and TypeName(obj) = "Wall" Then obj.SlingshotThreshold = mForce(ii) 1727 ii = ii + 1 1728 Next 1729 Else 1730 For Each obj In mSlingBump 1731 If TypeName(obj) = "Bumper" Then obj.Threshold = 100 1732 If vpmVPVer >= 90 and TypeName(obj) = "Wall" Then obj.SlingshotThreshold = 100 1733 Next 1734 End If 1735 End Sub 1736End Class 1737 1738'-------------------- 1739' DropTarget 1740'-------------------- 1741Class cvpmDropTarget 1742 Private mDropObj, mDropSw(), mDropSnd, mRaiseSnd, mSwAnyUp, mSwAllDn, mAllDn, mLink 1743 1744 Private Sub Class_Initialize 1745 mDropSnd = 0 : mRaiseSnd = 0 : mSwAnyUp = 0 : mSwAllDn = 0 : mAllDn = False : mLink = Empty 1746 End sub 1747 1748 Private Sub CheckAllDn(ByVal aStatus) 1749 Dim obj 1750 If Not IsEmpty(mLink) Then 1751 If aStatus Then 1752 For Each obj In mLink : aStatus = aStatus And obj.AllDown : Next 1753 End If 1754 For Each obj In mLink: obj.SetAllDn aStatus : Next 1755 End If 1756 SetAllDn aStatus 1757 End Sub 1758 1759 Public Sub SetAllDn(aStatus) 1760 Dim mSwcopy 1761 If mSwAllDn Then 1762 mSwcopy = mSwAllDn 1763 Controller.Switch(mSwcopy) = aStatus 1764 End If 1765 If mSwAnyUp Then 1766 mSwcopy = mSwAnyUp 1767 Controller.Switch(mSwcopy) = Not aStatus 1768 End If 1769 End Sub 1770 1771 Public Sub InitDrop(aWalls, aSw) 1772 Dim obj, obj2, ii 1773 ' Fill in switch number 1774 On Error Resume Next : ReDim mDropSw(0) 1775 If IsArray(aSw) Then 1776 ReDim mDropSw(UBound(aSw)) 1777 For ii = 0 To UBound(aSw) : mDropSw(ii) = aSw(ii) : Next 1778 ElseIf aSw = 0 Or Err Then 1779 On Error Goto 0 1780 If vpmIsArray(aWalls) Then 1781 ii = 0 : If IsArray(aWalls) Then ReDim mDropSw(UBound(aWalls)) Else ReDim mDropSw(aWalls.Count-1) 1782 For Each obj In aWalls 1783 If vpmIsArray(obj) Then 1784 For Each obj2 In obj 1785 If obj2.HasHitEvent Then mDropSw(ii) = obj2.TimerInterval : Exit For 1786 Next 1787 Else 1788 mDropSw(ii) = obj.TimerInterval 1789 End If 1790 ii = ii + 1 1791 Next 1792 Else 1793 mDropSw(0) = aWalls.TimerInterval 1794 End If 1795 Else 1796 mDropSw(0) = aSw 1797 End If 1798 ' Copy walls 1799 vpmSetArray mDropObj, aWalls 1800 End Sub 1801 1802 Public Sub CreateEvents(aName) 1803 Dim ii, obj1, obj2 1804 If Not vpmCheckEvent(aName, Me) Then Exit Sub 1805 ii = 1 1806 For Each obj1 In mDropObj 1807 If vpmIsArray(obj1) Then 1808 For Each obj2 In obj1 1809 if TypeName(obj2) = "HitTarget" Then 'if object in array is a Target, use .Dropped 1810 vpmBuildEvent obj2, "Dropped", aName & ".Hit " & ii 'Droptarget_Dropped : DTbank.Hit 1 : End Sub 1811 else 1812 If obj2.HasHitEvent Then vpmBuildEvent obj2, "Hit", aName & ".Hit " & ii 1813 End If 1814 Next 1815 Else 1816 if TypeName(obj1) = "HitTarget" Then 'if object in array is a Target, use .Dropped 1817 vpmBuildEvent obj1, "Dropped", aName & ".Hit " & ii 1818 else 1819 vpmBuildEvent obj1, "Hit", aName & ".Hit " & ii 1820 End If 1821 End If 1822 ii = ii + 1 1823 Next 1824 End Sub 1825 1826 Public Property Let AnyUpSw(aSwAnyUp) 1827 Dim mSwcopy 1828 mSwAnyUp = aSwAnyUp 1829 mSwcopy = mSwAnyUp 1830 Controller.Switch(mSwcopy) = True 1831 End Property 1832 Public Property Let AllDownSw(aSwAllDn) : mSwAllDn = aSwAllDn : End Property 1833 Public Property Get AllDown : AllDown = mAllDn : End Property 1834 Public Sub InitSnd(aDrop, aRaise) : mDropSnd = aDrop : mRaiseSnd = aRaise : End Sub 1835 Public Property Let LinkedTo(aLink) 1836 If IsArray(aLink) Then mLink = aLink Else mLink = Array(aLink) 1837 End Property 1838 1839 Public Sub Hit(aNo) 1840 Dim ii, mSwcopy 1841 vpmSolWall mDropObj(aNo-1), mDropSnd, True 1842 mSwcopy = mDropSw(aNo-1) 1843 Controller.Switch(mSwcopy) = True 1844 For Each ii In mDropSw 1845 mSwcopy = ii 1846 If Not Controller.Switch(mSwcopy) Then Exit Sub 1847 Next 1848 mAllDn = True : CheckAllDn True 1849 End Sub 1850 1851 Public Sub SolHit(aNo, aEnabled) : If aEnabled Then Hit aNo : End If : End Sub 1852 1853 Public Sub SolUnhit(aNo, aEnabled) 1854 Dim mSwcopy 1855 Dim ii : If Not aEnabled Then Exit Sub 1856 PlaySound mRaiseSnd : vpmSolWall mDropObj(aNo-1), False, False 1857 mSwcopy = mDropSw(aNo-1) 1858 Controller.Switch(mSwcopy) = False 1859 mAllDn = False : CheckAllDn False 1860 End Sub 1861 1862 Public Sub SolDropDown(aEnabled) 1863 Dim mSwcopy 1864 Dim ii : If Not aEnabled Then Exit Sub 1865 PlaySound mDropSnd 1866 For Each ii In mDropObj : vpmSolWall ii, False, True : Next 1867 For Each ii In mDropSw : mSwcopy = ii : Controller.Switch(mSwcopy) = True : Next 1868 mAllDn = True : CheckAllDn True 1869 End Sub 1870 1871 Public Sub SolDropUp(aEnabled) 1872 Dim mSwcopy 1873 Dim ii : If Not aEnabled Then Exit Sub 1874 PlaySound mRaiseSnd 1875 For Each ii In mDropObj : vpmSolWall ii, False, False : Next 1876 For Each ii In mDropSw : mSwcopy = ii : Controller.Switch(mSwcopy) = False : Next 1877 mAllDn = False : CheckAllDn False 1878 End Sub 1879 1880 Public Sub DropSol_On : SolDropUp True : End Sub 1881End Class 1882 1883'-------------------- 1884' Magnet 1885'-------------------- 1886Class cvpmMagnet 1887 Private mEnabled, mBalls, mTrigger 1888 Public X, Y, Strength, Size, GrabCenter, Solenoid 1889 1890 Private Sub Class_Initialize 1891 Size = 1 : Strength = 0 : Solenoid = 0 : mEnabled = False 1892 Set mBalls = New cvpmDictionary 1893 End Sub 1894 1895 Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, True, aEnabled : End Property 1896 1897 Public Sub InitMagnet(aTrigger, aStrength) 1898 Dim tmp 1899 If vpmIsArray(aTrigger) Then Set tmp = aTrigger(0) Else Set tmp = aTrigger 1900 X = tmp.X : Y = tmp.Y : Size = tmp.Radius : vpmTimer.InitTimer tmp, True 1901 If IsArray(aTrigger) Then mTrigger = aTrigger Else Set mTrigger = aTrigger 1902 Strength = aStrength : GrabCenter = aStrength > 14 1903 End Sub 1904 1905 Public Sub CreateEvents(aName) 1906 If vpmCheckEvent(aName, Me) Then 1907 vpmBuildEvent mTrigger, "Hit", aName & ".AddBall ActiveBall" 1908 vpmBuildEvent mTrigger, "UnHit", aName & ".RemoveBall ActiveBall" 1909 End If 1910 End Sub 1911 1912 Public Property Let MagnetOn(aEnabled) : mEnabled = aEnabled : End Property 1913 Public Property Get MagnetOn 1914 If Solenoid > 0 Then MagnetOn = Controller.Solenoid(Solenoid) Else MagnetOn = mEnabled 1915 End Property 1916 1917 Public Sub AddBall(aBall) 1918 With mBalls 1919 If .Exists(aBall) Then .Item(aBall) = .Item(aBall) + 1 Else .Add aBall, 1 : NeedUpdate = True 1920 End With 1921 End Sub 1922 1923 Public Sub RemoveBall(aBall) 1924 With mBalls 1925 If .Exists(aBall) Then .Item(aBall) = .Item(aBall) - 1 : If .Item(aBall) <= 0 Then .Remove aBall 1926 NeedUpdate = (.Count > 0) 1927 End With 1928 End Sub 1929 1930 Public Property Get Balls : Balls = mBalls.Keys : End Property 1931 1932 Public Sub Update 1933 Dim obj 1934 If MagnetOn Then 1935 On Error Resume Next 1936 For Each obj In mBalls.Keys 1937 If obj.X < 0 Or Err Then mBalls.Remove obj Else AttractBall obj 1938 Next 1939 On Error Goto 0 1940 End If 1941 End Sub 1942 1943 Public Sub AttractBall(aBall) 1944 Dim dX, dY, dist, force, ratio 1945 dX = aBall.X - X : dY = aBall.Y - Y : dist = Sqr(dX*dX + dY*dY) 1946 If dist > Size Or dist < 1 Then Exit Sub 'Just to be safe 1947 If GrabCenter And dist < 20 Then 1948 aBall.VelX = 0 : aBall.VelY = 0 : aBall.X = X : aBall.Y = Y 1949 Else 1950 ratio = dist / (1.5*Size) 1951 force = Strength * exp(-0.2/ratio)/(ratio*ratio*56) * 1.5 1952 aBall.VelX = (aBall.VelX - dX * force / dist) * 0.985 1953 aBall.VelY = (aBall.VelY - dY * force / dist) * 0.985 1954 End if 1955 End Sub 1956 ' obsolete 1957 Public Property Let Range(aSize) : Size = aSize : End Property 1958 Public Property Get Range : Range = Size : End Property 1959End Class 1960 1961'-------------------- 1962' Turntable 1963'-------------------- 1964Class cvpmTurntable 1965 Private mX, mY, mSize, mTrigger, mBalls, mSpinUp, mSpinDown 1966 Private mMotorOn, mSpinCW 1967 Private mMaxSpeed, mTargetSpeed, mCurrentAccel 1968 Public Speed 1969 1970 Private Sub Class_Initialize 1971 Set mBalls = New cvpmDictionary 1972 mMotorOn = False : mSpinCW = True : Speed = 0 : mSpinUp = 10 : mSpinDown = 4 1973 AdjustTargets 1974 End Sub 1975 1976 Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, True, aEnabled : End Property 1977 1978 Public Sub InitTurntable(aTrigger, aMaxSpeed) 1979 mX = aTrigger.X : mY = aTrigger.Y : mSize = aTrigger.Radius : vpmTimer.InitTimer aTrigger, True 1980 mMaxSpeed = aMaxSpeed : Set mTrigger = aTrigger 1981 AdjustTargets 1982 End Sub 1983 1984 Public Sub CreateEvents(aName) 1985 If vpmCheckEvent(aName, Me) Then 1986 vpmBuildEvent mTrigger, "Hit", aName & ".AddBall ActiveBall" 1987 vpmBuildEvent mTrigger, "UnHit", aName & ".RemoveBall ActiveBall" 1988 End If 1989 End Sub 1990 1991 Public Sub SolMotorState(aCW, aMotorOn) 1992 mSpinCW = aCW 1993 mMotorOn = aMotorOn 1994 AdjustTargets 1995 End Sub 1996 1997 Private Sub AdjustTargets 1998 If mMotorOn Then 1999 mTargetSpeed = MaxSpeed 2000 mCurrentAccel = SpinUp 2001 If Not mSpinCW Then mTargetSpeed = -MaxSpeed 2002 Else 2003 mTargetSpeed = 0 2004 mCurrentAccel = SpinDown 2005 End If 2006 2007 NeedUpdate = mBalls.Count Or SpinUp Or SpinDown 2008 End Sub 2009 2010 Public Property Let MaxSpeed(newSpeed) : mMaxSpeed = newSpeed : AdjustTargets : End Property 2011 Public Property Let SpinUp(newRate) : mSpinUp = newRate : AdjustTargets : End Property 2012 Public Property Let SpinDown(newRate) : mSpinDown = newRate : AdjustTargets : End Property 2013 2014 Public Property Get MaxSpeed : MaxSpeed = mMaxSpeed : End Property 2015 Public Property Get SpinUp : SpinUp = mSpinup : End Property 2016 Public Property Get SpinDown : SpinDown = mSpinDown : End Property 2017 2018 Public Property Let MotorOn(aEnabled) : SolMotorState mSpinCW, aEnabled : End Property 2019 Public Property Let SpinCW(aCW) : SolMotorState aCW, mMotorOn : End Property 2020 2021 Public Property Get MotorOn : MotorOn = mMotorOn : End Property 2022 Public Property Get SpinCW : SpinCW = mSpinCW : End Property 2023 2024 Public Sub AddBall(aBall) 2025 On Error Resume Next : mBalls.Add aBall,0 : NeedUpdate = True 2026 End Sub 2027 Public Sub RemoveBall(aBall) 2028 On Error Resume Next 2029 mBalls.Remove aBall : NeedUpdate = mBalls.Count Or SpinUp Or SpinDown 2030 End Sub 2031 Public Property Get Balls : Balls = mBalls.Keys : End Property 2032 2033 Public Sub Update 2034 If Speed > mTargetSpeed Then 2035 Speed = Speed - mCurrentAccel/100 2036 If Speed < mTargetSpeed Then Speed = mTargetSpeed : NeedUpdate = mBalls.Count 2037 ElseIf Speed < mTargetSpeed Then 2038 Speed = Speed + mCurrentAccel/100 2039 If Speed > mTargetSpeed Then Speed = mTargetSpeed : NeedUpdate = mBalls.Count 2040 End If 2041 2042 If Speed Then 2043 Dim obj 2044 On Error Resume Next 2045 For Each obj In mBalls.Keys 2046 If obj.X < 0 Or Err Then mBalls.Remove obj Else AffectBall obj 2047 Next 2048 On Error Goto 0 2049 End If 2050 End Sub 2051 2052 Public Sub AffectBall(aBall) 2053 Dim dX, dY, dist 2054 dX = aBall.X - mX : dY = aBall.Y - mY : dist = Sqr(dX*dX + dY*dY) 2055 If dist > mSize Or dist < 1 Or Speed = 0 Then Exit Sub 2056 aBall.VelX = aBall.VelX - (dY * Speed / 8000) 2057 aBall.VelY = aBall.VelY + (dX * Speed / 8000) 2058 End Sub 2059End Class 2060 2061'-------------------- 2062' Mech 2063'-------------------- 2064Const vpmMechLinear = &H00 2065Const vpmMechNonLinear = &H01 2066Const vpmMechCircle = &H00 2067Const vpmMechStopEnd = &H02 2068Const vpmMechReverse = &H04 2069Const vpmMechOneSol = &H00 2070Const vpmMechOneDirSol = &H10 2071Const vpmMechTwoDirSol = &H20 2072Const vpmMechStepSol = &H40 2073Const vpmMechSlow = &H00 2074Const vpmMechFast = &H80 2075Const vpmMechStepSw = &H00 2076Const vpmMechLengthSw = &H100 2077 2078Class cvpmMech 2079 Public Sol1, Sol2, MType, Length, Steps, Acc, Ret 2080 Private mMechNo, mNextSw, mSw(), mLastPos, mLastSpeed, mCallback 2081 2082 Private Sub Class_Initialize 2083 ReDim mSw(10) 2084 gNextMechNo = gNextMechNo + 1 : mMechNo = gNextMechNo : mNextSw = 0 : mLastPos = 0 : mLastSpeed = 0 2085 MType = 0 : Length = 0 : Steps = 0 : Acc = 0 : Ret = 0 : vpmTimer.addResetObj Me 2086 End Sub 2087 2088 Public Sub AddSw(aSwNo, aStart, aEnd) 2089 mSw(mNextSw) = Array(aSwNo, aStart, aEnd, 0) 2090 mNextSw = mNextSw + 1 2091 End Sub 2092 2093 Public Sub AddPulseSwNew(aSwNo, aInterval, aStart, aEnd) 2094 If Controller.Version >= "01200000" Then 2095 mSw(mNextSw) = Array(aSwNo, aStart, aEnd, aInterval) 2096 Else 2097 mSw(mNextSw) = Array(aSwNo, -aInterval, aEnd - aStart + 1, 0) 2098 End If 2099 mNextSw = mNextSw + 1 2100 End Sub 2101 2102 Public Sub Start 2103 Dim sw, ii 2104 With Controller 2105 .Mech(1) = Sol1 : .Mech(2) = Sol2 : .Mech(3) = Length 2106 .Mech(4) = Steps : .Mech(5) = MType : .Mech(6) = Acc : .Mech(7) = Ret 2107 ii = 10 2108 For Each sw In mSw 2109 If IsArray(sw) Then 2110 .Mech(ii) = sw(0) : .Mech(ii+1) = sw(1) 2111 .Mech(ii+2) = sw(2) : .Mech(ii+3) = sw(3) 2112 ii = ii + 10 2113 End If 2114 Next 2115 .Mech(0) = mMechNo 2116 End With 2117 If IsObject(mCallback) Then mCallBack 0, 0, 0 : mLastPos = 0 : vpmTimer.EnableUpdate Me, False, True 2118 End Sub 2119 2120 Public Property Get Position : Position = Controller.GetMech(mMechNo) : End Property 2121 Public Property Get Speed : Speed = Controller.GetMech(-mMechNo) : End Property 2122 Public Property Let Callback(aCallBack) : Set mCallback = aCallBack : End Property 2123 2124 Public Sub Update 2125 Dim currPos, speed 2126 currPos = Controller.GetMech(mMechNo) 2127 speed = Controller.GetMech(-mMechNo) 2128 If currPos < 0 Or (mLastPos = currPos And mLastSpeed = speed) Then Exit Sub 2129 mCallBack currPos, speed, mLastPos : mLastPos = currPos : mLastSpeed = speed 2130 End Sub 2131 2132 Public Sub Reset : Start : End Sub 2133 ' Obsolete 2134 Public Sub AddPulseSw(aSwNo, aInterval, aLength) : AddSw aSwNo, -aInterval, aLength : End Sub 2135End Class 2136 2137'-------------------- 2138' Captive Ball 2139'-------------------- 2140Class cvpmCaptiveBall 2141 Private mBallKicked, mBallDir, mBallCos, mBallSin, mTrigHit 2142 Private mTrig, mWall, mKickers, mVelX, mVelY, mKickNo 2143 Public ForceTrans, MinForce, RestSwitch, NailedBalls 2144 2145 Private Sub Class_Initialize 2146 mBallKicked = False : ForceTrans = 0.5 : mTrigHit = False : MinForce = 3 : NailedBalls = 0 2147 vpmTimer.addResetObj Me 2148 End Sub 2149 2150 Public Sub InitCaptive(aTrig, aWall, aKickers, aBallDir) 2151 Set mTrig = aTrig : Set mWall = aWall 2152 mKickNo = vpmSetArray(mKickers, aKickers) 2153 mBallDir = aBallDir : mBallCos = Cos(aBallDir * 3.1415927/180) : mBallSin = Sin(aBallDir * 3.1415927/180) 2154 End Sub 2155 2156 Public Sub Start 2157 Dim mSwcopy 2158 vpmCreateBall mKickers(mKickNo + (mKickNo <> NailedBalls)) 2159 If RestSwitch Then 2160 mSwcopy = RestSwitch 2161 Controller.Switch(mSwcopy) = True 2162 End If 2163 End Sub 2164 2165 Public Sub TrigHit(aBall) 2166 mTrigHit = IsObject(aBall) : If mTrigHit Then mVelX = aBall.VelX : mVelY = aBall.VelY 2167 End Sub 2168 2169 Public Sub Reset 2170 Dim mSwcopy 2171 If RestSwitch Then 2172 mSwcopy = RestSwitch 2173 Controller.Switch(mSwcopy) = True 2174 End If 2175 End Sub 2176 2177 Public Sub BallHit(aBall) 2178 Dim dX, dY, force, mSwcopy 2179 If mBallKicked Then Exit Sub ' Ball is not here 2180 If mTrigHit Then mTrigHit = False Else mVelX = aBall.VelX : mVelY = aBall.VelY 2181 dX = aBall.X - mKickers(0).X : dY = aBall.Y - mKickers(0).Y 2182 force = -ForceTrans * (dY * mVelY + dX * mVelX) * (dY * mBallCos + dX * mBallSin) / (dX*dX + dY*dY) 2183 If force < 1 Then Exit Sub 2184 If force < MinForce Then force = MinForce 2185 If mKickNo <> NailedBalls Then 2186 vpmCreateBall mKickers(mKickNo) 2187 mKickers(mKickNo-1).DestroyBall 2188 End If 2189 mKickers(mKickNo).Kick mBallDir, force : mBallKicked = True 2190 If RestSwitch Then 2191 mSwcopy = RestSwitch 2192 Controller.Switch(mSwcopy) = False 2193 End If 2194 End Sub 2195 2196 Public Sub BallReturn(aKicker) 2197 Dim mSwcopy 2198 If mKickNo <> NailedBalls Then vpmCreateBall mKickers(mKickNo-1) : aKicker.DestroyBall 2199 mBallKicked = False 2200 If RestSwitch Then 2201 mSwcopy = RestSwitch 2202 Controller.Switch(mSwcopy) = True 2203 End If 2204 End Sub 2205 2206 Public Sub CreateEvents(aName) 2207 If vpmCheckEvent(aName, Me) Then 2208 If Not mTrig Is Nothing Then 2209 vpmBuildEvent mTrig, "Hit", aName & ".TrigHit ActiveBall" 2210 vpmBuildEvent mTrig, "UnHit", aName & ".TrigHit 0" 2211 End If 2212 vpmBuildEvent mWall, "Hit", aName & ".BallHit ActiveBall" 2213 vpmBuildEvent mKickers(mKickNo), "Hit", aName & ".BallReturn Me" 2214 End If 2215 End Sub 2216 ' Obsolete 2217 Public BallImage, BallColour 2218End Class 2219 2220'-------------------- 2221' Visible Locks 2222'-------------------- 2223Class cvpmVLock 2224 Private mTrig, mKick, mSw(), mSize, mBalls, mGateOpen, mRealForce, mBallSnd, mNoBallSnd 2225 Public ExitDir, ExitForce, KickForceVar 2226 2227 Private Sub Class_Initialize 2228 mBalls = 0 : ExitDir = 0 : ExitForce = 0 : KickForceVar = 0 : mGateOpen = False 2229 vpmTimer.addResetObj Me 2230 End Sub 2231 2232 Public Sub InitVLock(aTrig, aKick, aSw) 2233 Dim ii 2234 mSize = vpmSetArray(mTrig, aTrig) 2235 If vpmSetArray(mKick, aKick) <> mSize Then MsgBox "cvpmVLock: Unmatched kick+trig" : Exit Sub 2236 On Error Resume Next 2237 ReDim mSw(mSize) 2238 If IsArray(aSw) Then 2239 For ii = 0 To UBound(aSw) : mSw(ii) = aSw(ii) : Next 2240 ElseIf aSw = 0 Or Err Then 2241 For ii = 0 To mSize: mSw(ii) = mTrig(ii).TimerInterval : Next 2242 Else 2243 mSw(0) = aSw 2244 End If 2245 End Sub 2246 2247 Public Sub InitSnd(aBall, aNoBall) : mBallSnd = aBall : mNoBallSnd = aNoBall : End Sub 2248 Public Sub CreateEvents(aName) 2249 Dim ii 2250 If Not vpmCheckEvent(aName, Me) Then Exit Sub 2251 For ii = 0 To mSize 2252 vpmBuildEvent mTrig(ii), "Hit", aName & ".TrigHit ActiveBall," & ii+1 2253 vpmBuildEvent mTrig(ii), "Unhit", aName & ".TrigUnhit ActiveBall," & ii+1 2254 vpmBuildEvent mKick(ii), "Hit", aName & ".KickHit " & ii+1 2255 Next 2256 End Sub 2257 2258 Public Sub SolExit(aEnabled) 2259 Dim ii, mSwcopy 2260 mGateOpen = aEnabled 2261 If Not aEnabled Then Exit Sub 2262 If mBalls > 0 Then PlaySound mBallSnd : Else PlaySound mNoBallSnd : Exit Sub 2263 For ii = 0 To mBalls-1 2264 mKick(ii).Enabled = False 2265 If mSw(ii) Then 2266 mSwcopy = mSw(ii) 2267 Controller.Switch(mSwcopy) = False 2268 End If 2269 Next 2270 If ExitForce > 0 Then ' Up 2271 mRealForce = ExitForce + (Rnd - 0.5)*KickForceVar : mKick(mBalls-1).Kick ExitDir, mRealForce 2272 Else ' Down 2273 mKick(0).Kick 0, 0 2274 End If 2275 End Sub 2276 2277 Public Sub Reset 2278 Dim mSwcopy 2279 Dim ii : If mBalls = 0 Then Exit Sub 2280 For ii = 0 To mBalls-1 2281 If mSw(ii) Then 2282 mSwcopy = mSw(ii) 2283 Controller.Switch(mSwcopy) = True 2284 End If 2285 Next 2286 End Sub 2287 2288 Public Property Get Balls : Balls = mBalls : End Property 2289 2290 Public Property Let Balls(aBalls) 2291 Dim mSwcopy 2292 Dim ii : mBalls = aBalls 2293 For ii = 0 To mSize 2294 mSwcopy = mSw(ii) 2295 If ii >= aBalls Then 2296 mKick(ii).DestroyBall : If mSwcopy Then Controller.Switch(mSwcopy) = False 2297 Else 2298 vpmCreateBall mKick(ii) : If mSwcopy Then Controller.Switch(mSwcopy) = True 2299 End If 2300 Next 2301 End Property 2302 2303 Public Sub TrigHit(aBall, aNo) 2304 Dim mSwcopy 2305 aNo = aNo - 1 2306 If mSw(aNo) Then 2307 mSwcopy = mSw(aNo) 2308 Controller.Switch(mSwcopy) = True 2309 End If 2310 If aBall.VelY < -1 Then Exit Sub ' Allow small upwards speed 2311 If aNo = mSize Then mBalls = mBalls + 1 2312 If mBalls > aNo Then mKick(aNo).Enabled = Not mGateOpen 2313 End Sub 2314 2315 Public Sub TrigUnhit(aBall, aNo) 2316 Dim mSwcopy 2317 aNo = aNo - 1 2318 If mSw(aNo) Then 2319 mSwcopy = mSw(aNo) 2320 Controller.Switch(mSwcopy) = False 2321 End If 2322 If aBall.VelY > -1 Then 2323 If aNo = 0 Then mBalls = mBalls - 1 2324 If aNo < mSize Then mKick(aNo+1).Kick 0, 0 2325 Else 2326 If aNo = mSize Then mBalls = mBalls - 1 2327 If aNo > 0 Then mKick(aNo-1).Kick ExitDir, mRealForce 2328 End If 2329 End Sub 2330 2331 Public Sub KickHit(aNo) : mKick(aNo-1).Enabled = False : End Sub 2332End Class 2333 2334'-------------------- 2335' View Dips 2336'-------------------- 2337Class cvpmDips 2338 Private mLWF, mChkCount, mOptCount, mItems() 2339 2340 Private Sub Class_Initialize 2341 ReDim mItems(100) 2342 End Sub 2343 2344 Private Sub addChkBox(aType, aLeft, aTop, aWidth, aNames) 2345 Dim ii, obj 2346 If Not isObject(mLWF) Then Exit Sub 2347 For ii = 0 To UBound(aNames) Step 2 2348 Set obj = mLWF.AddCtrl("chkBox", 10+aLeft, 5+aTop+ii*7, aWidth, 14, aNames(ii)) 2349 mChkCount = mChkCount + 1 : mItems(mChkCount+mOptCount) = Array(aType, obj, mChkCount, aNames(ii+1), aNames(ii+1)) 2350 Next 2351 End Sub 2352 2353 Private Sub addOptBox(aType, aLeft, aTop, aWidth, aHeading, aMask, aNames) 2354 Dim ii, obj 2355 If Not isObject(mLWF) Then Exit Sub 2356 mLWF.AddCtrl "Frame", 10+aLeft, 5+aTop, 10+aWidth, 7*UBound(aNames)+25, aHeading 2357 If aMask Then 2358 For ii = 0 To UBound(aNames) Step 2 2359 Set obj = mLWF.AddCtrl("OptBtn", 10+aLeft+5, 5+aTop+ii*7+14, aWidth, 14, aNames(ii)) 2360 mOptCount = mOptCount + 1 : mItems(mChkCount+mOptCount) = Array(aType+2,obj,mOptCount,aNames(ii+1),aMask) 2361 Next 2362 Else 2363 addChkBox aType, 5+aLeft, 15+aTop, aWidth, aNames 2364 End If 2365 End Sub 2366 2367 Public Sub addForm(ByVal aWidth, aHeight, aName) 2368 If aWidth < 80 Then aWidth = 80 2369 On Error Resume Next 2370 Set mLWF = CreateObject("VPinMAME.WSHDlg") : If Err Then Exit Sub 2371 With mLWF 2372 .x = -1 : .y = -1 ' : .w = aWidth : .h = aHeight+60 2373 .Title = aName : .AddCtrl "OKBtn", -1, -1, 70, 25, "&Ok" 2374 End With 2375 mChkCount = 0 : mOptCount = 0 2376 End Sub 2377 2378 Public Sub addChk(aLeft, aTop, aWidth, aNames) 2379 addChkBox 0, aLeft, aTop, aWidth, aNames 2380 End Sub 2381 Public Sub addChkExtra(aLeft, aTop, aWidth, aNames) 2382 addChkBox 1, aLeft, aTop, aWidth, aNames 2383 End Sub 2384 Public Sub addFrame(aLeft, aTop, aWidth, aHeading, aMask, aNames) 2385 addOptBox 0, aLeft, aTop, aWidth, aHeading, aMask, aNames 2386 End Sub 2387 Public Sub addFrameExtra(aLeft, aTop, aWidth, aHeading, aMask, aNames) 2388 addOptBox 1, aLeft, aTop, aWidth, aHeading, aMask, aNames 2389 End Sub 2390 2391 Public Sub addLabel(aLeft, aTop, aWidth, aHeight, aCaption) 2392 If Not isObject(mLWF) Then Exit Sub 2393 mLWF.AddCtrl "Label", 10+aLeft, 5+aTop, aWidth, aHeight, aCaption 2394 End Sub 2395 2396 Public Sub viewDips : viewDipsExtra 0 : End Sub 2397 Public Function viewDipsExtra(aExtra) 2398 Dim dips(1), ii, useDip 2399 If Not isObject(mLWF) Then Exit Function 2400 With Controller 2401 dips(0) = .Dip(0) + .Dip(1)*256 + .Dip(2)*65536 + (.Dip(3) And &H7f)*&H1000000 2402 If .Dip(3) And &H80 Then dips(0) = dips(0) Or &H80000000 'workaround for overflow error 2403 End With 2404 useDip = False : dips(1) = aExtra 2405 For ii = 1 To mChkCount + mOptCount 2406 mItems(ii)(1).Value = -((dips(mItems(ii)(0) And &H01) And mItems(ii)(4)) = mItems(ii)(3)) 2407 If (mItems(ii)(0) And &H01) = 0 Then useDip = True 2408 Next 2409 mLWF.Show GetPlayerHWnd 2410 dips(0) = 0 : dips(1) = 0 2411 For ii = 1 To mChkCount + mOptCount 2412 If mItems(ii)(1).Value Then dips(mItems(ii)(0) And &H01) = dips(mItems(ii)(0) And &H01) Or mItems(ii)(3) 2413 Next 2414 If useDip Then 2415 With Controller 2416 .Dip(0) = (dips(0) And 255) 2417 .Dip(1) = ((dips(0) And 65280)\256) And 255 2418 .Dip(2) = ((dips(0) And &H00ff0000)\65536) And 255 2419 .Dip(3) = ((dips(0) And &Hff000000)\&H01000000) And 255 2420 End With 2421 End If 2422 viewDipsExtra = dips(1) 2423 End Function 2424End Class 2425 2426'-------------------- 2427' Impulse Plunger 2428'-------------------- 2429Class cvpmImpulseP 2430 Private mEnabled, mBalls, mTrigger, mEntrySnd, mExitSnd, MExitSndBall 2431 Public X, Y, Strength, Res, Size, Solenoid, IMPowerOut, Time, mCount, Pull, IMPowerTrans, cFactor, Auto, RandomOut, SwitchNum, SwitchOn, BallOn 2432 2433 Private Sub Class_Initialize 2434 Size = 1 : Strength = 0 : Solenoid = 0 : Res = 1 : IMPowerOut = 0 : Time = 0 : mCount = 0 : mEnabled = False 2435 Pull = 0 : IMPowerTrans = 0 : Auto = False : RandomOut = 0 : SwitchOn = 0 : SwitchNum = 0 : BallOn = 0 2436 Set mBalls = New cvpmDictionary 2437 End Sub 2438 2439 Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, True, aEnabled : End Property 2440 2441 Public Sub InitImpulseP(aTrigger, aStrength, aTime) 2442 Dim tmp 2443 If vpmIsArray(aTrigger) Then Set tmp = aTrigger(0) Else Set tmp = aTrigger 2444 X = tmp.X : Y = tmp.Y : Size = tmp.Radius : vpmTimer.InitTimer tmp, True 2445 If IsArray(aTrigger) Then mTrigger = aTrigger Else Set mTrigger = aTrigger 2446 Strength = aStrength 2447 Res = 500 2448 Time = aTime 2449 If aTime = 0 Then 2450 Auto = True 2451 Else 2452 cFactor = (Res / Time) / 100 2453 Auto = False 2454 End If 2455 End Sub 2456 2457 Public Sub CreateEvents(aName) 2458 If vpmCheckEvent(aName, Me) Then 2459 vpmBuildEvent mTrigger, "Hit", aName & ".AddBall ActiveBall" 2460 vpmBuildEvent mTrigger, "UnHit", aName & ".RemoveBall ActiveBall" 2461 End If 2462 End Sub 2463 2464 2465 Public Property Let PlungeOn(aEnabled) : mEnabled = aEnabled : End Property 2466 Public Property Get PlungeOn 2467 If Solenoid > 0 Then PlungeOn = Controller.Solenoid(Solenoid) Else PlungeOn = mEnabled 2468 End Property 2469 2470 Public Sub AddBall(aBall) 2471 Dim mSwcopy 2472 With mBalls 2473 If .Exists(aBall) Then .Item(aBall) = .Item(aBall) + 1 Else .Add aBall, 1 : NeedUpdate = True 2474 End With 2475 If SwitchOn = True Then 2476 mSwcopy = SwitchNum 2477 Controller.Switch(mSwcopy) = 1 2478 End If 2479 BallOn = 1 2480 End Sub 2481 2482 Public Sub RemoveBall(aBall) 2483 Dim mSwcopy 2484 With mBalls 2485 If .Exists(aBall) Then .Item(aBall) = .Item(aBall) - 1 : If .Item(aBall) <= 0 Then .Remove aBall 2486 NeedUpdate = (.Count > 0) 2487 End With 2488 If SwitchOn = True Then 2489 mSwcopy = SwitchNum 2490 Controller.Switch(mSwcopy) = 0 2491 End If 2492 BallOn = 0 2493 End Sub 2494 2495 Public Property Get Balls : Balls = mBalls.Keys : End Property 2496 2497 Public Sub Update 2498 Dim obj 2499 If pull = 1 and mCount < Res Then 2500 mCount = mCount + cFactor 2501 IMPowerTrans = mCount 2502 NeedUpdate = True 2503 Else 2504 IMPowerTrans = mCount 2505 NeedUpdate = False 2506 End If 2507 If PlungeOn Then 2508 On Error Resume Next 2509 For Each obj In mBalls.Keys 2510 If obj.X < 0 Or Err Then : mBalls.Remove obj : Else : PlungeBall obj : End If 2511 Next 2512 On Error Goto 0 2513 End If 2514 End Sub 2515 2516 Public Sub PlungeBall(aBall) 2517 aBall.VelY = IMPowerOut 2518 End Sub 2519 2520 Public Sub Random(aInput) ' Random Output Varience 2521 RandomOut = aInput 2522 End Sub 2523 2524 Public Sub Fire ' Resets System and Transfer Power Value 2525 If Auto = True Then 2526 IMPowerOut = -Strength + ((Rnd) * RandomOut) 2527 Else 2528 IMPowerOut = -Strength * (IMPowerTrans + ((Rnd-0.5) * cFactor * RandomOut)) / Res 2529 End If 2530 PlungeOn = True 2531 Update 2532 PlungeOn = False 2533 Pull = 0 : IMPowerOut = 0 : IMPowerTrans = 0 : mCount = 0 2534 If BallOn = 1 Then : PlaySound mExitSndBall : Else : PlaySound mExitSnd : End If 2535 End Sub 2536 2537 Public Sub AutoFire ' Auto-Fire Specific Call (so you don't have to change timing) 2538 IMPowerOut = -Strength + ((Rnd) * RandomOut) 2539 PlungeOn = True 2540 Update 2541 PlungeOn = False 2542 Pull = 0 : IMPowerOut = 0 : IMPowerTrans = 0 : mCount = 0 2543 If BallOn = 1 Then : PlaySound mExitSndBall : Else : PlaySound mExitSnd : End If 2544 End Sub 2545 2546 Public Sub Pullback ' Pull Plunger 2547 Pull = 0 : IMPowerOut = 0 : IMPowerTrans = 0 : mCount = 0 ' reinitialize to be sure 2548 Pull = 1 : NeedUpdate = True 2549 PlaySound mEntrySnd 2550 End Sub 2551 2552 Public Sub Switch(aSw) 2553 SwitchOn = True 2554 SwitchNum = aSw 2555 End Sub 2556 2557 Public Sub InitEntrySnd(aNoBall) : mEntrySnd = aNoBall : End Sub 2558 Public Sub InitExitSnd(aBall, aNoBall) : mExitSndBall = aBall : mExitSnd = aNoBall : End Sub 2559End Class 2560 2561Set vpmTimer = New cvpmTimer 2562If LoadScript("NudgePlugIn.vbs") Then Set vpmNudge = New cvpmNudge2 Else Set vpmNudge = New cvpmNudge 2563 2564'------------- 2565'cvpmFlips (FastFlips) 2 Beta 1 2566'------------- 2567 2568'Redesigned to better support games from the solid-state flipper era, including previously unsupported games thanks to DJrobX and Stumblor! 2569'New Features: 2570'- Switches from script to rom control after a delay (100ms default, vpmflips.RomControlDelay) 2571' -This works independently for each flipper, ex. the Thing Flip will not interfere even briefly with lower flippers 2572'- New Feature - vpmFlips.Enabled. vpmFlips.Enabled = True / False will enable / disable fastflips. (This does the same thing as vpmflipsSAM.RomControl) 2573' -May be necessary to manually disable flippers for video mode on some games 2574'- New method to disable upper flippers without getting rom errors from the double action cab switches: call helper subs NoUpperLeftFlipper, NoUpperRightFlipper 2575' -On SS games that reuse upper flipper COILS, call the appropriate helper subs from the table script: NoUpperLeftFlipper, NoUpperRightFlipper (for example AFM) 2576' -On SS games that reuse upper flipper SWITCHES, you will still need the cSingleLFlip/cSingleRFlip lines! 2577' -CSinglexFlip automatically disables flippers to retain legacy behavior 2578'- Initializes using pulsetimer. VpmInit Me line no longer necessary (? may change) 2579 2580'Todo 2581'test delay - works okay but a little weird if longer than romcontroldelay 2582'test more tables 2583'test Red & Ted with the left side flippers 2584'test region safety 2585'update SAM.vbs ? 2586 2587dim vpmFlips : set vpmFlips = New cvpmFlips2 : vpmFlips.Name = "vpmFlips" 2588 2589Sub NoUpperLeftFlipper() : vpmFlips.FlipperSolNumber(2) = 0 : End Sub 2590Sub NoUpperRightFlipper() : vpmFlips.FlipperSolNumber(3) = 0 : End Sub 2591 2592Function NullFunction(a) : End Function 2593 2594vpmtimer.addtimer 40, "vpmFlips.Init'" 'this might be a dumb idea but it would replace the requirement for vpminit me 2595 2596Class cvpmFlips2 'test fastflips switches to rom control after 100ms or so delay 2597 Public Name, Delay, TiltObjects, Sol, DebugOn 2598 Public LagCompensation 'flag for solenoid jitter (may not be a problem anymore) set private 2599 2600 Public FlipperSolNumber(3) 'Flipper Solenoid Number. By default these are set to use the Core constants. 0=left 1=right 2=Uleft 3=URight 2601 Public ButtonState(3) 'Key Flip State 'set private 2602 Public SolState(3) 'Rom Flip State 'set private 2603 2604 'Public SubL, SubUL, SubR, SubUR 'may restore these to reduce nested calls. For now the script is compressed a bit. 2605 Public FlipperSub(3) 'Set to the flipper subs by .init 2606 2607 Public FlippersEnabled 'Flipper Circuit State (from the ROM) 2608 Public OnOff 'FastFlips Enabled. Separate from FlippersEnabled, which is the flipper circuit state 'private 'todo rename 2609 2610 Public FlipAt(3) 'Flip Time in gametime 'private 2611 Public RomControlDelay 'Delay after flipping that Rom Controlled Flips are accepted (default 100ms) 2612 2613 2614 Private Sub Class_Initialize() 2615 dim idx :for idx = 0 to 3 :FlipperSub(idx) = "NullFunction" : OnOff=True: ButtonState(idx)=0:SolState(idx)=0: Next 2616 Delay=0: FlippersEnabled=0: DebugOn=0 : LagCompensation=0 : Sol=0 : TiltObjects=1 2617 RomControlDelay = 100 'RomControlDelay MS between switching to rom controlled flippers 2618 FlipperSolNumber(0)=sLLFlipper :FlipperSolNumber(1)=sLRFlipper :FlipperSolNumber(2)=sULFlipper : FlipperSolNumber(3)=sURFlipper 2619 End Sub 2620 2621 Sub Init() 'called by a timer, but previously was called by vpminit sub 2622 On Error Resume Next 'If there's no usesolenoids variable present, exit 2623 call eval(UseSolenoids) : if err then exit Sub 2624 On Error Goto 0 2625 err.clear 2626 2627 'Set Solenoid 2628 if not UseSolenoids > 1 then exit sub 2629 On Error Resume Next 2630 'For some WPC games (IJ) that reuse upper flipper 2631 'switch numbers, and legacy fast flip code, disable 2632 'flippers if cSinglexFlip is set. 2633 If not cSingleLFlip Then 2634 if err.number = 0 then NoUpperLeftFlipper 2635 End If 2636 err.clear 2637 If not cSingleRFlip Then 2638 if err.number = 0 then NoUpperRightFlipper 2639 End If 2640 err.clear 2641 If UseSolenoids > 2 Then 2642 Solenoid = UseSolenoids 2643 Else 2644 err.clear 2645 if IsEmpty(GameOnSolenoid) or Err then msgbox "VPMflips error: " & err.description 2646 if err = 500 then 'Error 500 - Variable not defined 2647 msgbox "UseSolenoids = 2 error!" & vbnewline & vbnewline & "GameOnSolenoid is not defined!" & vbnewline & _ 2648 "System may be incompatible (Check the compatibility list) or your system scripts may be out of date" 2649 End If 2650 Solenoid = GameOnSolenoid 2651 End If 2652 On Error Goto 0 2653 2654 'Set callbacks 2655 dim idx : for idx = 0 to 3 2656 If IsNumeric(FlipperSolNumber(idx)) then 2657 Callback(idx) = SolCallback(abs(FlipperSolNumber(idx))) 2658 end If 2659 Next 2660 2661 'dim str 2662 'for idx = 0 to 3 : str = str & "Callback" & idx & ":" & Callback(idx) &vbnewline : Next 2663 'str = "init successful" &vbnewline& _ 2664 ' "Sol=" & Solenoid & " " & sol &vbnewline& str 2665 'msgbox str 2666 ''''vpmFlips.DebugTestInit = True 'removed debug stuff for the moment 2667 End Sub 2668 2669 'Index based callbacks... 2670 Public Property Let Callback(aIdx, aInput) 2671 if Not IsEmpty(aInput) then 2672 FlipperSub(aIDX) = aInput 'hold old flipper subs 2673 SolCallback(FlipperSolNumber(aIdx)) = name & ".RomFlip(" & aIdx & ")=" 2674 end if 2675 End Property 2676 Public Property Get Callback(aIdx) : CallBack = FlipperSub(aIDX) : End Property 2677 2678 Public Property Let Enabled(ByVal aEnabled) 'improving choreography 2679 aEnabled = cBool(aEnabled) 2680 if aEnabled <> OnOff then 'disregard redundant updates 2681 OnOff = aEnabled 2682 dim idx 2683 If aEnabled then 'Switch to ROM solenoid states or button states immediately 2684 for idx = 0 to 3 2685 if SolState(idx) <> ButtonState(idx) And FlippersEnabled Then Execute FlipperSub(idx) &" "& ButtonState(idx) end If 2686 Next 2687 Else 2688 for idx = 0 to 3 : if ButtonState(idx) <> SolState(idx) Then Execute FlipperSub(idx) &" "& SolState(idx) end if : Next 2689 End If 2690 end If 2691 End Property 2692 Public Property Get Enabled : Enabled = OnOff : End Property 2693 2694 Public Property Let Solenoid(aInput) : if isnumeric(aInput) then Sol = abs(aInput) : end if : End Property 'set solenoid 2695 Public Property Get Solenoid : Solenoid = sol : End Property 2696 2697 Public Property Let Flip(aIdx, ByVal aEnabled) 'Key Flip: Indexed base flip... may keep may not 2698 aEnabled = abs(aEnabled) 'True / False is not region safe with execute. Convert to 1 or 0 instead. 2699 ButtonState(aIDX) = aEnabled 'track flipper button states: the game-on sol flips immediately if the button is held down 2700 'debug.print "Key Flip " & aIdx &" @ " & gametime & " FF ON: " & OnOff & " Circuit On? " & FlippersEnabled 2701 If OnOff and FlippersEnabled or DebugOn then 2702 execute FlipperSub(aIdx) & " " & aEnabled 2703 FlipAt(aIDX) = GameTime 2704 end If 2705 End Property 2706 2707 'call callbacks 'legacy 2708 Public Sub FlipL(aEnabled) : Flip(0)=aEnabled :End Sub : Public Sub FlipR(aEnabled) : Flip(1)=aEnabled :End Sub 2709 Public Sub FlipUL(aEnabled): Flip(2)=aEnabled :End Sub : Public Sub FlipUR(aEnabled): Flip(3)=aEnabled :End Sub 2710 2711 Public Property Let RomFlip(aIdx, ByVal aEnabled) 2712 aEnabled = abs(aEnabled) 2713 SolState(aIdx) = aEnabled 2714 2715 If Not OnOff OR GameTime >= FlipAt(aIdx) + RomControlDelay Then 2716 Execute FlipperSub(aIDX) & " " & aEnabled 2717 'tb.text = "Rom Flip " & aIdx & " state:" & aEnabled &vbnewline&_ 2718 'GameTime & " >= " & FlipAt(aIdx) & "+" & RomControlDelay 2719 'debug.print "rom flip @ " & gametime & "solenoid:" & sol & ": " & FlippersEnabled 2720 end if 2721 End property 2722 2723 Public Sub TiltSol(ByVal aEnabled) 'Handle solenoid / Delay (if delayinit) 2724 aEnabled = cBool(aEnabled) 2725 If delay > 0 and not aEnabled then 'handle delay 2726 vpmtimer.addtimer Delay, Name & ".FireDelay" & "'" 2727 LagCompensation = 1 2728 else 2729 If Delay > 0 then LagCompensation = 0 2730 EnableFlippers(aEnabled) 2731 end If 2732 End Sub 2733 2734 Sub FireDelay() : If LagCompensation then EnableFlippers False End If : End Sub 2735 2736 Public Sub EnableFlippers(ByVal aEnabled) 'private 2737 aEnabled = abs(aEnabled) 'Might fix TMNT issue with vpmnudge.solgameon? 2738 dim idx 2739 'If aEnabled then execute SubL &" "& ButtonState(0) :execute SubR &" "& ButtonState(1) :execute subUL &" "& ButtonState(2): execute subUR &" "& ButtonState(3)':end if 2740 If aEnabled then : for idx = 0 to 3 : execute FlipperSub(idx) &" "& ButtonState(idx) : next : end If 2741 FlippersEnabled = aEnabled 2742 If TiltObjects then vpmnudge.solgameon aEnabled 2743 If Not aEnabled then 2744' execute subL & " " & 0 : execute subR & " " & 0 2745' execute subUL & " " & 0 : execute subUR & " " & 0 2746 for idx = 0 to 3 : execute FlipperSub(idx) &" "& 0 : Next 2747 End If 2748 End Sub 2749 2750 'debug for finding sols 2751 Public Sub PrintSols() : Dim x, sols: sols=controller.solenoids: for x= 0 to uBound(sols) : if sols(x) then debug.print x & ":" & sols(x) end if : Next : End Sub 2752 2753End Class 2754 2755 2756'--------------------------- 2757' Check VP version running 2758'--------------------------- 2759Private Function vpmCheckVPVer 2760 On Error Resume Next 2761 ' a bug in VBS?: Err object is not cleared on Exit Function 2762 If VPBuildVersion < 0 Or Err Then vpmCheckVPVer = 50 : Err.Clear : Exit Function 2763 If VPBuildVersion > 2806 and VPBuildVersion < 9999 Then 2764 vpmCheckVPVer = 63 2765 ElseIf VPBuildVersion > 2721 and VPBuildVersion < 9999 Then 2766 vpmCheckVPVer = 61 2767 ElseIf VPBuildVersion >= 900 and VPBuildVersion <= 999 Then 2768 vpmCheckVPVer = 90 2769 ElseIf VPBuildVersion >= 10000 Then 2770 vpmCheckVPVer = 100 2771 Else 2772 vpmCheckVPVer = 60 2773 End If 2774End Function 2775Private vpmVPVer : vpmVPVer = vpmCheckVPVer() 2776'-------------------- 2777' Initialise timers 2778'-------------------- 2779Sub PulseTimer_Init : vpmTimer.InitTimer Me, False : End Sub 2780Sub PinMAMETimer_Init : Me.Interval = PinMAMEInterval : Me.Enabled = True : End Sub 2781 2782'--------------------------------------------- 2783' Init function called from Table_Init event 2784'--------------------------------------------- 2785Public Sub vpmInit(aTable) 2786 Set vpmTable = aTable 2787 If vpmVPVer >= 60 Then 2788 On Error Resume Next 2789 If Not IsObject(GetRef(aTable.name & "_Paused")) Or Err Then Err.Clear : vpmBuildEvent aTable, "Paused", "Controller.Pause = True" 2790 If Not IsObject(GetRef(aTable.name & "_UnPaused")) Or Err Then Err.Clear : vpmBuildEvent aTable, "UnPaused", "Controller.Pause = False" 2791 If Not IsObject(GetRef(aTable.name & "_Exit")) Or Err Then Err.Clear : vpmBuildEvent aTable, "Exit", "Controller.Pause = False:Controller.Stop" 2792 End If 2793 if UseModSol Then 2794 If Controller.Version >= 02080000 Then 2795 Controller.SolMask(2)=1 2796 Else 2797 MsgBox "Modulated Flashers/Solenoids not supported with this Visual PinMAME version (2.8 or newer is required)" 2798 End If 2799 End If 2800 'InitVpmFlips 'have vpmtimer doing this atm 2801End Sub 2802 2803' Exit function called in Table_Exit event 2804Public Sub vpmExit : End Sub 2805'------------------------------------------------------ 2806' All classes call this function to create a ball 2807' Assign vpmCreateBall if you want a custom function 2808'------------------------------------------------------ 2809Private Function vpmDefCreateBall(aKicker) 2810 If Not IsEmpty(vpmBallImage) Then aKicker.Createball.Image = vpmBallImage Else aKicker.Createball : End If 2811 Set vpmDefCreateBall = aKicker 2812End Function 2813 2814Private Function vpmDefCreateBall2(aKicker) 2815 If Not IsEmpty(vpmBallImage) Then aKicker.Createsizedball(BSize).Image = vpmBallImage Else aKicker.Createsizedball(BSize) : End If 2816 Set vpmDefCreateBall2 = aKicker 2817End Function 2818 2819Private Function vpmDefCreateBall3(aKicker) 2820 If Not IsEmpty(vpmBallImage) Then 2821 aKicker.CreateSizedBallWithMass(BSize,BMass).Image = vpmBallImage 2822 Else 2823 aKicker.CreateSizedBallWithMass BSize,BMass ' for whatever reason it doesn't work if using () 2824 End If 2825 Set vpmDefCreateBall3 = aKicker 2826End Function 2827 2828If VPBuildVersion >= 10000 Then 2829 Set vpmCreateBall = GetRef("vpmDefCreateBall3") 2830ElseIf VPBuildVersion > 909 And vpmVPVer >= 90 Then 2831 Set vpmCreateBall = GetRef("vpmDefCreateBall2") 2832Else 2833 Set vpmCreateBall = GetRef("vpmDefCreateBall") 2834End If 2835 2836Private vpmTrough ' Default Trough. Used to clear up missing balls 2837Private vpmTable ' Table object 2838 2839'------------------- 2840' Main Loop 2841'------------------ 2842Private Const CHGNO = 0 2843Private Const CHGSTATE = 1 2844Private vpmTrueFalse : vpmTrueFalse = Array(" True", " False"," True") 2845 2846Sub vpmDoSolCallback(aNo, aEnabled) 2847 If SolCallback(aNo) <> "" Then Execute SolCallback(aNo) & vpmTrueFalse(aEnabled+1) 2848End Sub 2849 2850Sub vpmDoLampUpdate(aNo, aEnabled) 2851 On Error Resume Next : Lights(aNo).State = Abs(aEnabled) 2852End Sub 2853 2854Sub PinMAMETimer_Timer 2855 Dim ChgLamp,ChgSol,ChgGI, ii, tmp, idx, nsol, solon, ChgLed 2856 Dim DMDp 2857 Dim ChgNVRAM 2858 2859 'Me.Enabled = False 'this was supposed to be some kind of weird mutex, disable it 2860 2861 On Error Resume Next 2862 If UseDMD Then 2863 DMDp = Controller.RawDmdPixels 2864 If Not IsEmpty(DMDp) Then 2865 DMDWidth = Controller.RawDmdWidth 2866 DMDHeight = Controller.RawDmdHeight 2867 DMDPixels = DMDp 2868 End If 2869 ElseIf UseColoredDMD Then 2870 DMDp = Controller.RawDmdColoredPixels 2871 If Not IsEmpty(DMDp) Then 2872 DMDWidth = Controller.RawDmdWidth 2873 DMDHeight = Controller.RawDmdHeight 2874 DMDColoredPixels = DMDp 2875 End If 2876 End If 2877 If UseNVRAM Then 2878 If isObject(NVRAMCallback) Then 2879 ChgNVRAM = Controller.ChangedNVRAM 'Controller.NVRAM would deliver everything of the NVRAM all the time as 1D array 2880 If(Not IsEmpty(ChgNVRAM)) Then NVRAMCallback ChgNVRAM 2881 End If 2882 End If 2883 If UseLamps Then ChgLamp = Controller.ChangedLamps Else LampCallback 2884 If UsePdbLeds Then ChgLed = Controller.ChangedPDLeds Else PDLedCallback 2885 If UseSolenoids Then ChgSol = Controller.ChangedSolenoids 2886 If isObject(GICallback) or isObject(GICallback2) Then ChgGI = Controller.ChangedGIStrings 2887 MotorCallback 2888 On Error Goto 0 2889 If Not IsEmpty(ChgLamp) Then 2890 On Error Resume Next 2891 For ii = 0 To UBound(ChgLamp) 2892 idx = ChgLamp(ii, 0) 2893 If IsArray(Lights(idx)) Then 2894 For Each tmp In Lights(idx) : tmp.State = ChgLamp(ii, 1) : Next 2895 Else 2896 Lights(idx).State = ChgLamp(ii, 1) 2897 End If 2898 Next 2899 For Each tmp In vpmMultiLights 2900 For ii = 1 To UBound(tmp) : tmp(ii).State = tmp(0).State : Next 2901 Next 2902 LampCallback 2903 On Error Goto 0 2904 End If 2905 If Not IsEmpty(ChgSol) Then 2906 For ii = 0 To UBound(ChgSol) 2907 nsol = ChgSol(ii, 0) 2908 tmp = SolCallback(nsol) 2909 solon = ChgSol(ii, 1) 2910 If solon > 1 Then solon = 1 2911 If UseModSol Then 2912 If solon <> SolPrevState(nsol) Then 2913 SolPrevState(nsol) = solon 2914 If tmp <> "" Then Execute tmp & vpmTrueFalse(solon+1) 2915 End If 2916 tmp = SolModCallback(nsol) 2917 If tmp <> "" Then Execute tmp & " " & ChgSol(ii, 1) 2918 Else 2919 If tmp <> "" Then Execute tmp & vpmTrueFalse(solon+1) 2920 End If 2921 if UseSolenoids > 1 then if nsol = vpmFlips.Solenoid then vpmFlips.TiltSol solon ': msgbox solon 2922 Next 2923 End If 2924 If Not IsEmpty(ChgGI) Then 2925 For ii = 0 To UBound(ChgGI) 2926 GICallback ChgGI(ii, 0), CBool(ChgGI(ii, 1)) 2927 GICallback2 ChgGI(ii, 0), ChgGI(ii, 1) 2928 Next 2929 End If 2930 If Not IsEmpty(ChgLed) Then 2931 On Error Resume Next 2932 For ii = 0 To UBound(ChgLed) 2933 Dim color,ledstate 2934 idx = ChgLed(ii, 0) 2935 color = ChgLed(ii, 1) 2936 if color = 0 Then ledstate = 0 : Else ledstate = 1: End If 2937 2938 If IsArray(Lights(idx)) Then 2939 For Each tmp In Lights(idx) : tmp.Color = color : tmp.State = ledstate : Next 2940 Else 2941 Lights(idx).Color = color : Lights(idx).State = ledstate 2942 End If 2943 Next 2944 For Each tmp In vpmMultiLights 2945 For ii = 1 To UBound(tmp) : tmp(ii).Color = tmp(0).Color : tmp(ii).State = tmp(0).State : Next 2946 Next 2947 PDLedCallback 2948 On Error Goto 0 2949 End If 2950 'Me.Enabled = True 'this was supposed to be some kind of weird mutex, disable it 2951End Sub 2952 2953' 2954' Private helper functions 2955' 2956Private Sub vpmPlaySound(aEnabled, aSound) 2957 If VarType(aSound) = vbString Then 2958 If aEnabled Then StopSound aSound : PlaySound aSound 2959 ElseIf aSound Then 2960 If aEnabled Then PlaySound SSolenoidOn Else PlaySound SSolenoidOff 2961 End If 2962End Sub 2963 2964Private Sub vpmToggleObj(aObj, aEnabled) 2965 Dim mSwcopy 2966 Select Case TypeName(aObj) 2967 Case "Wall", "HitTarget" aObj.IsDropped = aEnabled 2968 Case "Bumper", "Light" aObj.State = Abs(aEnabled) 2969 Case "Kicker", "Trigger", "Timer" aObj.Enabled = aEnabled 2970 Case "Gate" aObj.Open = aEnabled 2971 Case "Primitive", "Ramp", "Rubber", "Flasher" aObj.Visible = aEnabled 2972 Case "Integer" mSwcopy = aObj : Controller.Switch(mSwcopy) = aEnabled 2973 Case Else MsgBox "vpmToggleObj: Unhandled Object " & TypeName(aObj) 2974 End Select 2975End Sub 2976 2977Private Function vpmCheckEvent(aName, aObj) 2978 vpmCheckEvent = True 2979 On Error Resume Next 2980 If Not Eval(aName) Is aObj Or Err Then MsgBox "CreateEvents: Wrong name " & aName : vpmCheckEvent = False 2981End Function 2982 2983Private Sub vpmBuildEvent(aObj, aEvent, aTask) 2984 Dim obj, str 2985 str = "_" & aEvent & " : " & aTask & " : End Sub" 2986 If vpmIsArray(aObj) Then 2987 For Each obj In aObj : ExecuteGlobal "Sub " & obj.Name & str : Next 2988 Else 2989 ExecuteGlobal "Sub " & aObj.Name & str 2990 End If 2991End Sub 2992 2993Private Function vpmIsCollection(aObj) 2994 vpmIsCollection = TypeName(aObj) = "Collection" Or TypeName(aObj) = "ICollection" 2995End Function 2996Private Function vpmIsArray(aObj) 2997 vpmIsArray = IsArray(aObj) Or vpmIsCollection(aObj) 2998End Function 2999 3000Private Function vpmSetArray(aTo, aFrom) 3001 If IsArray(aFrom) Then 3002 aTo = aFrom : vpmSetArray = UBound(aFrom) 3003 ElseIf vpmIsCollection(aFrom) Then 3004 Set aTo = aFrom : vpmSetArray = aFrom.Count - 1 3005 Else 3006 aTo = Array(aFrom) : vpmSetArray = 0 3007 End If 3008End Function 3009 3010Sub vpmCreateEvents(aHitObjs) 3011 Dim obj 3012 For Each obj In aHitObjs 3013 Select Case TypeName(obj) 3014 Case "Trigger" 3015 vpmBuildEvent obj, "Hit", "Controller.Switch(" & Obj.TimerInterval & ") = True" 3016 vpmBuildEvent obj, "UnHit", "Controller.Switch(" & Obj.TimerInterval & ") = False" 3017 Case "Wall" 3018 If obj.HasHitEvent Then 3019 vpmBuildEvent obj, "Hit", "vpmTimer.PulseSw " & Obj.TimerInterval 3020 Else 3021 vpmBuildEvent obj, "SlingShot", "vpmTimer.PulseSw " & Obj.TimerInterval 3022 End If 3023 Case "Bumper", "Gate", "Primitive", "HitTarget", "Rubber" 3024 vpmBuildEvent obj, "Hit", "vpmTimer.PulseSw " & Obj.TimerInterval 3025 Case "Spinner" 3026 vpmBuildEvent obj, "Spin", "vpmTimer.PulseSw " & Obj.TimerInterval 3027 End Select 3028 Next 3029End Sub 3030 3031Sub vpmMapLights(aLights) 3032 Dim obj, str, ii, idx 3033 For Each obj In aLights 3034 idx = obj.TimerInterval 3035 If IsArray(Lights(idx)) Then 3036 str = "Lights(" & idx & ") = Array(" 3037 For Each ii In Lights(idx) : str = str & ii.Name & "," : Next 3038 ExecuteGlobal str & obj.Name & ")" 3039 ElseIf IsObject(Lights(idx)) Then 3040 Lights(idx) = Array(Lights(idx),obj) 3041 Else 3042 Set Lights(idx) = obj 3043 End If 3044 Next 3045End Sub 3046 3047Function vpmMoveBall(aBall, aFromKick, aToKick) 3048 With aToKick.CreateBall 3049 If TypeName(aBall) = "IBall" Then 3050 .Color = aBall.Color : .Image = aBall.Image 3051 If vpmVPVer >= 60 Then 3052 .FrontDecal = aBall.FrontDecal : .BackDecal = aBall.BackDecal 3053' .UserValue = aBall.UserValue 3054 End If 3055 End If 3056 End With 3057 aFromKick.DestroyBall : Set vpmMoveBall = aToKick 3058End Function 3059 3060Sub vpmAddBall 3061 Dim Answer 3062 If IsObject(vpmTrough) Then 3063 Answer=MsgBox("Click YES to Add a ball to the Trough, NO Removes a ball from the Trough",vbYesNoCancel + vbQuestion) 3064 If Answer = vbYes Then vpmTrough.AddBall 0 3065 If Answer = vbNo Then vpmTrough.Balls=vpmTrough.Balls-1 3066 End If 3067End Sub 3068 3069'---------------------------- 3070' Generic solenoid handlers 3071'---------------------------- 3072' ----- Flippers ------ 3073Sub vpmSolFlipper(aFlip1, aFlip2, aEnabled) 3074 Dim oldStrength, oldSpeed ' only for pre-VP10 3075 If aEnabled Then 3076 PlaySound SFlipperOn : aFlip1.RotateToEnd : If Not aFlip2 Is Nothing Then aFlip2.RotateToEnd 3077 Else 3078 PlaySound SFlipperOff 3079 If VPBuildVersion < 10000 Then 3080 oldStrength = aFlip1.Strength : aFlip1.Strength = conFlipRetStrength 3081 oldSpeed = aFlip1.Speed : aFlip1.Speed = conFlipRetSpeed 3082 End If 3083 aFlip1.RotateToStart 3084 If VPBuildVersion < 10000 Then 3085 aFlip1.Strength = oldStrength 3086 aFlip1.Speed = oldSpeed 3087 End If 3088 If Not aFlip2 Is Nothing Then 3089 If VPBuildVersion < 10000 Then 3090 oldStrength = aFlip2.Strength : aFlip2.Strength = conFlipRetStrength 3091 oldSpeed = aFlip2.Speed : aFlip2.Speed = conFlipRetSpeed 3092 End If 3093 aFlip2.RotateToStart 3094 If VPBuildVersion < 10000 Then 3095 aFlip2.Strength = oldStrength 3096 aFlip2.Speed = oldSpeed 3097 End If 3098 End If 3099 End If 3100End Sub 3101 3102' ----- Flippers With Speed Control ------ 3103Sub vpmSolFlip2(aFlip1, aFlip2, aFlipSpeedUp, aFlipSpeedDn, aSnd, aEnabled) ' DEPRECATED, as VP10 does not feature speed on flippers anymore 3104 Dim oldStrength, oldSpeed 3105 If aEnabled Then 3106 If aSnd = true then : PlaySound SFlipperOn : End If 3107 If Not aFlipSpeedUp = 0 Then 3108 aFlip1.Speed = aFlipSpeedUp 3109 aFlip1.RotateToEnd 3110 Else 3111 aFlip1.RotateToEnd 3112 End If 3113 If Not aFlip2 Is Nothing Then 3114 If Not aFlipSpeedUp = 0 Then 3115 aFlip2.Speed = aFlipSpeedUp 3116 aFlip2.RotateToEnd 3117 Else 3118 aFlip2.RotateToEnd 3119 End If 3120 End If 3121 Else 3122 If aSnd = true then : PlaySound SFlipperOff : End If 3123 oldStrength = aFlip1.Strength 3124 aFlip1.Strength = conFlipRetStrength 3125 oldSpeed = aFlip1.Speed 3126 If Not aFlipSpeedDn = 0 Then 3127 aFlip1.Speed = aFlipSpeedDn 3128 Else 3129 aFlip1.Speed = conFlipRetSpeed 3130 End If 3131 aFlip1.RotateToStart : aFlip1.Strength = oldStrength : aFlip1.Speed = oldSpeed 3132 If Not aFlip2 Is Nothing Then 3133 oldStrength = aFlip2.Strength 3134 oldSpeed = aFlip2.Speed 3135 If Not aFlipSpeedDn = 0 Then 3136 aFlip2.Speed = aFlipSpeedDn 3137 Else 3138 aFlip2.Speed = conFlipRetSpeed 3139 End If 3140 aFlip2.Strength = conFlipRetStrength 3141 aFlip2.RotateToStart : aFlip2.Strength = oldStrength : aFlip2.Speed = oldSpeed 3142 End If 3143 End If 3144End Sub 3145 3146' ------ Diverters ------ 3147Sub vpmSolDiverter(aDiv, aSound, aEnabled) 3148 If aEnabled Then aDiv.RotateToEnd : Else aDiv.RotateToStart 3149 vpmPlaySound aEnabled, aSound 3150End sub 3151 3152' ------ Walls ------ 3153Sub vpmSolWall(aWall, aSound, aEnabled) 3154 Dim obj 3155 If vpmIsArray(aWall) Then 3156 For Each obj In aWall : obj.IsDropped = aEnabled : Next 3157 Else 3158 aWall.IsDropped = aEnabled 3159 End If 3160 vpmPlaySound aEnabled, aSound 3161End Sub 3162 3163Sub vpmSolToggleWall(aWall1, aWall2, aSound, aEnabled) 3164 Dim obj 3165 If vpmIsArray(aWall1) Then 3166 For Each obj In aWall1 : obj.IsDropped = aEnabled : Next 3167 Else 3168 aWall1.IsDropped = aEnabled 3169 End If 3170 If vpmIsArray(aWall2) Then 3171 For Each obj In aWall2 : obj.IsDropped = Not aEnabled : Next 3172 Else 3173 aWall2.IsDropped = Not aEnabled 3174 End If 3175 vpmPlaySound aEnabled, aSound 3176End Sub 3177 3178' ------- Autoplunger ------ 3179Sub vpmSolAutoPlunger(aPlung, aVar, aEnabled) 3180 Dim oldFire 3181 If aEnabled Then 3182 oldFire = aPlung.FireSpeed : aPlung.FireSpeed = oldFire * (100-aVar*(2*Rnd-1))/100 3183 PlaySound SSolenoidOn : aPlung.Fire : aPlung.FireSpeed = oldFire 3184 Else 3185 aPlung.Pullback 3186 End If 3187End Sub 3188 3189' --------Autoplunger with Specified Sound To Play --------- 3190Sub vpmSolAutoPlungeS(aPlung, aSound, aVar, aEnabled) 3191 Dim oldFire 3192 If aEnabled Then 3193 oldFire = aPlung.FireSpeed : aPlung.FireSpeed = oldFire * (100-aVar*(2*Rnd-1))/100 3194 PlaySound aSound : aPlung.Fire : aPlung.FireSpeed = oldFire 3195 Else 3196 aPlung.Pullback 3197 End If 3198End Sub 3199 3200' --------- Gate ----------- 3201Sub vpmSolGate(aGate, aSound, aEnabled) 3202 Dim obj 3203 If vpmIsArray(aGate) Then 3204 For Each obj In aGate : obj.Open = aEnabled : Next 3205 Else 3206 aGate.Open = aEnabled 3207 End If 3208 vpmPlaySound aEnabled, aSound 3209End Sub 3210 3211' ------ Sound Only ------- 3212Sub vpmSolSound(aSound, aEnabled) 3213 If aEnabled Then StopSound aSound : PlaySound aSound 3214End Sub 3215 3216' ------- Flashers -------- 3217Sub vpmFlasher(aFlash, aEnabled) 3218 Dim obj 3219 If vpmIsArray(aFlash) Then 3220 For Each obj In aFlash : obj.State = Abs(aEnabled) : Next 3221 Else 3222 aFlash.State = Abs(aEnabled) 3223 End If 3224End Sub 3225 3226'---- Generic object toggle ---- 3227Sub vpmSolToggleObj(aObj1, aObj2, aSound, aEnabled) 3228 Dim obj 3229 If vpmIsArray(aObj1) Then 3230 If IsArray(aObj1(0)) Then 3231 For Each obj In aObj1(0) : vpmToggleObj obj, aEnabled : Next 3232 For Each obj In aObj1(1) : vpmToggleObj obj, Not aEnabled : Next 3233 Else 3234 For Each obj In aObj1 : vpmToggleObj obj, aEnabled : Next 3235 End If 3236 ElseIf Not aObj1 Is Nothing Then 3237 vpmToggleObj aObj1, aEnabled 3238 End If 3239 If vpmIsArray(aObj2) Then 3240 If IsArray(aObj2(0)) Then 3241 For Each obj In aObj2(0) : vpmToggleObj obj, Not aEnabled : Next 3242 For Each obj In aObj2(1) : vpmToggleObj obj, aEnabled : Next 3243 Else 3244 For Each obj In aObj2 : vpmToggleObj obj, Not aEnabled : Next 3245 End If 3246 ElseIf Not aObj2 Is Nothing Then 3247 vpmToggleObj aObj2, Not aEnabled 3248 End If 3249 vpmPlaySound aEnabled, aSound 3250End Sub 3251 3252' 3253' Stubs to allow older games to still work 3254' These will be removed one day 3255' 3256Sub SolFlipper(f1,f2,e) : vpmSolFlipper f1,f2,e : End Sub 3257Sub SolDiverter(d,s,e) : vpmSolDiverter d,s,e : End Sub 3258Sub SolSound(s,e) : vpmSolSound s,e : End Sub 3259Sub Flasher(f,e) : vpmFlasher f,e : End Sub 3260Sub SolMagnet(m,e) : vpmSolMagnet m,e : End Sub 3261Sub SolAutoPlunger(p,e) : vpmSolAutoPlunger p,0,e : End Sub 3262Function KeyDownHandler(ByVal k) : KeyDownHandler = vpmKeyDown(k) : End Function 3263Function KeyUpHandler(ByVal k) : KeyUpHandler = vpmKeyUp(k) : End Function 3264Function KeyName(ByVal k) : KeyName = vpmKeyName(k) : End Function 3265Sub vpmSolMagnet(m,e) : m.Enabled = e : If Not e Then m.Kick 180,1 : End If : End Sub 3266Dim vpmBallImage : vpmBallImage = Empty ' Default ball properties 3267Dim vpmBallColour 3268 3269'-- Flipper solenoids (all games) 3270Const sLRFlipper = 46 3271Const sLLFlipper = 48 3272Const sURFlipper = 34 3273Const sULFlipper = 36 3274 3275' Convert keycode to readable string 3276Private keyNames1, keyNames2 3277keyNames1 = Array("Escape","1","2","3","4","5","6","7","8","9","0","Minus '-'",_ 3278"Equals '='","Backspace","Tab","Q","W","E","R","T","Y","U","I","O","P","[","]",_ 3279"Enter","Left Ctrl","A","S","D","F","G","H","J","K","L",";","'","`","Left Shift",_ 3280"\","Z","X","C","V","B","N","M",",",".","/","Right Shift","*","Left Menu","Space",_ 3281"Caps Lock","F1","F2","F3","F4","F5","F6","F7","F8","F9","F10","NumLock","ScrlLock",_ 3282"Numpad 7","Numpad 8","Numpad 9","Numpad -","Numpad 4","Numpad 5","Numpad 6",_ 3283"Numpad +","Numpad 1","Numpad 2","Numpad 3","Numpad 0","Numpad .","?","?","?",_ 3284"F11","F12","F13","F14","F15") 3285keyNames2 = Array("Pause","?","Home","Up","PageUp","?","Left","?","Right","?",_ 3286"End","Down","PageDown","Insert","Delete") 3287 3288Function vpmKeyName(ByVal aKeycode) 3289 If aKeyCode-1 <= UBound(keyNames1) Then 3290 vpmKeyName = keyNames1(aKeyCode-1) 3291 ElseIf aKeyCode >= 197 And aKeyCode <= 211 Then 3292 vpmKeyName = keyNames2(aKeyCode-197) 3293 ElseIf aKeyCode = 184 Then 3294 vpmKeyName = "R.Alt" 3295 Else 3296 vpmKeyName = "?" 3297 End If 3298End Function 3299 3300Private vpmSystemHelp 3301Private Sub vpmShowHelp 3302 Dim szKeyMsg 3303 szKeyMsg = "The following keys are defined: " & vbNewLine &_ 3304 "(American keyboard layout)" & vbNewLine &_ 3305 vbNewLine & "Visual PinMAME keys:" & vbNewLine &_ 3306 vpmKeyName(keyShowOpts) & vbTab & "Game options..." & vbNewLine &_ 3307 vpmKeyName(keyShowKeys) & vbTab & "Keyboard settings..." & vbNewLine &_ 3308 vpmKeyName(keyReset) & vbTab & "Reset emulation" & vbNewLine &_ 3309 vpmKeyName(keyFrame) & vbTab & "Toggle Display lock" & vbNewLine &_ 3310 vpmKeyName(keyDoubleSize) & vbTab & "Toggle Display size" & vbNewLine 3311 If IsObject(vpmShowDips) Then 3312 szKeyMsg = szKeyMsg & vpmKeyName(keyShowDips) & vbTab & "Show DIP Switch / Option Menu" & vbNewLine 3313 End If 3314 If IsObject(vpmTrough) Then 3315 szKeyMsg = szKeyMsg & vpmKeyName(keyAddBall) & vbTab & "Add / Remove Ball From Table" & vbNewLine 3316 End If 3317 szKeyMsg = szKeyMsg & vpmKeyName(keyBangBack) & vbTab & "Bang Back" & vbNewLine &_ 3318 vbNewLine & vpmSystemHelp & vbNewLine 3319 If ExtraKeyHelp <> "" Then 3320 szKeyMsg = szKeyMsg & vbNewLine & "Game Specific keys:" &_ 3321 vbNewLine & ExtraKeyHelp & vbNewLine 3322 End If 3323 szKeyMsg = szKeyMsg & vbNewLine & "Visual Pinball keys:" & vbNewLine &_ 3324 vpmKeyName(LeftFlipperKey) & vbTab & "Left Flipper" & vbNewLine &_ 3325 vpmKeyName(RightFlipperKey) & vbTab & "Right Flipper" & vbNewLine &_ 3326 vpmKeyName(LeftMagnaSave) & vbTab & "Left Magna Save" & vbNewLine &_ 3327 vpmKeyName(RightMagnaSave) & vbTab & "Right Magna Save" & vbNewLine &_ 3328 vpmKeyName(PlungerKey) & vbTab & "Launch Ball" & vbNewLine &_ 3329 vpmKeyName(StartGameKey) & vbTab & "Start Button" & vbNewLine &_ 3330 vpmKeyName(AddCreditKey) & vbTab & "Insert Coin 1" & vbNewLine &_ 3331 vpmKeyName(AddCreditKey2) & vbTab & "Insert Coin 2" & vbNewLine &_ 3332 vpmKeyName(ExitGame) & vbTab & "Exit Game" & vbNewLine &_ 3333 vpmKeyName(MechanicalTilt) & vbTab & "Mechanical Tilt" & vbNewLine &_ 3334 vpmKeyName(LeftTiltKey) & vbTab & "Nudge from Left" & vbNewLine &_ 3335 vpmKeyName(RightTiltKey) & vbTab & "Nudge from Right" & vbNewLine &_ 3336 vpmKeyName(CenterTiltKey) & vbTab & "Nudge forward" & vbNewLine 3337 MsgBox szKeyMsg,vbOkOnly,"Keyboard Settings..." 3338End Sub 3339 3340Private Sub NullSub(no,enabled) 3341'Place Holder Sub 3342End Sub 3343 3344'added thanks to Koadic 3345Sub NVOffset(version) ' version 2 for dB2S compatibility 3346 Dim check,nvcheck,v,vv,nvpath,rom 3347 Set check = CreateObject("Scripting.FileSystemObject") 3348 Set nvcheck = CreateObject("WScript.Shell") 3349 nvpath = nvcheck.RegRead("HKCU\Software\Freeware\Visual PinMame\globals\nvram_directory") & "\" 3350 rom = controller.gamename 3351 For v=1 to 32 'check up to 32 possible versions using same rom, it's overkill, but could be changed to a lower number (requested for 32 NFL variations) 3352 If check.FileExists(nvpath & rom & " v" & v & ".txt") Then vv=v : exit For : End If 3353 vv=0 3354 Next 3355 If vv=version or version = 0 Then 3356 Exit Sub 3357 ElseIf vv=0 Then 3358 check.CreateTextFile nvpath & rom & " v" & version & ".txt", True 3359 Exit Sub 3360 Else 3361 check.moveFile nvpath & rom & " v" & vv & ".txt", nvpath & rom & " v" & version & ".txt" 3362 If check.FileExists(nvpath & rom & ".nv") Then 3363 check.copyFile nvpath & rom & ".nv", nvpath & rom & " v" & vv & ".nv", True 3364 End If 3365 If check.FileExists(nvpath & rom & " v" & version & ".nv") Then 3366 check.copyFile nvpath & rom & " v" & version & ".nv", nvpath & rom & ".nv", True 3367 End If 3368 End If 3369End Sub 3370 3371Sub VPMVol 3372 Dim VolPM,VolPMNew 3373 VolPM = Controller.Games(controller.GameName).Settings.Value("volume") 3374 VolPMNew = InputBox ("Enter desired VPinMame Volume Level (-32 to 0)","VPinMame Volume",VolPM) 3375 If VolPMNew = "" Then Exit Sub 3376 If VolPMNew <=0 and VolPMNew >= -32 Then 3377 Controller.Games(controller.GameName).Settings.Value("volume")= round(VolPMNew) 3378 msgbox "The Visual PinMAME Global Volume is now set to " & round(VolPMNew) & "db." & VbNewLine & VbNewLine & "Please reset Visual PinMAME (F3) to apply." 3379 Else 3380 msgbox "Entered value is out of range. Entry must be in the range of negative 32 to 0." & VbNewLine & VbNewLine & "Visual PinMAME Global Volume will remain set at " & VolPM & "." 3381 End If 3382End Sub 3383 3384' Simple min/max functions 3385Function vpMin(a, b) : If a < b Then vpMin = a Else vpMin = b : End If : End Function 3386Function vpMax(a, b) : If a > b Then vpMax = a Else vpMax = b : End If : End Function 3387 3388LoadScript("ledcontrol.vbs"):Err.Clear ' Checks for existance of ledcontrol.vbs and loads it if found, if found but no ledwiz installed, clear error to allow loading of table 3389 3390LoadScript("GlobalPlugIn.vbs") ' Checks for existance of GlobalPlugIn.vbs and loads it if found, useful for adding 3391 ' custom scripting that can be used for all tables instead of altering the core.vbs 3392