This stand-alone HTA (called Cubeworld) lets you easily draw 3D worlds which you can wander around in with game-play features. It's not a smooth real time game like Doom or something, more like a 3D maze engine from the 80's. Don't let this put you off though as Cubeworld has many features:-
Based on the "Dungeon master" viewpoint but with a scope of 17 VML blocks width and 17 high with 13 depths which gives an almost proper 3D feel (as opposed to a typical maze game's 3x1 in 6 or less depths).
Every single block in the world can have a unique shape, rotation and 2 colours. You're not limited to cubes as there's lots of interesting shapes to draw with (calling the game Cubeworld is a bit unfair)
Can render 17 blocks up and down, which breaks away from the standard maze game and lets you create towers,
bridges, mountains or anything you can think of!
Integrated world editor that is really easy to use. Has features like eyedropper,bookmarks,onion skin and paint mode
No area boundaries, you can start drawing in one direction and just keep going and going!
Lots of built in game-play features like stairs, gravity, collecting items, opening locked doors, sound FX etc However the following three game features turn Cubeworld from a normal game, into something a bit more special:-
Unlimited exits to other worlds,
Transparent savegame system that saves the state of all worlds you visit in live mode and keeps track of your inventory,
Switches and events that let you create lots of varied puzzles and traps (all switch states and events are also saved)
<HTML><HEAD>
<TITLE>Creating VMLs, please wait.....</TITLE>
<HTA:APPLICATION
CONTEXTMENU = "No"
MAXIMIZEBUTTON = "No"
MINIMIZEBUTTON = "No"
INNERBORDER = "No"
BORDER = "Thin"
NAVIGABLE = "No"
WINDOWSTATE = "Maximize"
SCROLL = "No"
SELECTION = "No"
/>
<STYLE TYPE="Text/CSS">
V\:*{Behavior:URL(#Default#VML); AntiAlias:False;}
BODY {
Margin : 0 ; Border : 0 ; BackGround-Color : #303030 ;
}
.styButton {
Position : Absolute ;
Font-Family : Arial ; Font-Size : 12 ;
Color : #D0D0D0 ; BackGround-Color : #585858 ;
Border-Top: Thin Solid #B0B0B0 ; Border-Left: Thin Solid #B0B0B0;
Border-Right: Thin Solid #101010 ; Border-Bottom: Thin Solid #101010;
}
.styText {
Position : Absolute ;
Font-Family : Arial ; Font-Size : 12 ;
Color : #D0D0D0 ;
}
</STYLE>
<XML:NAMESPACE NS="URN:Schemas-Microsoft-COM:VML" PREFIX="V" />
</HEAD>
<BODY SCROLL="No"></BODY>
<SCRIPT LANGUAGE="VBScript">
Option Explicit
'-----------------
'Cubeworld V0.9
'By Alan Bond 2011
'-----------------
'-------------------- Speed constants --------------------
''00 Globals
Const intStartDepth = 2 'How many depths to draw 0-12 (optimum 2) Zero is the largest (width & height to)
Const intStartWidth = 1 'How many VMLs horizontal 0-7 (optimum 1)
Const intStartHeight = 2 'How many VMLs vertical 0-7 (optimum 4)
'width and height add two VMLs on each side (to keep the size odd) and so are only half the max viewport size.
'(Check the Info tab for after loading for better reports)
'Remember, a "depth" can have a possible 17x17 VMLs in it, times that by 13 and you have a huge viewport which may be
'too slow in complex scenes (still good start-up speeds though)
Const intLOD = 3 'Curve detail. Works like modern PC games "LOD" (gets more detailed the closer it is)
'0.45 = Default, 8 = Fast, but curves looks bad. WARNING!...Entering 0 here will crash the
'program when a curve is drawn (a VML extrusion bug)
Const intMaxSpinners = 30 'Spinners are like Quake pickups that spin in realtime. Any over this number will appear
'frozen (but you can still collect them)
Const blnSkyGradients = True 'Two gradients for the sky and floor. CPU intensive but look good for outside scenes
Const intKeyLockDelay = 250 'How long to pause for after moving (MS). Gets choppy if faster than the scene can draw.
'250 = Optimal for a normal Pentium 4 (1 core), so you can probably lower this to 1, However if
'you do the game might be too fast.
Const intBrightness = 0 'This value is added to the fog and the light-switch event. LCD monitors should use 0, and
'older tube monitors should use .5 upwards (doesn't change sky\floor gradients)
Const blnSAMSound = True 'TTS speech sound FX. You'll lose audio cues if switched off, like traps.
'-------------------- Globals --------------------
'---- VML Globals
Const intViewMaxWidth = 16 'Max VML counts in X,Y,Z
Const intViewMaxHeight = 16 '(Over 16 for width or height makes the blocks look too stretched)
Const intViewMaxDepth = 12
Dim vmlShape(16,16,12) 'All VML shapes and extrusions in X,Y,Z
Dim vmlExtru(16,16,12)
Dim strPaths(255) 'Array of 2D shape data, used to make 3D shapes
Dim strPathNames(255) 'Each path needs a description for the editor
Dim intColTab(512,2) 'Hardcoded colour\Wireframe data
Dim strDuelColours(255) 'User duel colours
Dim intBackDepth 'The backdepth for all VMLs, changes per depth
Dim intBackDepthThin(12) 'Like intBackDepth but much thinner (for Spinners)
Dim RenderDir(23,3,2) 'Rotation table for VMLs (24 angles with 4 directions and 3 XYZ coords)
Dim strLight(3,1) 'Two lights per VML for NESW lighting
'---- Dictionaries
Dim dctWorldSpace 'Dictionary for the world space
Dim dctEvents 'For multiple world exits and trigger-event pairs (temporary, for speed checking)
Dim dctPlayerStatus 'For the player status (which world you are in, what keys you own etc). Used in a savegame.
'---- World header
Dim strFogExe 'Used to Execute the fog algorithm (your own code)
Dim lngInvisibleFloor 'Position in Y of an invisible floor you can't fall through (default 0)
Dim strDefaultWP 'Default world header
'---- Camera & keys
Dim intCamX 'Where the camera\player is in the world
Dim intCamY '
Dim intCamZ '
Dim intCamDirection 'Render direction, North=0, East=1, South=2, West=3 (up,down to do)
Dim intInputDX 'For cursor+page keys
Dim intInputDY '
Dim intInputDZ '
Dim intKeyLock 'For locking the keyboard (and speed throttle)
Dim intEditMode 'What mode we are in edit=1, live=0
Dim intRelDir(3,4) 'Movement key offsets, relative to each NESW direction (including strafe)
'---- GUI
Dim objCTRL(53) 'Every control except the grid
Dim Grid(10,10,1) 'Grid of 11x11 DIVs & 2D VML icons
Dim intEditCamX 'Where you are in the edit world (separate from camera)
Dim intEditCamY '
Dim intEditCamZ '
Dim intDrawMode 'For mouse-down\up drawing
Dim intOnionDir 'Changes the grid onion skin direction (default down)
Dim intCurBookMark 'Current bookmark
Dim intRecurse 'For label clicking
Dim intEditWarn 'For live mode to edit mode warning (only from a continued game)
Dim intBoxX 'For drawing large boxes of blocks in the editor
Dim intBoxY '
Dim intBoxZ '
'---- Files
Dim FSO 'File system object
Dim strFullDir 'Directory and filename of this HTA (used once)
Dim strHTADir 'Directory of this HTA
Dim strCW 'For msgbox titles
'---- Game
Dim strRoomName 'Used to show the title of the world after entering, helpful if you're lost
Dim strColNames 'The first 10 colours have names
Dim intSwitchToggle 'For the toggle switch....to swap opposite states
Dim intWorldLights 'Is the world in darkness?
Dim intMoveAfterFilter 'For moving the camera after a DX transition (pressure switch, event camera)
Dim intMoveAfterDX '
Dim intMoveAfterDY '
Dim intMoveAfterDZ '
Dim TTS 'Sound FX
'---- Spinners
Dim invSpinners 'Interval for spinning VMLs
Dim intSpinnerCount 'How many Spinners in the last scene render?
Dim Spinner(255) 'Can rotate up to 255 spinners a once, default 30
Dim intSpinnerRX 'Shared rotation of all spinners.
Dim intSpinnerRY '
Dim intSpinner 'Spinner For..next index (not wise to dim something every 50MS)
'---- Debug
Dim intVMLCount 'How many VMLs are there altogether? (effected by intStartDepth,Width and Height)
Dim intItemsRendered 'How many VMLs in the last render?
Dim sngTimer 'For timing my code
Dim strStartupTime 'Start-up report for info tab
'-------------------- Content --------------------
''01 Content
'---- Paths
'Any path name that starts with a comment, isn't added to the brush list (EG you can't draw with dead switches)
strPaths(0)="RESERVED|M 100,0 L 200,100 150,100 150,200 50,200 50,100 0,100 E 66,90 32,65 76,65 78,32 66,79 78,68"
strPaths(1)="Cube|M 0,0 L 200,0 200,200 0,200"
strPaths(2)="Key round|AR 10,30 80,170 200,0 200,0 XAR 20,40 70,160 200,0 200,0 XM 80,94 L 194,94 194,107 180,107 180,147 167,147 167,107 154,107 154,147 140,147 140,107 80,107"
strPaths(3)="Key triangle|M 14,34 L 74,94 194,94 194,107 180,107 180,140 167,140 167,107 154,107 154,140 140,140 140,107 74,107 14,160 XM 27,60 L 60,94 60,107 27,134"
strPaths(4)="Key Yale|AR 0,50 100,150 200,50 200,150 L 107,127 107,120 134,120 140,127 147,120 147,127 154,127 154,120 167,134 174,120 187,120 200,107 187,94 107,94 107,87 100,94 XAR 20,90 40,110 0,0 0,0"
strPaths(10)="Coin|AR 50,50 150,150 200,0 200,0"
strPaths(20)="Info|AR 0,0 200,200 200,0 200,0 XAR 10,10 190,190 200,0 200,0 XAR 120,30 81,70 200,0 200,0 XM 80,87 L 120,87 120,167 127,167 127,174 74,174 74,167 80,167"
strPaths(21)="Game goal|M 18,75 L 82,75 102,21 122,75 184,75 132,110 152,165 102,131 52,165 70,110"
strPaths(40)="Push block|SMALL|M 16,50 L 50,16 150,16 183,50 183,150 150,183 50,183 16,150"
strPaths(41)="Trap floor \ Secret wall|M 0,0 L 200,0 200,200 0,200 XM 85,200 L 120,165 112,154 75,141 108,148 82,97 127,165 110,180 132,181 105,186 92,200"
strPaths(42)="Coin op. door|M 0,0 L 200,0 200,200 0,200 XM 20,87 L 180,87 180,114 20,114 XM 94,10 L 94,67 100,67 100,10 XM 94,190 L 94,134 100,134 100,190"
strPaths(43)="Quest switch|M 0,0 L 200,0 200,200 0,200 XAR 10,10 190,190 200,0 200,0 XAR 30,30 170,170 200,0 200,0"
strPaths(44)="'Quest switch dead|M 0,0 L 200,0 200,200 0,200 XAR 10,10 190,190 200,0 200,0 XAR 15,15 185,185 200,0 200,0"
strPaths(60)="Locked door inset|SMALL|M 14,80 L 54,80 54,120 14,120 XM 80,80 L 120,80 120,120 80,120 XM 147,80 L 187,80 187,120 147,120"
strPaths(61)="Locked door flush|M 0,0 L 27,0 27,27 0,27 XM 60,0 L 87,0 87,27 60,27 XM 114,0 L 140,0 140,27 114,27 XM 174,0 L 200,0 200,27 174,27 XM 0,174 L 27,174 27,200 0,200 XM 60,174 L 87,174 87,200 60,200 XM 114,174 L 140,174 140,200 114,200 XM 174,174 L 200,174 200,200 174,200"
strPaths(62)="Locked door bars|M 0,20 QY 20,40 40,20 20,0 0,20 XM 80,20 QY 100,40 120,20 100,0 80,20 XM 160,20 QY 180,40 200,20 180,0 160,20 XM 0,180 QY 20,200 40,180 20,160 0,180 XM 80,180 QY 100,200 120,180 100,160 80,180 XM 160,180 QY 180,200 200,180 180,160 160,180"
strPaths(63)="Locked door keyhole|M 0,0 L 200,0 200,200 0,200 XAR 55,20 145,110 200,240 70,120 L 54,180 147,180"
strPaths(70)="Exit arch|M 0,0 L 200,0 200,200 167,200 167,100 C 166,0 34,0 34,100 L 34,200 0,200"
strPaths(71)="Exit Moroccan|M 0,0 L 200,0 200,200 167,200 167,100 C 200,0 0,0 34,100 L 34,200 0,200"
strPaths(72)="Exit pointed|M 0,0 L 200,0 200,200 167,200 167,100 C 50,10 150,10 34,100 L 34,200 0,200"
strPaths(73)="Exit cave|M 0,0 L 200,0 200,200 180,200 187,187 180,180 180,174 187,167 167,140 167,127 174,127 174,120 187,87 174,87 167,80 180,67 154,54 147,40 100,27 57,37 67,54 40,60 34,87 40,87 47,100 34,100 27,127 34,134 40,160 20,180 20,200 0,200"
strPaths(74)="Exit floor \ roof|M 0,0 L 200,0 200,200 0,200 XM 27,27 L 174,27 174,174 27,174"
strPaths(80)="Continuous switch|M 0,0 L 200,0 200,200 0,200 XM 100,20 L 20,100 100,180 180,100 XM 40,100 L 100,40 160,100 100,160"
strPaths(81)="Once switch|M 0,0 L 200,0 200,200 0,200 XM 14,40 L 40,14 160,14 187,40 187,160 160,187 40,187 14,160 XM 27,54 L 54,27 147,27 174,54 174,147 147,174 54,174 27,147"
strPaths(82)="'Once switch dead|M 0,0 L 200,0 200,200 0,200 XM 7,7 L 194,7 194,194 7,194 XM 14,14 L 187,14 187,187 14,187"
strPaths(83)="Toggle switch off|M 0,200 L 34,167 54,167 60,174 67,174 74,167 87,167 87,160 94,160 0,0 14,0 107,160 114,160 114,167 127,167 134,174 140,174 147,167 167,167 200,200"
strPaths(84)="Toggle switch on|M 0,200 L 34,167 54,167 60,174 67,174 74,167 87,167 87,160 94,160 187,0 200,0 107,160 114,160 114,167 127,167 134,174 140,174 147,167 167,167 200,200"
strPaths(85)="Pressure pad|M 0,0 L 80,0 87,7 114,7 120,0 200,0 200,80 194,87 194,114 200,120 200,200 120,200 114,194 87,194 80,200 0,200 0,120 7,114 7,87 0,80 XM 7,7 R 20,0 0,20 -20,0 XM 174,7 R 20,0 0,20 -20,0 XM 174,174 R 20,0 0,20 -20,0 XM 7,174 R 20,0 0,20 -20,0"
strPaths(86)="'Pressure pad down||M 7,14 L 14,7 80,7 87,0 114,0 120,7 187,7 194,14 194,80 200,87 200,114 194,120 194,187 187,194 120,194 114,200 87,200 80,194 14,194 7,187 7,120 0,114 0,87 7,80"
strPaths(100)="Stair basic|M 0,0 L 40,0 40,40 80,40 80,80 120,80 120,120 160,120 160,160 200,160 200,200 0,200"
strPaths(101)="Stair fine|M 0,0 L 20,0 20,20 40,20 40,40 60,40 60,60 80,60 80,80 100,80 100,100 120,100 120,120 140,120 140,140 160,140 160,160 180,160 180,180 200,180 200,200 0,200"
strPaths(102)="Stair thin|M 0,0 L 40,0 40,40 80,40 80,80 120,80 120,120 160,120 160,160 200,160 200,200"
strPaths(103)="Stair tech|M 0,0 L 34,0 34,34 67,67 100,67 100,100 134,134 167,134 167,167 200,200 0,200"
strPaths(104)="Stair Gothic|M 0,0 L 40,0 40,7 27,7 27,40 80,40 80,47 67,47 67,80 120,80 120,87 107,87 107,120 160,120 160,127 147,127 147,160 200,160 200,167 187,167 187,187 200,200 0,200"
strPaths(105)="Stair rounded|M 0,0 L 20,0 QX 40,20 L 40,40 60,40 QX 80,60 L 80,80 100,80 QX 120,100 L 120,120 140,120 QX 160,140 160,160 180,160 QX 200,180 L 200,200 0,200"
strPaths(106)="Slope|M 0,0 L 200,200 0,200"
strPaths(107)="Slope thin|M 0,0 L 200,200 198,200 0,2"
strPaths(108)="Slope tech 1|M 0,0 L 47,47 34,60 47,74 60,60 140,140 127,154 140,167 154,154 200,200 0,200"
strPaths(109)="Slope tech 2|M 0,0 L 90,90 60,120 20,120 20,180 80,180 80,140 110,110 200,200 0,200 XM 100,150 L 110,140 150,180 100,180 XM 20,100 L 50,100 60,90 20,50"
strPaths(110)="Slope frame|M 0,0 L 200,200 0,200 XM 14,34 L 87,107 14,180 XM 100,120 L 167,187 34,187"
strPaths(111)="Slope rung|M 0,0 L 27,27 34,20 47,20 47,34 40,40 94,94 100,87 114,87 114,100 107,107 154,154 160,147 174,147 174,160 167,167 200,200 0,200"
strPaths(112)="Slope roof|M 0,0 L 60,27 60,34 34,34 34,34 94,60 94,67 67,67 127,94 127,100 100,100 160,127 160,134 134,134 200,167 200,174 174,174 200,200 0,200"
strPaths(113)="Slope aqua 1|M 0,0 QY 100,100 QX 200,200 L 0,200"
strPaths(114)="Slope aqua 2|M 0,0 QX 40,40 80,80 120,120 160,160 200,200 L 0,200"
strPaths(115)="Slope curve|M 0,0 QX 200,200 L 0,200"
strPaths(116)="Slope cave 1|M 0,0 L 7,3 14,22 24,24 41,23 53,41 61,58 56,91 72,93 107,97 116,106 126,127 132,143 157,148 160,160 172,188 200,200 0,200"
strPaths(117)="Slope cave 2|M 0,0 L 39,5 49,18 65,16 113,23 138,41 126,46 129,51 162,49 175,62 181,79 192,90 168,107 181,114 187,117 177,136 186,154 182,177 200,200 0,200"
strPaths(150)="Cube frame|M 0,0 L 200,0 200,200 0,200 XM 14,14 L 187,14 107,94 94,94 XM 14,187 L 187,187 107,107 94,107 XM 187,34 L 187,167 127,107 127,94 XM 14,167 L 14,34 74,94 74,107"
strPaths(151)="Chamfer box x4|M 0,30 QY 30,0 L 170,0 QX 200,30 L 200,170 QY 170,200 L 30,200 QX 0,170"
strPaths(152)="Chamfer box x2|M 0,30 QY 30,0 L 170,0 QX 200,30 L 200,200 0,200"
strPaths(153)="Chamfer box x1|M 0,30 QY 30,0 L 200,0 200,200 0,200"
strPaths(154)="Chamfer box rev|M 0,30 QX 30,0 L 170,0 QY 200,30 L 200,170 QX 170,200 L 30,200 QY 0,170"
strPaths(160)="Cylinder 200|AR 0,0 200,200 200,0 200,0"
strPaths(161)="Cylinder 150|SMALL|AR 25,25 175,175 200,0 200,0"
strPaths(162)="Cylinder 100|SMALL|AR 50,50 150,150 200,0 200,0"
strPaths(163)="Tube 200|AR 0,0 200,200 200,0 200,0 XAR 25,25 175,175 200,0 200,0"
strPaths(164)="Cylinder tech|M 0,0 L 20,0 0,20 XM 180,0 L 200,0 200,20 XM 200,180 L 200,200 180,200 XM 20,200 L 0,200 0,180 XAR 25,25 175,175 200,0 200,0"
strPaths(165)="Curve wall 200|WA 0,0 200,200 00,100 200,100 L 200,200 0,200"
strPaths(166)="Cog\Column 200|M 100,0 L 100,14 134,20 140,7 167,27 160,40 174,60 187,54 200,94 187,94 180,127 194,134 174,167 160,160 134,180 140,194 100,200 100,187 67,180 60,194 27,167 40,160 20,127 7,134 0,100 14,100 20,67 7,60 27,34 34,40 67,20 60,7"
strPaths(170)="Space corridor 1|M 0,0 L 200,0 200,20 180,40 180,160 200,180 200,200 0,200 0,20"
strPaths(171)="Space corridor 2|M 0,0 L 200,0 200,40 150,70 150,90 160,90 160,110 150,110 150,130 200,160 200,200 0,200"
strPaths(172)="Gothic wall|M 0,0 L 187,0 187,14 174,14 174,140 180,140 180,147 187,147 187,194 200,194 200,200 0,200"
strPaths(173)="Skirting board|M 0,0 L 187,0 187,27 194,27 194,40 187,40 187,174 194,174 194,187 200,187 200,200 0,200"
strPaths(174)="Wall in-curve|M 0,0 L 200,0 QX 100,100 200,200 L 0,200"
strPaths(175)="Padded cell|M 0,0 QX 40,20 70,0 100,20 130,0 160,20 200,0 L 200,200 0,200"
strPaths(176)="Wall aqua|M 0,50 QY 50,0 100,50 150,90 200,50 L 200,200 0,200"
strPaths(177)="Wall Cave 1|M 0,0 L 200,0 130,32 157,41 145,53 167,65 188,83 163,90 142,111 165,120 180,132 173,147 158,153 149,173 200,200 0,200 X E"
strPaths(178)="Wall Cave 2|M 0,0 L 200,0 191,44 162,59 130,65 148,81 136,94 163,111 159,127 136,149 123,136 117,161 144,180 167,163 169,183 200,200 0,200 X E"
strPaths(179)="Wall Cave 3|M 0,0 L 0,0 200,0 170,31 186,54 171,58 179,67 172,86 187,93 182,116 171,119 163,140 178,146 190,158 179,176 191,185 200,200 0,200 X E"
strPaths(190)="Railings|SMALL|M 0,87 R 14,0 0,13 -14,0 XM 34,87 R 14,0 0,13 -14,0 XM 67,87 R 14,0 0,13 -14,0 XM 100,87 R 14,0 0,13 -14,0 XM 134,87 R 14,0 0,13 -14,0 XM 167,87 R 14,0 0,13 -14,0"
strPaths(191)="Window 1|M 0,0 L 200,0 200,200 0,200 XM 20,20 L 180,20 180,90 20,90 XM 20,110 L 180,110 180,180 20,180"
strPaths(192)="Window 2|M 0,0 L 200,0 200,200 0,200 XM 110,20 QX 180,80 L 110,80 XM 90,20 QX 20,80 L 90,80 XM 180,100 L 110,100 110,180 180,180 XM 20,100 L 90,100 90,180 20,180"
strPaths(193)="Sofa|SMALL|M 50,50 QX 70,150 130,140 200,170 180,180 L 180,200 170,200 170,180 50,180 40,200 30,200 40,180 QX 20,50 X"
strPaths(240)="Frame|SMALL|M 0,0 L 10,0 0,10 X M 190,0 L 200,0 200,10 X M 200,190 L 200,200 190,200 X M 0,190 L 10,200 0,200"
strPaths(255)="EDITOR BOOKMARK|M 60,50 L 130,50 QX 160,80 130,110 160,140 130,170 L 60,170 XM 70,60 L 135,60 QX 150,80 120,105 70,105 XM 70,115 L 120,115 QX 150,140 125,160 70,160"
'---- Duel colours. Two colours picked from the hardcoded palette which are used for the extrusion and front face.
'While it's OK for me to make the main palette (I've tested most good\bad colours in Cubeworld), the duel colours
'are user content. There's too many normal colours to mix and match them all, and it's a matter of personal taste.
strDuelColours(0) = "42,21" 'Dark red & white, Good for the "Slope roof" to make house sides
strDuelColours(1) = "00,44" 'Brown floor with Hell below....Doom style
strDuelColours(2) = "22,55" 'Grey and sky blue
strDuelColours(3) = "55,22" 'Reversed grey and sky blue
'-------------------- Start up --------------------
''10 Start
Sub Window_OnLoad()
Dim intStartInEditMode, intAsk, intIndex, intAng, intDir
'---- Get local directory
strFullDir = Replace(Document.URLUnencoded,"file://","")
strHTADir = Left(strFullDir, InstrRev(strFullDir,"\"))
Set FSO = CreateObject("Scripting.FileSystemObject")
strCW = "Cubeworld"
'---- Quick resolution check (I WILL NEVER USE CSS ZOOM EVER AGAIN! V0.1 to V0.8)
If Screen.Width =< 800 Then
MsgBox "Cubeworld needs at least a 1024x768 desktop resolution (sorry!)", 48, strCW
Window.Close
End If
'---- Is there a savegame folder here?
If FSO.FolderExists(strHTADir & "SaveGame") Then
'---- Any savegame files inside?
If FSO.FileExists(strHTADir & "SaveGame\PlayerData.txt") Then
'---- Ask to continue play
intAsk = MsgBox ("Do you want to continue play?" & VBCRLF & VBCRLF & "Yes = Continue" & _
VBCRLF & "No = Delete save game and go to editor" & VBCRLF & "Cancel = Quit", 67, strCW)
If intAsk = 6 Then
intStartInEditMode = 0
'---- Purge savegame folder, go to editor
ElseIf intAsk = 7 Then
FSO.DeleteFolder strHTADir & "SaveGame", True
FSO.CreateFolder strHTADir & "SaveGame"
intStartInEditMode = 1
Else
Window.Close
End If
'---- Savegame folder exists but no saves inside, go to edit mode
Else
intStartInEditMode = 1
End If
'---- Ask to make a folder, start in edit mode if OK
Else
intAsk = MsgBox ("Can I make a SaveGame folder where this HTA is? No quits.", 68, strCW)
If intAsk = 7 Then
Window.Close
Else
FSO.CreateFolder strHTADir & "SaveGame"
intStartInEditMode = 1
End If
End If
'---- Start timing (for the start-up report)
sngTimer = Timer
'---- Create dictionaries
Set dctWorldSpace = CreateObject("Scripting.Dictionary")
Set dctEvents = CreateObject("Scripting.Dictionary")
Set dctPlayerStatus = CreateObject("Scripting.Dictionary")
dctWorldSpace.CompareMode = vbTextCompare
dctEvents.CompareMode = vbTextCompare
dctPlayerStatus.CompareMode = vbTextCompare
'---- Set relative X+Z keys
intRelDir(0,1) = -1 : intRelDir(0,2) = 1 : intRelDir(1,0) = 1 : intRelDir(1,3) = 1
intRelDir(2,1) = 1 : intRelDir(2,2) = -1 : intRelDir(3,0) = -1 : intRelDir(3,3) = -1
'---- Setup VML lights (should these be in the header?)
strLight(0,0) = "1 0 0" : strLight(0,1) = "1 -2 0" 'N
strLight(1,0) = "0 0 -1" : strLight(1,1) = "0 -2 -1" 'E
strLight(2,0) = "-1 0 0" : strLight(2,1) = "-1 -2 0"' S
strLight(3,0) = "0 0 1" : strLight(3,1) = "0 -2 1"' W
'---- Quest colour names
strColNames = Array("red","orange","yellow","green","turquoise","blue","purple","pink","white","black")
'---- Default world file header
strDefaultWP = "Name = Untitled" & VBCRLF & "Fog = (intZ / 18) + 0.4" & VBCRLF & _
"Lite = 1" & VBCRLF & "Grad = Black, Black, Black, Black" & VBCRLF & "Flor = 0"
'---- Backdepths of VMLs for each view depth (and thin version)
intBackDepth = Array(13, 16, 20, 27, 36, 49, 66, 90, 125, 174, 247, 359, 543)
For intIndex = 0 To intViewMaxDepth
intBackDepthThin(intIndex) = intBackDepth(intIndex) / 16
Next
'---- Create a rotation table for 24 angles (each has camera direction offset)
For intAng = 0 To 23
For intDir = 0 To 3
RenderDir(intAng,intDir,0) = 0 : RenderDir(intAng,intDir,1) = 0 : RenderDir(intAng,intDir,2) = 0
If intAng < 8 Then RenderDir(intAng,intDir,0) = 90
Select Case True
Case intAng < 4 : RenderDir(intAng,intDir,1) = ((intAng And 3) * 90) - (intDir * 90)
Case intAng > 3 And intAng < 8 : RenderDir(intAng,intDir,1) = ((intAng And 3) * 90) + (intDir * 90)
Case intAng > 11 And intAng < 16 : RenderDir(intAng,intDir,1) = 90
Case intAng > 15 And intAng < 20 : RenderDir(intAng,intDir,1) = 180
Case intAng > 19 : RenderDir(intAng,intDir,1) = 270
End Select
If intAng > 3 And intAng < 8 Then
RenderDir(intAng,intDir,2) = 180
ElseIf intAng > 7 Then
RenderDir(intAng,intDir,2) = (((intAng + 1) And 3) * 90) - (intDir * 90)
End If
Next
Next
'---- Sound FX
If blnSAMSound Then
Set TTS = CreateObject("Sapi.SpVoice")
Set TTS.Voice = TTS.GetVoices.Item(0)
End If
'---- Start the build process
BuildCTRLs 'Build interface
SetupViewport 'Add the VMLs
ProcessContent 'Reduce path sizes, format colours and add them to listboxes
RefreshWorldFiles 'Update local worlds listbox
'---- Misc
Document.Title = strCW & " - By Alan Bond"
intOnionDir = 1 'Onion skin downwards
intSpinnerRX = 0 : intSpinnerRY = 0 ' Spinners needs a value
intCurBookMark = 0
'---- Start-up report (see Info bar)
sngTimer = Timer - sngTimer
strStartupTime = "CW startup time = " & sngTimer & VBCRLF & "Viewport size XYZ = " & 17 - (intStartWidth*2) & _
"," & 17 - (intStartHeight*2) & "," & 13 - intStartDepth & VBCRLF & "Total viewport VML count = " & intVMLCount
objCTRL(35).Value = strStartupTime
'---- Start in edit mode
If intStartInEditMode Then
objCTRL(0).Style.Display = "Block" 'Show editor
'---- If you have a world called START.CW in this folder then auto load it.
If FSO.FileExists(strHTADir & "start.cw") Then
objCTRL(41).Value = "Start"
ClearWorld 1 'For camera reset really
LoadWorld strHTADir & "start.cw"
'---- Edit mode with an empty world
Else
objCTRL(33).Value = strDefaultWP 'Set default header
UpdateWorldProps
ClearWorld 1
End If
intEditMode = 1 : intEditWarn = 0
Message "Welcome to Cubeworld",5
'---- Or continue playing the game
Else
objCTRL(0).Style.Display = "None" 'Hide editor
invSpinners = Window.SetInterval ("Spinners", 50) ' Start Spinners
LoadPlayerStatus
LoadWorldCopy
intEditMode = 0 : intEditWarn = 1
UnLockKeys 'In case you saved while falling!
End If
objCTRL(0).Style.Left = 5 'Move editor into view last (this stops listboxes drawing 1st)
'---- Draw the 1st scene (rest of the game is keyboard driven)
RenderScene intCamDirection
End Sub
'-------------------- Build GUI --------------------
''15 BuildCTRLs
Sub BuildCTRLs()
Dim strCTRLData
Dim strCTRL
Dim intIndex, intX, intY
Dim strSplit
Dim strHelp, strRepHelp
strCTRLData = Array("DIV,Document.Body,,B,-9999,1,258,744,","DIV,0,,B,14,48,224,224,","DIV,Document.Body,,T,0,0,720,720,", _
"DIV,2,,T,0,0,720,360,","DIV,2,,T,0,360,720,360,","DIV,0,,B,1,303,251,435,","DIV,0,,B,1,303,251,435,", _
"DIV,0,,B,1,303,251,435,","DIV,0,,B,1,303,251,435,","","BUTTON,0,Brush,B,1,283,63,20,","BUTTON,0,Header,B,64,283,63,20,", _
"BUTTON,0,Files,B,127,283,63,20,","BUTTON,0,Info,B,190,283,63,20,","LABEL,0,Grid follows cam,T,30,5,100,20,", _
"_CHECKBOX,0,,T,9,1,20,20,","LABEL,0,Reverse onion skin,T,30,25,110,20,","_CHECKBOX,0,,T,9,21,20,20,","","", _
"LABEL,5,Path,T,5,3,50,20,","SELECT,5,,B,5,20,153,385,","LABEL,5,Angle \ Colour,T,155,3,180,20,", _
"SELECT,5,,B,155,20,30,385,","SELECT,5,,B,182,20,60,385,","LABEL,5,Paint mode,T,24,408,100,20,", _
"_CHECKBOX,5,,T,3,404,20,20,","","","","BUTTON,0,5,B,219,3,20,20,Move grid up","BUTTON,0,6,B,219,23,20,20,Move grid down", _
"BUTTON,0,.,B,199,3,20,20,Show scene in wireframe","TEXTAREA,6,HEADER,B,3,23,243,406,","BUTTON,6,Refresh,B,3,3,243,20,", _
"TEXTAREA,8,INFO,B,3,23,243,160,","BUTTON,8,Count blocks,B,3,3,243,20,","LABEL,8,Help,T,3,186,100,20,", _
"TEXTAREA,8,HELP,B,3,203,243,226,","","LABEL,7,Current world,T,3,3,100,20,","INPUT,7,,B,3,20,192,20,", _
"BUTTON,7,Save,B,195,20,50,20,","LABEL,7,Auto-save,T,172,44,100,20,Saves when going to live mode, loading or quitting", _
"_CHECKBOX,7,,T,227,40,20,20,","LABEL,7,Local worlds,T,3,68,80,20,","SELECT,7,,B,2,85,243,320,", _
"BUTTON,7,Clear world,B,164,400,80,25,","V:SHAPE,1,,T,0,0,12,12,","LABEL,Document.Body,,T,0,0,10,10,", _
"LABEL,Document.Body,,T,600,0,300,25,","BUTTON,0,B,B,199,23,20,20,Jump to bookmark", _
"LABEL,5,Shadow mode,T,144,408,100,20,","_CHECKBOX,5,,T,224,404,20,20,")
'---- Build control array
For intIndex = 0 to UBound(strCTRLData)
If strCTRLData(intIndex) <> "" Then
strSplit = Split(strCTRLData(intIndex),",") : strCTRL = strSplit(0)
'---- Wrap an <INPUT> around control type (for checkboxes etc)
If Instr(strCTRL,"_") Then strCTRL = Replace(strCTRL,"_","<INPUT TYPE='") & "' />"
Set objCTRL(intIndex) = Document.CreateElement(strCTRL)
'---- Add control to parent
If IsNumeric(strSplit(1)) Then
objCTRL(Int(strSplit(1))).AppendChild objCTRL(intIndex) 'Another control array is the parent
Else
Execute strSplit(1) & ".AppendChild objCTRL(intIndex)" 'Standard text parent (doc body etc)
End If
'---- Setup control
With objCTRL(intIndex)
.ID = intIndex : .TabIndex = -1
With .Style
.Left = strSplit(4) : .Top = strSplit(5)
.Width = strSplit(6) : .Height = strSplit(7)
End With
Set .OnClick = GetRef("CTRLClick") 'Add click event
If strSplit(8) <> "" Then .Title = strSplit(8) 'Tooltip
'---- Button or text label class?
If strSplit(3) = "T" Then .ClassName = "styText" Else .ClassName = "styButton"
'---- Default properties per control type
Select Case LCase(strSplit(0))
Case "button", "input", "_password"
.Value = strSplit(2)
Case "textarea"
.Value = strSplit(2)
.Style.ScrollbarBaseColor = "#585858" '<- Doesn't work in <HEAD> CSS!?
Case "label"
.InnerText = strSplit(2)
Case "select"
.Size = 2
Set .OnMouseOut = GetRef("MouseOutCTRL") 'No CRSR-keys outside of any list
Case "div"
.Style.OverFlow = "Hidden"
End Select
End With
End If
Next
'---- Position editor
objCTRL(0).Style.Top = (Screen.Height/2) - 372
'---- Grid up\down buttons & wireframe use webding font
For intIndex = 30 To 32
objCTRL(intIndex).Style.FontFamily = "Webdings"
objCTRL(intIndex).Style.LineHeight = 1.3
Next
'---- Grid mouse cursor
objCTRL(1).Style.Cursor = "Crosshair"
objCTRL(24).Style.FontWeight= "Bold"
'---- Start in brush tab
objCTRL(5).Style.Visibility = "Visible"
For intIndex = 6 To 8
objCTRL(intIndex).Style.Visibility = "Hidden"
Next
'---- Start in info tab (for me really)
'objCTRL(8).Style.Visibility = "Visible"
'For intIndex = 5 To 7
' objCTRL(intIndex).Style.Visibility = "Hidden"
'Next
'---- Local worlds listbox OnChange event (onClick is worse)
Set objCTRL(46).OnChange = GetRef("QuickTravel")
'---- Camera icon (uses the strPaths(0) shape)
With objCTRL(48)
.Path = strPaths(0) : .CoordSize = "200 200"
.Style.ZIndex = 9999 : .Style.Position = "Absolute"
End With
UpdateCamIcon
'---- Sky & floor ZIndex
objCTRL(3).Style.Zindex = -99999 : objCTRL(4).Style.Zindex = -99999
'---- Game message with 2 filters
With objCTRL(49)
With .Style
.TextAlign = "Center" : .FontFamily = "Arial" : .FontSize = 20 : .Color ="White"
.Filter = "ProgID:DXImageTransform.Microsoft.Glow ProgID:DXImageTransform.Microsoft.Fade"
End With
.Filters(0).Color = "#0000FF" : .Filters(0).Strength = 2
End With
'---- Make a VML edit grid
For intY= 0 to 10
For intX= 0 to 10
Set Grid(intX,intY,0) = Document.CreateElement("DIV")
Set Grid(intX,intY,1) = Document.CreateElement("V:SHAPE")
objCTRL(1).AppendChild Grid(intX,intY,0)
Grid(intX,intY,0).AppendChild Grid(intX,intY,1)
With Grid(intX,intY,0)
Set .OnMouseMove = GetRef("GridMove") 'Every grid cell has a mouse-over event (for fast coods)
Set .OnMouseDown = GetRef("GridClick") 'For drawing
Set .OnMouseWheel = GetRef("GridWheel") 'For mouse wheel rotate
With .Style
.Position = "Absolute" : .OverFlow = "Hidden"
.BackGroundColor = "#1A1A1A" : .Border = "1 Solid #404040"
.Width = 20 : .Height = 20 : .Left = intX * 20 : .Top = intY * 20
End With
End With
With Grid(intX,intY,1)
.CoordSize = "250 250" : .Style.Width = 20 : .Style.Height = 20
End With
Next
Next
'---- Fill quick help
strHelp = "#Game keys##[CRSR] = Move or turn camera#[CTRL+CRSR] = Side step (strafe)#[PGUP][PGDN] " & _
"= Fly (only in edit mode)#[SPACE] = Reload last savegame (if stuck)#[ESC] = Save progress and quit" & _
"#_Editor keys \ mouse##[TAB] = Toggle edit \ live mode#[LMB] = Draw a @#[RMB] = Delete a @#[MMB] =" & _
" Move 3D camera to 2D position#[WHEEL] = Rotate @ under cursor#[CTRL+LMB] = Grab a @ (eye dropper)" & _
"#[SHIFT+LMB] = Draw a 3D square of @s#[CRSR] = Move the grid in X+Z#[PGUP][PGDN] = Move the grid i" & _
"n Y#[HOME] = Jump to 3D camera#[CTRL+S] = Save current ~#[ESC] = Save and quit (if autosave is on)" & _
"##Hover the mouse on the grid to see @ info and coordinates#_World header##Name = Shown after ente" & _
"ring a ~#Fog = A formula that uses intX,Y,Z#Lite = World lights (1 = on, 0 = off)#Grad = Four col" & _
"ours for the sky & floor#Flor = Invisible floor Y position#Info = Text for info pick-ups#Exit =" & _
" Exits to other ~s#Swit = Switch events#_Exits and switches##You can have multiple exits and switc" & _
"hes, each need 7 values:-##Exit = X1, Y1, Z1, Filename, *#X1, Y1, Z1 = Position of exit in this ~#" & _
"Filename = Destination ~ filename#* = Destination camera position##Switch = X1, Y1, Z1, Event, *#X" & _
"1, Y1, Z1 = Position of switch#Event = Event name#* = Location of event#_Events##DEL#Delete a @ at" & _
" *#No <##ADD\PT\AN\CT#Add a @ (Path \ Angle \ Colour) at *#No <##TOG\PT\AN\CT#Add or delete @#Can " & _
"<##MOV\DX\DY\DZ#Move @ using DX\DY\DZ#Can < (returns to original place)##SWP\X\Y\Z#Swap @ at X\Y\Z" & _
" with *#Can swap two @s or a @ and empty space#Can <##WDC\PT\AN\CT, PT,AN,CT#Scans all the ~, if f" & _
"inds \PT\AN\CT then replace with * Can <, but might not revert to 100% previous state##TEL#Telepor" & _
"t camera to *#No <##DRK#World lights off (* unused)#No <##LIT#Lights on (returns to Fog settings)#" & _
"No <##LSW#Light switch#Can <#_Example:-#Swit = 0,-1,0, ADD\100\8\36, 0,10,0##If you press the swit" & _
"ch at 0,-1,0 then a blue stair is added at 0,10,0##Have fun!"
strRepHelp = Array("_", VBCRLF & String(20,"—") & VBCRLF ,"#",VBCRLF , "*","X2, Y2, Z2", "@","block", _
"~","world", "<","toggle")
For intIndex = 0 To UBound(strRepHelp) Step 2
strHelp = Replace(strHelp, strRepHelp(intIndex), strRepHelp(intIndex + 1))
Next
objCTRL(38).Style.Fontsize = 11
objCTRL(38).Value = strHelp
End Sub
'-------------------- Setup viewport --------------------
''20 Setup viewport
Sub SetupViewport()
Dim intX, intY, intZ
Dim intSize
Dim intDrawOffset
Dim intSkipOffset1
Dim intSkipOffset2
Dim intViewPoint
'The size of each VML, X+Y draw offsets and camera focal length (per depth)
intSize = Array(16, 21, 27, 36, 48, 65, 88, 120, 166, 232, 330, 479, 723 )
intDrawOffset = Array(-229, -187, -136, -60, 42, 186, 381, 653, 1044, 1605, 2438, 3704, 5778 )
intViewPoint = Array(13.5, 16.5, 21, 27, 36, 48, 64.5, 85.5, 114, 153, 205.5, 277.5, 375)
'Most large shapes are out of the viewport, this simple table lets me skip creating any that you can't see,
'reducing the VML count\startup time and increasing step speed
intSkipOffset1 = Array(0, 0, 0, 0, 0, 1, 1, 4, 5, 5, 6, 7, 7)
intSkipOffset2 = Array(16, 16, 16, 16, 16, 15, 14, 12, 11, 11, 10, 9, 9)
'---- Setup viewport DIV
With objCTRL(2).Style
.Left = (Screen.Width/2) - (.PixelWidth/2)
.Top = (Screen.Height/2) - (.PixelWidth/2)
.Border = "1 Solid #606060"
'---- 1024x768 resolution fixer (no centreing yet)
If .PixelLeft < objCTRL(0).Style.PixelWidth then
.Left = objCTRL(0).Style.PixelWidth + 10
End If
'---- The game message is not in the viewport because it has two filters, so just place on top.
objCTRL(49).Style.Width = .PixelWidth
objCTRL(49).Style.Left = .PixelLeft
objCTRL(49).Style.Top = .PixelTop + 40
End With
'---- Render info label
With objCTRL(50)
.Style.Top = objCTRL(2).Style.PixelTop - 20
.Style.Left = objCTRL(2).Style.PixelLeft
End With
'---- Add VMLS
For intZ = intStartDepth To intViewMaxDepth
For intY = 0 To intViewMaxHeight
'---- Top\bottom within Y range?
If intY => intSkipOffset1(intZ) And intY <= intSkipOffset2(intZ) And intY => intStartHeight And intY =< intViewMaxHeight - intStartHeight Then
For intX = 0 To intViewMaxWidth
'----Left\right within X range?
If intX => intSkipOffset1(intZ) And intX <= intSkipOffset2(intZ) And intX => intStartWidth And intX =< intViewMaxWidth - intStartWidth Then
'---- OK to create VML shape + extrusion
Set vmlShape(intX, intY, intZ) = Document.CreateElement("V:SHAPE")
objCTRL(2).AppendChild vmlShape(intX, intY, intZ)
Set vmlExtru(intX, intY, intZ) = Document.CreateElement("V:EXTRUSION")
vmlShape(intX, intY, intZ).AppendChild vmlExtru(intX, intY, intZ)
'---- Default shape properties
With vmlShape(intX, intY, intZ)
.CoordSize = "200 200" : .StrokeColor = "White"
With .Style
.Position = "Absolute"
.Left = (intX * ( intSize(intZ) - 1 )) - intDrawOffset(intZ)
.Top = (intY * ( intSize(intZ) - 1)) - intDrawOffset(intZ)
.Width = intSize(intZ) : .Height = intSize(intZ)
'---- Right side of middle block needs reverse Zindex
If intX > (intViewMaxWidth / 2) Then
.Zindex = -intX
End If
'---- So does below middle (and right)
If intY > (intViewMaxHeight / 2) Then
If intX > (intViewMaxWidth / 2) Then
.Zindex = -(intX * intY)
Else
.Zindex = -intY
End If
End If
End With
End With
'---- Default extrusion properties
With vmlExtru(intX, intY, intZ)
.On = 1 : .AutoRotationCenter = 1 : .Type = 2
.ColorMode = 2 : .Edge = 0
.Facet = intLOD ' See speed constants (don't put zero here!)
'---- The new CW V0.9 Angle\Backdepth (very different to 0.8)
.Viewpoint="0mm 0mm " & intViewPoint(intZ) & "mm"
.BackDepth = intBackDepth(intZ)
.ViewpointOrigin = (intViewMaxWidth/2) - intX & " " & (intViewMaxHeight/2) - intY & " 0"
End With
intVMLCount = intVMLCount + 1 ' For debug
End If
Next
End If
Next
Next
End Sub
'-------------------- Worldspace --------------------
''40 Worldspace
'---- Clear the world
Sub ClearWorld(intClearCamera)
dctWorldSpace.RemoveAll
dctEvents.RemoveAll
'---- Reset cameras
If intClearCamera Then
intEditCamX = -5 : intEditCamY = -5 : intEditCamZ = 0
intCamX = 0 : intCamY = 0 : intCamZ = 0 : intCamDirection = 0
UpdateGrid : UpdateCamIcon
End If
End Sub
'---- Set a single worldspace property (1 out of a possible 3)
Sub SetWorld(intX,intY,intZ,strCom,varValue)
dctWorldSpace.Item(intX & "\" & intY & "\" & intZ & "\" & strCom) = varValue
End Sub
'---- Get worldspace property
Function GetWorld(intX,intY,intZ,strCom)
If dctWorldSpace.Exists(intX & "\" & intY & "\" & intZ & "\" & strCom) Then '<--- stops a blank record being made
GetWorld = Int(dctWorldSpace.Item(intX & "\" & intY & "\" & intZ & "\" & strCom))
End If
End Function
'---- Set Block (used in game\editor\loader for creating full blocks in one sub call)
Sub SetBlock(intX,intY,intZ,intIndexPath,intRotation,intIndexColour)
SetWorld intX, intY, intZ, "PT", intIndexPath
SetWorld intX, intY, intZ, "AN", intRotation
SetWorld intX, intY, intZ, "CT", intIndexColour
End Sub
'---- Delete Block (used in game\editor)
'Doesn't plot 0, but instead removes the dictionary item. Needed for world saving\loading
'(no point saving empty data)
Sub DeleteBlock(intX,intY,intZ)
If dctWorldSpace.Exists(intX & "\" & intY & "\" & intZ & "\PT") Then
dctWorldSpace.Remove(intX & "\" & intY & "\" & intZ & "\" & "PT")
dctWorldSpace.Remove(intX & "\" & intY & "\" & intZ & "\" & "AN")
dctWorldSpace.Remove(intX & "\" & intY & "\" & intZ & "\" & "CT")
End If
End Sub
'---- Move Block (used in game)
'Move something at XYZ to XYZ+DirXYZ
Sub MoveBlock(intX,intY,intZ,intDX,intDY,intDZ)
'---- Copy all properties to new position
SetWorld intX+intDX, intY+intDY, intZ+intDZ, "PT", GetWorld(intX, intY, intZ, "PT")
SetWorld intX+intDX, intY+intDY, intZ+intDZ, "AN", GetWorld(intX, intY, intZ, "AN")
SetWorld intX+intDX, intY+intDY, intZ+intDZ, "CT", GetWorld(intX, intY, intZ, "CT")
'---- Delete old position
DeleteBlock intX,intY,intZ
End Sub
'---- Swap two Blocks (used in game)
'Swap something at XYZ to X\Y\Z\
Sub SwapBlock(intX1, intY1, intZ1, intX2, intY2, intZ2)
Dim intTempPT1, intTempAN1, intTempCT1 'Temp tiles
Dim intTempPT2, intTempAN2, intTempCT2
intTempPT1 = GetWorld(intX1, intY1, intZ1, "PT") : intTempPT2 = GetWorld(intX2, intY2, intZ2, "PT")
intTempAN1 = GetWorld(intX1, intY1, intZ1, "AN") : intTempAN2 = GetWorld(intX2, intY2, intZ2, "AN")
intTempCT1 = GetWorld(intX1, intY1, intZ1, "CT") : intTempCT2 = GetWorld(intX2, intY2, intZ2, "CT")
'---- Swap them (If empty space then remove it, don't swap it)
If intTempPT2 Then
SetBlock intX1, intY1, intZ1, intTempPT2, intTempAN2, intTempCT2
Else
DeleteBlock intX1, intY1, intZ1
End If
If intTempPT1 Then
SetBlock intX2, intY2, intZ2, intTempPT1, intTempAN1, intTempCT1
Else
DeleteBlock intX2, intY2, intZ2
End If
End Sub
'---- Find & replace block based on PT\AN\CT in the entire world
'Pretty fast and potentially dangerous in the world change event, use with caution.
Sub WorldChange (intFindPT,intFindAN,intFindCT, intRepPT,intRepAN,intRepCT)
Dim strKeyArray
Dim strItemArray
Dim strSplit
Dim intIndex
'---- A toggle switch (or the user) is trying to replace empty space
If intFindPT = 0 Then
Msgbox "You are currently trying to replace Empty space [0] with an object." & VBCRLF & _
"The world change event (WDC) can not toggle spaces. Please check your switches.",64, strCW
Exit sub
End If
strKeyArray = dctWorldSpace.Keys : strItemArray = dctWorldSpace.Items
For intIndex = 0 To UBound(strKeyArray) Step 3
'---- Search for item
If Int(strItemArray(intIndex)) = Int(intFindPT) Then
If Int(strItemArray(intIndex + 1)) = Int(intFindAN) Then
If Int(strItemArray(intIndex + 2)) = Int(intFindCT) Then
'---- Found one, replace it and carry on
strSplit = Split(strKeyArray(intIndex),"\")
SetBlock strSplit(0), strSplit(1), strSplit(2), intRepPT, intRepAN, intRepCT
End If
End If
End If
Next
End Sub
'---- Scan world for bookmarks and place camera if found
Sub ScanBookmarks()
Dim intIndex
Dim strKeyArray
Dim strItemArray
Dim strSplit
Dim intThisBookMark
Dim intFound
'---- Empty world?
If dctWorldSpace.Count = 0 Then Exit Sub
'---- Scan for bookmarks
intThisBookMark = 0 : intFound = 0
strKeyArray = dctWorldSpace.Keys : strItemArray = dctWorldSpace.Items
For intIndex = 0 To UBound(strKeyArray) Step 3
'---- Found bookmark, move camera
If strItemArray(intIndex) = 255 Then
intThisBookMark = intThisBookMark + 1
If intCurBookMark = intThisBookMark Then
strSplit = Split(strKeyArray(intIndex),"\")
intCamX = Int(strSplit(0)) : intCamY = Int(strSplit(1)) : intCamZ = Int(strSplit(2))
JumpTo3DCam
RenderScene intCamDirection
intFound = 1
End If
End If
Next
If intFound = 0 Then intCurBookMark = 0
End Sub
'---- Show world block counts
Function CountBlocks()
Dim intIndex
Dim strName
Dim intCoinVal
Dim strKeyArray
Dim strItemArray
Dim dctTempCount
'---- Empty world?
If dctWorldSpace.Count = 0 Then
Msgbox "Nothing to count.", 64, strCW
Exit Function
End If
strKeyArray = dctWorldSpace.Keys : strItemArray = dctWorldSpace.Items
Set dctTempCount = CreateObject("Scripting.Dictionary")
dctTempCount.CompareMode = vbTextCompare
intCoinVal = 0
For intIndex = 0 To UBound(strKeyArray) Step 3
'---- Total coin value
If strItemArray(intIndex) = 10 Then
Select Case strItemArray(intIndex + 2)
Case 2 : intCoinVal = intCoinVal + 3 'Gold coins
Case 8 : intCoinVal = intCoinVal + 2 'Silver coins
Case Else : intCoinVal = intCoinVal + 1 'Bronze and other
End Select
End If
'---- Count items
strName = strPathNames(strItemArray(intIndex))
dctTempCount.Item(strName) = dctTempCount.Item(strName) + 1
Next
'---- Build string
strKeyArray = dctTempCount.Keys : strItemArray = dctTempCount.Items
CountBlocks = "Blocks in world = " & dctWorldSpace.Count / 3 & VBCRLF & _
"Total coin value = " & intCoinVal & VBCRLF & VBCRLF
For intIndex = 0 To UBound(strKeyArray)
CountBlocks = CountBlocks & strKeyArray(intIndex) & " = " & strItemArray(intIndex) & VBCRLF
Next
End Function
'-------------------- World save\load --------------------
''41 Save world
'---- Save
Sub SaveWorld(strWorldFile)
Dim intdctIndex
Dim strKeyArray
Dim strItemArray
Dim intIndex
Dim strLine
Dim objWriteFile
Dim strProps
'---- Empty world?
If dctWorldSpace.Count = 0 Then
Msgbox "Nothing to save.", 64, strCW
Exit Sub
End If
'---- Get filename
If strWorldFile = "" Then
strWorldFile = CheckWorldFile(objCTRL(41).Value)
If strWorldFile = "" Then Exit Sub
End If
'---- Get all the dictionary keys\items
strKeyArray = dctWorldSpace.Keys : strItemArray = dctWorldSpace.Items
Set objWriteFile = FSO.CreateTextFile(strWorldFile,2)
'---- Write world header 1st
strProps = Split(objCTRL(33).Value,VBCRLF)
For intIndex = 0 To UBound(strProps)
Select Case LCase(Left(strProps(intIndex),4))
Case "lite" 'Lights on\off is the only header value saved in live mode.
objWriteFile.WriteLine "Lite = " & intWorldLights
Case Else
objWriteFile.WriteLine strProps(intIndex)
End Select
Next
objWriteFile.WriteLine "WorldData = "
'---- Save worldspace dictionary in steps of 3
For intIndex = 0 To UBound(strKeyArray) Step 3
strLine = strLine & Left(strKeyArray(intIndex),Len(strKeyArray(intIndex))-2) & _
strItemArray(intIndex) & "\" & strItemArray(intIndex + 1) & "\" & strItemArray(intIndex + 2) & " "
If Len(strLine) > 80 Then objWriteFile.WriteLine Trim(strLine) : strLine="" '80 column mode
Next
If Len(strLine) < 81 Then objWriteFile.WriteLine Trim(strLine)
objWriteFile.Close
End Sub
'---- Load
Sub LoadWorld(strWorldFile)
Dim objReadFile
Dim strLine
Dim intIndex
Dim strSplit
Dim strVal
Dim intProperties
'---- Clear the current world 1st
objCTRL(33).Value = "" 'World header
intCurBookMark = 0 'clear bookmark
If intEditMode Then
ClearWorld 1
Else
ClearWorld 0 'Don't clear camera in live mode
End If
'---- Load it
intProperties = 1
Set objReadFile = FSO.OpenTextFile(strWorldFile, 1)
Do While Not objReadFile.AtEndOfStream
'---- World header goes to the textarea (even in live mode)
If intProperties Then
strLine = Trim(objReadFile.ReadLine)
If LCase(Left(strLine,9)) = "worlddata" Then
intProperties = 0
Else
If strLine<>"" Then objCTRL(33).Value = objCTRL(33).Value & strLine & VBCRLF
End If
'---- World data
Else
strSplit = Split(objReadFile.ReadLine, " ")
For intIndex = 0 To UBound(strSplit)
strVal = Split(strSplit(intIndex),"\")
SetBlock strVal(0),strVal(1),strVal(2),strVal(3),strVal(4),strVal(5)
Next
End If
Loop
objReadFile.Close
'---- Update world header and grid
UpdateWorldProps
UpdateGrid
'---- Show location name in live mode
If intEditMode = 0 Then Message strRoomName, 5
End Sub
'---- Check filename
Function CheckWorldFile(strFile)
CheckWorldFile = ""
'---- "Are you local?" error
If inStr(strFile,":") or inStr(strFile,"\") Then
Msgbox "You only need to supply a single filename with no path or extension.", 64, strCW
Exit Function
ElseIf strFile = "" Then
Exit Function
End If
'---- Add HTA's path, If user added extension then take it off and add it again. :-)
CheckWorldFile = strHTADir & Replace(strFile,".cw","",1,-1,1) & ".cw"
End Function
'---- Update all the world files in the list (used at start and after saving)
Sub RefreshWorldFiles()
Dim objFolder, objFile, objOption, intIndex
With objCTRL(46)
'---- Clear list
For intIndex = 0 To .Length
.Remove 0
Next
'---- Add .CW files (alphabetical sorting to do)
Set objFolder = FSO.GetFolder(strHTADir)
For Each objFile In objFolder.Files
If LCase( Right(objFile.Name,3) ) = ".cw" Then
Set objOption = Document.CreateElement("OPTION")
objOption.Text = Left(objFile.Name, Len(objFile.Name) - 3)
'---- If filename is called "Start.CW", then set to green (this is the start room)
If LCase(objOption.Text) = "start" Then
objOption.Style.Color = "#50FF50"
objOption.Style.BackgroundColor = "#008000"
End If
.Add(objOption)
End If
Next
End With
End Sub
'---- Click a worldfile in the list
Sub QuickTravel()
Dim strFile
'---- Save this world if auto-save
If objCTRL(44).Checked Then SaveWorld ""
'---- Load it
sngTimer = Timer
strFile = Me.Options(Me.SelectedIndex).Text
objCTRL(41).Value = strFile
LoadWorld strHTADir & strFile & ".cw"
'---- Show loading time in Info tab
sngTimer = Timer - sngTimer
objCTRL(35).Value = strStartupTime & VBCRLF & VBCRLF & strFile & ".CW load time = " & sngTimer
RenderScene intCamDirection
End Sub
'---- Update world header textarea (called from LoadWorld, or the world header refresh button)
Sub UpdateWorldProps()
Dim intIndex, strEventXYZ, intTxtMess
Dim strSplitLine, strSplitEquals, strSplitComma
Dim intSF, strCol1, strCol2
'---- Clear all events
dctEvents.RemoveAll
intTxtMess = 0
'---- Scan textarea
strSplitLine = Split(objCTRL(33).Value, VBCRLF)
For intIndex = 0 To UBound(strSplitLine)
'---- Skip empty lines and comment lines
If Trim(strSplitLine(intIndex)) <> "" And Left(Trim(strSplitLine(intIndex)),1) <> "'" Then
strSplitEquals = Split(strSplitLine(intIndex), "=")
'---- Show any equals errors for all lines
If UBound(strSplitEquals) = 0 Then
Msgbox "All world properites need an equals sign after the command:-" & VBCRLF & _
VBCRLF & strSplitLine(intIndex), 16, strCW
Exit Sub
End If
Select Case LCase(Trim(strSplitEquals(0)))
Case "name"
strRoomName = Trim(strSplitEquals(1))
Case "fog"
strFogExe = Trim(strSplitEquals(1))
ChangeVisibleVMLs 3
intWorldLights = ""
Case "flor"
lngInvisibleFloor = CLng(strSplitEquals(1))
Case "lite"
intWorldLights = Int(Trim(strSplitEquals(1)))
If intWorldLights = 0 Then ChangeVisibleVMLs 4 'Do this last or you'll be editing in the dark
Case "info"
dctEvents.Item ("info" & intTxtMess) = Trim(strSplitEquals(1))
intTxtMess = intTxtMess + 1
'---- Update gradients
Case "grad"
strSplitComma = Split(strSplitEquals(1) , ",")
'---- Show any comma errors (or DX crash)
If UBound(strSplitComma) <> 3 Then
Msgbox "SkyFloor needs four arguments.", 16, strCW
Exit Sub
End If
For intSF = 0 To 1
strCol1 = Trim(strSplitComma(intSF * 2))
strCol2 = Trim(strSplitComma((intSF * 2) + 1))
With objCTRL(intSF + 3)
'---- Skip DX Gradient if the same colours, or gradients are disabled
If strCol1 = strCol2 Or blnSkyGradients = False Then
.Style.Filter = ""
.Style.BackGroundColor = strCol1
Else
.Style.Filter = "ProgID:DXImageTransform.Microsoft.Gradient"
.Filters(0).StartColorStr = strCol1
.Filters(0).EndColorStr = strCol2
End If
End With
Next
'---- Duel exit and switch events
Case "exit", "swit"
strSplitComma = Split(strSplitEquals(1) , ",")
'---- Show any comma errors for exit\switch
If UBound(strSplitComma) <> 6 Then
Msgbox "Exits and switches need seven comma delimited values:-" & VBCRLF & _
VBCRLF & strSplitLine(intIndex), 16, strCW
Exit Sub
End If
'---- Add event
strEventXYZ = Trim(strSplitComma(0)) & "\" & Trim(strSplitComma(1)) & "\" & Trim(strSplitComma(2)) & "\"
dctEvents.Item (strEventXYZ & "event") = Trim(strSplitComma(3))
dctEvents.Item (strEventXYZ & "dsx") = Trim(strSplitComma(4))
dctEvents.Item (strEventXYZ & "dsy") = Trim(strSplitComma(5))
dctEvents.Item (strEventXYZ & "dsz") = Trim(strSplitComma(6))
Case Else
Msgbox "Unknown command in world header:-" & VBCRLF & _
VBCRLF & strSplitLine(intIndex), 16, strCW
End Select
End If
Next
End Sub
'---- Do "something" to all the VMLs. Faster than moving\turning as no paths are being set.
Sub ChangeVisibleVMLs(intType)
Dim intX,intY,intZ
For intZ = intStartDepth To intViewMaxDepth
For intY = intStartHeight To intViewMaxHeight - intStartHeight
For intX = intStartWidth To intViewMaxWidth - intStartWidth
If vmlShape(intX, intY, intZ) <> Empty Then
Select Case intType
'---- Roatate all to 45 degrees, as a test
Case 0
vmlShape(intX, intY, intZ).Rotation = 45
'---- Show scene in wireframe
Case 2
vmlExtru(intX, intY, intZ).Render = 2
'---- Set fog (from LoadWorld & events)
Case 3
Execute "vmlExtru(intX, intY, intZ).Diffusity = intBrightness + " & strFogExe
'---- Lights off (from LoadWorld & events)
Case 4
vmlExtru(intX, intY, intZ).Diffusity = intBrightness + 0.1
End Select
End If
Next
Next
Next
End Sub
'-------------------- Process content --------------------
''45 Process paths
Sub ProcessContent()
Dim intIndex, objOption, strSplit, intCount, intCoord, strNewPath
Dim intColourData, strColPak
'---- Single colours:- 10 Quest, 10 quest wireframe , 5 greys, 16 pastel, 16 dark natural
strColPak = "FF0000FF8000FFFF0000FF0000EFEF1C1CFF801CFFFF00FFFFFFFF404040FF0000FF8000FFFF0000FF0000EFEF1C1CFF801CFFFF00" & _
"FFFFFFFF404040E0E0E0C0C0C0A0A0A0808080606060E48B6CFFC1C1C99432B19679D6B59CC9BB23E7DBA3CEFFC19FC98DA6B179C1FFEA89DADFC1" & _
"CDFF89ADDFE6B2ECC59CD66825169C3824683F16995A1D7040304B42116B5C17686B173A4B111357262F7719577B09054751006B82006BD8003C9E"
'---- Paths
For intIndex = 0 to UBound(strPaths)
If strPaths(intIndex) <> "" Then
'---- Split path data with my custom pipe chars
strSplit = Split(strPaths(intIndex),"|")
'---- 1st item is the block name, so add it to the editor list box
Set objOption = Document.CreateElement("OPTION")
If intIndex = 0 Then
objOption.Text = "Empty Space"
Else
objOption.Text = Trim(strSplit(0))
End If
strPathNames(intIndex) = objOption.Text ' Move block name to own array
objOption.Value = intIndex
'---- Don't add block to combobox if commented
If Left(objOption.Text,1) <> "'" Then
'---- Seperate block types by background colour (switches,pickups,architecture etc)
With objOption.Style
Select Case True
Case intIndex < 2 Or intIndex => 200 : .BackGroundColor = "Black"
Case intIndex > 1 And intIndex < 40 : .Color = "White"
Case intIndex => 40 And intIndex < 60, intIndex => 70 And intIndex < 80, intIndex => 100 And intIndex < 150
.BackGroundColor ="#404040"
End Select
End With
objCTRL(21).Add(objOption)
End If
'---- No extra options? Then trim the name, reset strPaths() and add " XE"
intCount = UBound(strSplit)
If intCount = 1 Then
strPaths(intIndex) = Trim(strSplit(1)) & " XE"
'---- Dynamic shape changing
Else
Select Case LCase(Trim(strSplit(1)))
'---- Small shape hotfix
'If a shape is smaller than 200x200, then wrap an invisible border around it. This keeps
'the angle and placement correct. It's not invisible in the 2D grid however (you may see 2
'dots in each corner).
Case "small"
strPaths(intIndex) = "M0,0 L0,0 X " & strSplit(intCount) & " X M200,200 L200,200 XE"
'---- Room for expansion (random scatter etc?)
End Select
End If
End If
Next
objCTRL(21).SelectedIndex = 1 ' Cube is default
'---- Unpack single colours
intCount = 0
For intIndex = 1 to Len(strColPak) Step 6
intColTab(intCount, 0) = "#" & Mid(strColPak, intIndex,6) 'Colour 1
intColTab(intCount, 1) = intColTab(intCount, 0) 'Colour 2 is a copy of 1
Set objOption = Document.CreateElement("OPTION")
'---- Wireframe colour
If intCount>9 And intCount<20 Then
intColTab(intCount, 2) = 1
objOption.Style.Color = intColTab(intCount, 0)
objOption.Style.BackgroundColor = "Black"
'---- Solid colour
Else
intColTab(intCount, 2) = 0
objOption.Style.Color = "Black"
objOption.Style.BackgroundColor = intColTab(intCount, 0)
End If
objOption.Text = intCount
objCTRL(24).Add(objOption)
intCount = intCount + 1
Next
'---- Duel colours
For intIndex = 0 to UBound(strDuelColours)
If strDuelColours(intIndex) = "" Then Exit For
strSplit = Split(strDuelColours(intIndex), ",")
intColTab(intCount, 0) = intColTab(Int(strSplit(0)), 0)
intColTab(intCount, 1) = intColTab(Int(strSplit(1)), 1)
Set objOption = Document.CreateElement("OPTION")
objOption.Style.Color = intColTab(intCount, 0)
objOption.Style.BackgroundColor = intColTab(intCount, 1)
objOption.Text = intCount & " D"
objCTRL(24).Add(objOption)
intCount = intCount + 1
Next
objCTRL(24).SelectedIndex = 22 ' Grey is default
'---- Shadow colours
For intIndex = 256 + 20 to 511
intColTab(intIndex, 0) = Shadow(intColTab(intIndex - 256, 0))
intColTab(intIndex, 1) = Shadow(intColTab(intIndex - 256, 1))
intColTab(intIndex, 2) = intColTab(intIndex - 256, 2)
Next
'----- Angles
intColourData = 0
For intIndex = 0 to 23
Set objOption = Document.CreateElement("OPTION")
objOption.Text = intIndex
If (intIndex And 3) = 0 Then intColourData = intColourData + 1 And 1
If intColourData Then
objOption.Style.BackgroundColor = "#808080"
objOption.Style.Color = "White"
End If
objCTRL(23).Add(objOption)
Next
objCTRL(23).SelectedIndex = 0 ' Angle 0 is default
End Sub
'---- Turn a normal colour to shadow (-32)
Function Shadow (ByVal strColour)
Dim intIndex, strNum
If strColour = "" Then Exit Function
strColour = Right(strColour,Len(strColour)-1)
Shadow = "#"
For intIndex = 1 To 6 Step 2
strNum = Mid(strColour, intIndex, 2)
strNum = Hex(Eval("&H" & strNum & "-32"))
If Len(strNum) = 1 Then
strNum = "0" & strNum
ElseIf Len(strNum) > 2 Then
strNum = "00"
End If
Shadow = Shadow & strNum
Next
End Function
'-------------------- Render scene --------------------
''50 Render
Sub RenderScene(intDirection)
Dim intX 'For-nexts
Dim intY
Dim intZ
Dim intPath 'Shape data reference at world xyz. Also used to dertermine if a shape is on\off in viewport
Dim intAngle 'A block can be rotated in 23 angles
Dim intColIndex 'Colour table index
Dim intNewX 'Swaps the world scanning coord system around depending on camera direction
Dim intNewY
Dim intNewZ
intSpinnerCount = 0 'Spinner counts are dynamic (for speed)
sngTimer = Timer 'Start the timer clock
intItemsRendered = 0
For intZ = intStartDepth To intViewMaxDepth
For intY = intStartHeight To intViewMaxHeight - intStartHeight
For intX = intStartWidth To intViewMaxWidth - intStartWidth
'---- This deals with the VMLs that were skipped being created.
If vmlShape(intX, intY, intZ) <> Empty Then
'---- Change world grabbing coords, depending on facing direction
intNewY = intY + intCamY - 8
Select Case intDirection
'---- North (standard L-R, T-B)
Case 0 : intNewX = intX + intCamX - 8 : intNewZ = intZ + intCamZ - intViewMaxDepth
'---- East (T-B, R-L)
Case 1 : intNewX = intCamX - intZ + intViewMaxDepth : intNewZ = intX + intCamZ - 8
'---- South (mirror North)
Case 2 : intNewX = intCamX - intX + 8 : intNewZ = intCamZ - intZ + intViewMaxDepth
'---- West (mirror East)
Case 3 : intNewX = intCamX + intZ - intViewMaxDepth : intNewZ = intCamZ - intX + 8
End Select
'---- Get path index at new world xyz
intPath = GetWorld(intNewX, intNewY, intNewZ ,"PT")
'---- Change this VML
With vmlShape(intX, intY, intZ)
'---- Always hide it 1st (or you'll see it change)
.Style.Display = "None"
'---- Update VML (if not an empty space)
If intPath Then
'---- Set the new path
.Path = strPaths(intPath)
'---- Get angle
intAngle = GetWorld(intNewX, intNewY, intNewZ ,"AN")
'---- Angle 99 = A spinner
If intAngle = 99 Then
vmlExtru(intX, intY, intZ).BackDepth = intBackDepthThin(intZ)
If intSpinnerCount < intMaxSpinners Then
intSpinnerCount = intSpinnerCount + 1
Set Spinner(intSpinnerCount) = vmlExtru(intX, intY, intZ)
Spinner(intSpinnerCount).RotationAngle = intSpinnerRX & " " & intSpinnerRY
Spinner(intSpinnerCount).Specularity = 10
.Rotation = 0
End If
'---- Or just rotate VML
Else
.Rotation = RenderDir(intAngle,intDirection,1) ' Rotating the shape deals with Y
vmlExtru(intX, intY, intZ).RotationAngle = RenderDir(intAngle,intDirection,0) & _
" " & RenderDir(intAngle,intDirection,2) ' Extrusion deals with X+Z
vmlExtru(intX, intY, intZ).BackDepth = intBackDepth(intZ) ' If not a spinner then must reset BD
vmlExtru(intX, intY, intZ).Specularity = 0
End If
'---- Get colour table index
intColIndex = GetWorld(intNewX, intNewY, intNewZ ,"CT")
'---- Wireframe quest object?
If intColTab(intColIndex, 2) Then
'---- Passed quest status, so plot solid
If dctPlayerStatus.Exists("quest" & intColIndex) Then
SetWorld intNewX, intNewY, intNewZ ,"CT", intColIndex - 10
vmlExtru(intX, intY, intZ).Render = "Solid"
Else
vmlExtru(intX, intY, intZ).Render = "Wireframe"
.StrokeColor = intColTab(intColIndex, 0)
End If
Else
vmlExtru(intX, intY, intZ).Render = "Solid"
End If
'---- Colour 1 (extrusion)
vmlExtru(intX, intY, intZ).Color = intColTab(intColIndex, 0)
'---- Colour 2 (shape)
.FillColor = intColTab(intColIndex, 1)
'---- Rotate world lights for this VML
vmlExtru(intX, intY, intZ).LightPosition = strLight(intDirection,0)
vmlExtru(intX, intY, intZ).LightPosition2 = strLight(intDirection,1)
'---- Show it (if no path or bookmark, then it stays hidden)
If intPath = 255 Then
If intEditMode Then
vmlExtru(intX, intY, intZ).RotationAngle = "0 0"
vmlExtru(intX, intY, intZ).BackDepth = 20
.Rotation = 0
.Style.Display = "Block"
End If
Else
.Style.Display = "Block"
End If
'---- Update count
intItemsRendered = intItemsRendered + 1
End If
End With
End If
Next
Next
Next
'---- Report frame time & VML count
If intEditMode Then
sngTimer = Timer - sngTimer
If Instr(sngTimer,"-") Then sngTimer = 0
objCTRL(50).InnerText = "Render time = " & sngTimer & " ( " & intItemsRendered & " / " & intVMLCount & " blocks )"
End If
End Sub
'-------------------- GUI events --------------------
''80 GUI
'---- Click events for all controls
Sub CTRLClick()
Dim intIndex, intCTRL
'---- Label recurse
If intRecurse Then
intCTRL = intRecurse : intRecurse = 0
Else
intCTRL = Me.ID
End If
Select Case intCTRL
'---- Tab bar buttons
Case 10, 11, 12, 13
For intIndex = 5 To 8
objCTRL(intIndex).Style.Visibility = "Hidden"
Next
objCTRL(Int(Me.ID) - 5).Style.Visibility = "Visible"
'---- Follow camera toggle
Case 15
JumpTo3DCam
'---- Change onion skin direction
Case 17
intOnionDir = -intOnionDir
UpdateGrid : UpdateCamIcon
'---- Paint mode, just a cursor change (but so needed)
Case 26
If objCTRL(intCTRL).Checked Then
objCTRL(1).Style.Cursor = "Hand"
Else
objCTRL(1).Style.Cursor = "Crosshair"
End If
'---- Grid up\down buttons
Case 30
intEditCamZ = intEditCamZ - 1
UpdateCamIcon : UpdateGrid
Case 31
intEditCamZ = intEditCamZ + 1
UpdateCamIcon : UpdateGrid
'---- Quick wireframe view (not a toggle)
Case 32
ChangeVisibleVMLs 2
'---- Update world header
Case 34
UpdateWorldProps
'---- Count blocks
Case 36
objCTRL(35).Value = strStartupTime & VBCRLF & VBCRLF & CountBlocks
'---- Save world
Case 42
If objCTRL(41).Value = "" Then
Msgbox "Please type a file name.", 64, strCW
Exit Sub
End If
SaveWorld ""
RefreshWorldFiles
'---- Clear world
Case 47
If Msgbox ("Are you sure you want to clear the world?", 36, strCW) = 6 Then
ClearWorld 1
objCTRL(41).Value = "" 'Clear filebox
objCTRL(33).Value = strDefaultWP 'Set default header
UpdateWorldProps
RenderScene intCamDirection
End If
'---- Goto bookmark
Case 51
intCurBookMark = intCurBookMark + 1
ScanBookmarks
'---- Checkbox label click workaround (<LABEL FOR=""> doesn't seem to work in VBS-DOM?)
Case 14, 16, 25, 43, 52
objCTRL(Int(Me.ID) + 1).Checked = objCTRL(Int(Me.ID) + 1).Checked + 1 And 1
intRecurse = Me.ID + 1 : CTRLClick
End Select
End Sub
'---- Mouse move in grid
Sub GridMove()
Dim intX,intY,intPT,intAN,intCT
'---- Drawing?
If intDrawMode = 1 Then
intX = Int(Me.Style.PixelLeft / 20) : intY = Int(Me.Style.PixelTop / 20)
DrawInWorld intX, intY
UpdateSingleGrid intX, intY,intX + intEditCamX, intEditCamZ, intY + intEditCamY
End If
'---- Info & coordinates in each grid tooltip (GUI space saver)
intX = Int(((Me.Style.PixelLeft)/20) + intEditCamX)
intY = Int(((Me.Style.PixelTop)/20) + intEditCamY)
intAN = GetWorld(intX, intEditCamZ, intY, "AN")
intCT = GetWorld(intX, intEditCamZ, intY, "CT")
intPT = GetWorld(intX, intEditCamZ, intY, "PT")
If intAN = 99 Then intAN = intAN & " (Spinner)"
If intCT < 20 Then
intCT = intCT & " (Quest)"
ElseIf intCT > 56 And intCT < 256 Then
intCT = intCT & " (Duel)"
ElseIf intCT> 255 Then
intCT = intCT & " (Shadow)"
End If
If intPT = 0 Then intAN = "None" : intCT = "None" : intPT= "0"
Me.Title = "Block = " & strPathNames(intPT) & " [" & intPT & "]" & VBCRLF & "Angle = " & _
intAN & VBCRLF & "Colour = " & intCT & VBCRLF & "XYZ = " & intX & "\" & intEditCamZ & "\" & intY
End Sub
'---- Mouse click in grid
Sub GridClick()
Dim intX,intY
intX = Int(Me.Style.PixelLeft / 20) : intY = Int(Me.Style.PixelTop / 20)
If intDrawMode = 0 Then
intDrawMode = 1
DrawInWorld intX, intY
UpdateSingleGrid intX, intY,intX + intEditCamX, intEditCamZ, intY + intEditCamY
Else
intDrawMode = 0
End If
End Sub
'---- Mouse wheel in grid
Sub GridWheel()
Dim intX, intY, intAN
intX = Int(Me.Style.PixelLeft / 20) : intY = Int(Me.Style.PixelTop / 20)
'---- Can't rotate empty space
If GetWorld(intX + intEditCamX, intEditCamZ, intY + intEditCamY, "PT") Then
intAN = GetWorld(intX + intEditCamX, intEditCamZ, intY + intEditCamY, "AN")
If intAN = 99 Then Exit Sub 'Can't rotate a spinner
'---- Goto next angle (show in listbox)
intAN = intAN + 1 : If intAN = 24 Then intAN = 0
objCTRL(23).SelectedIndex = intAN
SetWorld intX + intEditCamX, intEditCamZ, intY + intEditCamY, "AN", intAN
UpdateSingleGrid intX, intY,intX + intEditCamX, intEditCamZ, intY + intEditCamY
RenderScene intCamDirection
End If
End Sub
'---- Only render on a mouse up
Sub Document_OnMouseUp()
If intDrawMode = 1 Then RenderScene intCamDirection
intDrawMode = 0
End Sub
'---- Blur all lists on mouse out (CRSR fixer)
Sub MouseOutCTRL()
If objCTRL(0).Style.Display = "block" Then ' Stops hidden list focus error
objCTRL(0).Focus
End If
End Sub
'---- Draw in the worldspace
Sub DrawInWorld(intX,intY)
Dim intIndex, intPT, intAN, intCT, intBrPT, intBrAN, intBrCT
'---- Middle mouse button moves 3D cam to here
If Window.Event.Button = 4 Then
intCamX = intEditCamX + intX : intCamZ = intEditCamY + intY : intCamY = intEditCamZ
UpdateCamIcon
Else
intPT = GetWorld(intX + intEditCamX, intEditCamZ, intY + intEditCamY, "PT")
intAN = GetWorld(intX + intEditCamX, intEditCamZ, intY + intEditCamY, "AN")
intCT = GetWorld(intX + intEditCamX, intEditCamZ, intY + intEditCamY, "CT")
'---- Hold CTRL to grab brush at cursor
If Window.Event.CTRLKey Then
'---- Find path value (paths are spaced out in the list), and select list item
For intIndex = 0 To objCTRL(21).Length - 1
If intPT = Int(objCTRL(21).Options(intIndex).Value) Then
objCTRL(21).SelectedIndex = intIndex
Exit For
End If
Next
'---- Angles and colours
If intAN<>99 Then objCTRL(23).SelectedIndex = intAN
If intCT > 255 Then intCT = intCT - 256
objCTRL(24).SelectedIndex = intCT
'---- Or just draw
Else
intBrPT = Int(objCTRL(21).Options(objCTRL(21).SelectedIndex).Value)
intBrAN = Int(objCTRL(23).SelectedIndex)
intBrCT = Int(objCTRL(24).SelectedIndex)
'---- Delete item (RMB or using the empty brush)
If intBrPT = 0 Or Window.Event.Button = 2 Then
DeleteBlock intX + intEditCamX, intEditCamZ, intY + intEditCamY
'---- Draw in grid (LMB)
Else
'---- Paint mode, only updates colour if not empty space
If objCTRL(26).Checked Then
If intPT Then
'---- Shadow paint mode. Doesn't change the main colour, just the shade
If objCTRL(53).Checked Then
intBrCT = intCT
If intCT > 19 And intCT < 256 Then intBrCT = intCT + 256
End If
SetWorld intX + intEditCamX, intEditCamZ, intY + intEditCamY, "CT", intBrCT
End If
'---- Or draw with path\angle\colour
Else
'---- Auto-set spinner angle 99, if drawing with any spinner
If intBrPT => 2 And intBrPT =< 39 Then intBrAN = 99
'---- Normal shadow mode
If objCTRL(53).Checked And intBrCT > 19 Then intBrCT = intBrCT + 256
'---- Draw block
SetBlock intX + intEditCamX, intEditCamZ, intY + intEditCamY, intBrPT, intBrAN, intBrCT
'---- Start box drawing
If Window.Event.ShiftKey Then
If objCTRL(1).Style.Cursor = "move" Then
objCTRL(1).Style.Cursor = "Crosshair"
Draw3DBox intX + intEditCamX, intEditCamZ, intY + intEditCamY, intBrPT, intBrAN, intBrCT
Else
objCTRL(1).Style.Cursor = "Move"
intBoxX = intX + intEditCamX
intBoxY = intEditCamZ
intBoxZ = intY + intEditCamY
End If
End If
End If
End If
End If
End If
End Sub
'---- Draw a 3D box of blocks in the worldspace, With two shift-clicks.
Sub Draw3DBox(intBoxEX,intBoxEY,intBoxEZ, intPT,intAN,intCT)
Dim intX,intY,intZ
Dim intSX,intSY,intSZ
'---- Swap start and end if larger
If intBoxEX < intBoxX Then intSX = intBoxX : intBoxX = intBoxEX Else intSX = intBoxEX
If intBoxEY < intBoxY Then intSY = intBoxY : intBoxY = intBoxEY Else intSY = intBoxEY
If intBoxEZ < intBoxZ Then intSZ = intBoxZ : intBoxZ = intBoxEZ Else intSZ = intBoxEZ
'---- Draw the box
For intX = intBoxX To intSX
For intY = intBoxY To intSY
For intZ = intBoxZ To intSZ
SetBlock intX,intY,intZ,intPT,intAN,intCT
Next
Next
Next
UpdateGrid
End Sub
'---- Update all the editor grid
Sub UpdateGrid()
Dim intX, intY
For intX = 0 To 10
For intY = 0 To 10
UpdateSingleGrid intX, intY, intX + intEditCamX, intEditCamZ, intY + intEditCamY
Next
Next
End Sub
'---- Update a single grid cell (used for fast drawing and full grid update)
Sub UpdateSingleGrid(intGX, intGY, intX, intY, intZ)
Dim intPath, intColIndex ,intAngle
intPath = GetWorld(intX, intY, intZ ,"PT")
With Grid(intGX,intGY,1)
'---- A path exists at xyz
If intPath Then
.Path = strPaths(intPath)
intColIndex = GetWorld(intX, intY, intZ ,"CT")
.FillColor = intColTab(intColIndex, 0)
.StrokeColor = intColTab(intColIndex, 1)
intAngle = GetWorld(intX, intY, intZ ,"AN")
.Rotation = ((intAngle ) And 3) * 90
'---- Nothing here? Check above or underneath (simple onion skin)
Else
intPath = GetWorld(intX, intY + intOnionDir, intZ,"PT")
If intPath Then
'---- Show with no fill
intColIndex = GetWorld(intX, intY + intOnionDir, intZ,"CT")
.Path = strPaths(intPath)
.FillColor = "#202020"
.StrokeColor = intColTab(intColIndex,0)
'---- Nothing here or underneath, then turn to empty space
Else
.Path = "M0,0"
End If
End If
End With
End Sub
'---- Update camera icon
Sub UpdateCamIcon()
With objCTRL(48).Style
'---- Only calculate X+Z if on the same Y level
If intCamY = intEditCamZ Then
If intCamX < intEditCamX + 11 And intCamX > intEditCamX - 1 And _
intCamZ < intEditCamY + 11 And intCamZ > intEditCamY - 1 Then
'---- Position cam with edit offset
.Left = Int((intCamX - intEditCamX) * 20) + 3
.Top = Int(((intCamZ - intEditCamY) * 20) + 3)
'---- Rotate camera icon for NESW
objCTRL(48).Rotation = intCamDirection * 90
.Display = "Block"
Else
.Display = "None"
End If
Else
.Display = "None"
End If
End With
End Sub
'---- Jump to game camera
Sub JumpTo3DCam()
intEditCamX = intCamX - 5 : intEditCamY = intCamZ - 5 : intEditCamZ = intCamY
UpdateGrid : UpdateCamIcon
End Sub
'---- Dissable selection (HTA header SELECTION="No" doesn't work with shift+click or dblclick)
Function Document_OnSelectStart()
If Document.ActiveElement.ID = "" Then 'No ID? (like the document.body)
Document_OnSelectStart = False
Else
Select Case Document.ActiveElement.ID
Case 33,41 ' World header and file textbox need selection
Case Else
Document_OnSelectStart = False
End Select
End If
End Function
'---- Window close
Sub Window_OnUnload()
'---- From live mode (savegame)
If intEditMode = 0 Then
SavePlayerStatus
SaveWorldCopy
'---- From edit mode (auto-save)
Else
If objCTRL(44).Checked Then SaveWorld ""
End If
End Sub
'-------------------- Keyboard input --------------------
''90 Game
'---- Keypress
Sub Document_OnKeyDown()
Dim strReloadWorld
Select Case Window.Event.KeyCode
'---- [ESC] Exit
Case 27 : Window.Close
'---- [CRSRS]
Case 37 : intInputDX = -1
Case 39 : intInputDX = 1
Case 38 : intInputDZ = 1
Case 40 : intInputDZ = -1
'---- [PGUP\DN] fly or grid up\down
Case 33 : If intEditMode Then intInputDY = -1
Case 34 : If intEditMode Then intInputDY = 1
'---- [SPACE] Reload in live mode
Case 32
If intEditMode = 0 Then
LoadPlayerStatus
LoadWorldCopy
RenderScene intCamDirection
LockKeys
End If
'---- [HOME] Jump to 3D camera
Case 36
If intEditMode Then JumpTo3DCam
'---- [CTRL+S] Quick save
Case 83
If Window.Event.CTRLKey And intEditMode Then intRecurse = 42 : CTRLClick
'---- [TAB] Toggle editor\live mode
Case 9
'---- Go to live mode
If intEditMode Then
'---- Empty world?
If dctWorldSpace.Count = 0 Then
MsgBox "The world is empty.", 64, strCW
Exit Sub
End If
'---- Auto-Save current world
UpdateWorldProps
If objCTRL(44).Checked Then SaveWorld ""
SavePlayerStatus
'---- Hide editor
objCTRL(0).Style.Display = "None"
objCTRL(50).Style.Display = "None"
invSpinners = Window.SetInterval ("Spinners", 50) 'Start Spinners
intEditMode = 0 : UnLockKeys 'Check for falling right away
'---- Go to edit mode
Else
'---- If playing a continued game only, then warn about Savegame data deletion
If intEditWarn = 1 Then
If MsgBox ("If you enter the editor now then you'll lose your save game, continue?",33,strCW) = 2 Then Exit Sub
intEditWarn = 0
End If
'---- Stop Spinners
intSpinnerRX = 0 : intSpinnerRY = 0
Window.ClearInterval(invSpinners)
'---- Purge savegame folder & clear player
FSO.DeleteFolder strHTADir & "SaveGame", True
FSO.CreateFolder strHTADir & "SaveGame"
dctEvents.RemoveAll
dctPlayerStatus.RemoveAll
'---- Reload current world
strReloadWorld = CheckWorldFile(objCTRL(41).Value)
If strReloadWorld<> "" Then LoadWorld strReloadWorld
RenderScene intCamDirection
intEditMode = 1
JumpTo3DCam
'---- Show editor
objCTRL(2).Style.Visibility = "Visible" 'If you beaten the game!
objCTRL(0).Style.Display = "Block"
objCTRL(50).Style.Display = "Block"
End If
End Select
'---- Change CRSRs depending on mouse position
If intEditMode Then
'---- CRSRs for game (edit mode)
If Window.Event.X => ObjCTRL(0).Style.PixelWidth Then
GameKeys()
'---- Grid following camera?
If ObjCTRL(15).Checked Then
JumpTo3DCam
Else
UpdateCamIcon
End If
'---- CRSRs for grid
Else
If Window.Event.Y <= ObjCTRL(0).Style.PixelTop + 283 Then
intEditCamX = intEditCamX + intInputDX
intEditCamZ = intEditCamZ + intInputDY
intEditCamY = intEditCamY - intInputDZ
intInputDX = 0 : intInputDY = 0 : intInputDZ = 0
UpdateCamIcon : UpdateGrid
End If
End If
intInputDX = 0 : intInputDY = 0 : intInputDZ = 0
'---- CRSRs for game (live mode)
Else
GameKeys()
End If
End Sub
'---- Gameplay keys
Sub GameKeys()
Dim intMoveDX 'Forwards X+Z gets swaped depending on strafe
Dim intMoveDZ
'---- Keys locked out?
If intKeyLock = 1 Then Exit Sub
'---- Turning
If intInputDX And Not Window.Event.CTRLKey Then
intCamDirection = intCamDirection + intInputDX And 3
RenderScene intCamDirection
LockKeys
'---- Or moving
ElseIf intInputDX Or intInputDZ Or intInputDY Then
'---- Forward step or strafe?
If Window.Event.CTRLKey Then
intMoveDX = intRelDir(intCamDirection,2) * intInputDX
intMoveDZ = intRelDir(intCamDirection,3) * intInputDX
Else
intMoveDX = intRelDir(intCamDirection,0) * intInputDZ
intMoveDZ = intRelDir(intCamDirection,1) * intInputDZ
End If
'---- Check if the camera is blocked, move if it's clear
If CheckCamera(intMoveDX, intInputDY, intMoveDZ) = 0 Then
intCamX = intCamX + intMoveDX
intCamZ = intCamZ + intMoveDZ
intCamY = intCamY + intInputDY
RenderScene intCamDirection
LockKeys
End If
intInputDX = 0 : intInputDY = 0 : intInputDZ = 0
End If
End Sub
'-------------------- Game realated functions --------------------
'---- Unlock keyboard, check\set for falling
Sub UnLockKeys()
intKeyLock = 0 : intInputDX = 0 : intInputDY = 0 : intInputDZ = 0
'---- Falling check
If intEditMode = 0 Then 'No gravity in edit mode
If intCamY < lngInvisibleFloor Then 'Camera Y is higher than the invisible floor?
If CheckCamera(0, 1, 0) = 0 Then 'Space below camera? Also checks for switches\coins\exits etc
intCamY = intCamY + 1 'Camera falls down 1 worldspace
RenderScene intCamDirection
LockKeys 'Will loop falling forever (see LockKeys below)
Sound "fall"
End If
End If
End If
End Sub
'---- Lock keyboard
Sub LockKeys()
intKeyLock = 1 : Window.SetTimeOut "UnLockKeys" , intKeyLockDelay
End Sub
'---- Save player Status
Sub SavePlayerStatus()
Dim objWriteFile, strKeyArray, strItemArray, intIndex
'---- Set some player values 1st
dctPlayerStatus.Item("time") = Now
dctPlayerStatus.Item("current_world") = objCTRL(41).Value
dctPlayerStatus.Item("x") = intCamX
dctPlayerStatus.Item("y") = intCamY 'Can savegame while falling.....hummm
dctPlayerStatus.Item("z") = intCamZ
dctPlayerStatus.Item("d") = intCamDirection
'---- Save everything (keys,coins etc)
Set objWriteFile = FSO.CreateTextFile(strHTADir & "SaveGame\PlayerData.txt",2)
strKeyArray = dctPlayerStatus.Keys : strItemArray = dctPlayerStatus.Items
For intIndex = 0 To UBound(strKeyArray)
objWriteFile.WriteLine strKeyArray(intIndex)
objWriteFile.WriteLine strItemArray(intIndex)
Next
objWriteFile.Close
End Sub
'---- Save a copy of a world (with play changes)
Sub SaveWorldCopy()
'---- Does the original world exist? If so then save a copy
If FSO.FileExists(CheckWorldFile(objCTRL(41).Value)) Then
SaveWorld strHTADir & "SaveGame\" & objCTRL(41).Value & ".cw"
Else
MsgBox "Can not save your progress since this world has never been saved.", 16, strCW
Exit Sub
End If
End Sub
'---- Load player Status
Sub LoadPlayerStatus()
Dim objReadFile, strCommand, strValue
dctPlayerStatus.RemoveAll 'Clear previous player
Set objReadFile = FSO.OpenTextFile(strHTADir & "SaveGame\PlayerData.txt", 1)
Do While Not objReadFile.AtEndOfStream
strCommand = objReadFile.ReadLine
strValue = objReadFile.ReadLine
dctPlayerStatus.Item(strCommand) = strValue
'---- Grab and set these values
Select Case strCommand
Case "current_world" : objCTRL(41).Value = strValue
Case "x" : intCamX = Int(strValue)
Case "y" : intCamY = Int(strValue)
Case "z" : intCamZ = Int(strValue)
Case "d" : intCamDirection = Int(strValue)
End Select
Loop
objReadFile.Close
End Sub
'---- Load a copy of a world or original
Sub LoadWorldCopy()
'---- Does the original world exist?
If FSO.FileExists(CheckWorldFile(objCTRL(41).Value)) Then
'---- Does the savegame exist?
If FSO.FileExists(strHTADir & "SaveGame\" & objCTRL(41).Value & ".cw") Then
LoadWorld strHTADir & "SaveGame\" & objCTRL(41).Value & ".cw"
'---- No? then load original
Else
LoadWorld CheckWorldFile(objCTRL(41).Value)
End If
'---- Go and undo whatever you just did
Else
MsgBox "You moved,deleted or renamed the world file for this savegame!", 16, strCW
Window.Close
End If
End Sub
'---- Spinner animation (called from a SetInterval)
Sub Spinners()
If intSpinnerCount = 0 Then Exit Sub
intSpinnerRX = (intSpinnerRX + 5) Mod 360
intSpinnerRY = (intSpinnerRY + 10) Mod 360
For intSpinner = 1 to intSpinnerCount
Spinner(intSpinner).RotationAngle = intSpinnerRX & " " & intSpinnerRY
Next
End Sub
'---- Most DXImageTransform transitions in one handy sub (random dissolve has no options)
Sub SetDXImage(strType,intTime,strVar1,strVar2)
With objCTRL(2)
.Style.Filter = "ProgID:DXImageTransform.Microsoft." & strType
.Filters(0).Duration = intTime
Select Case LCase(strType)
Case "iris"
.Filters(0).IrisStyle = strVar1 'circle,square,star
.Filters(0).Motion = strVar2 'in,out
Case "blinds"
.Filters(0).Bands = strVar1 '1-???
.Filters(0).Direction = strVar2 'up,down,left,right
Case "checkerboard"
.Filters(0).Direction = strVar1 'up,down,left,right
Case "barn"
.Filters(0).Orientation = strVar1 'vertical,horizontal
.Filters(0).Motion = strVar2 'in,out
Case "strips"
.Filters(0).Motion = strVar1 'leftdown,leftup,rightdown,rightup
Case "randombars"
.Filters(0).Orientation = strVar1 'vertical,horizontal
End Select
.Filters.Item(0).Apply()
intKeyLock=1 : Window.SetTimeOut "DXFinished",intTime * 1000 '(see DXFinished below)
End With
End Sub
'---- DX Transitions use a different lock-timer than intKeyLockDelay (walk speed), as I want to force
'a delay so you can see it happen (not too long though)
Sub DXFinished()
'---- Move and render the camera after the filter? (pressure switch\event camera)
If intMoveAfterFilter Then
intMoveAfterFilter = 0
intCamX = intCamX + intMoveAfterDX
intCamY = intCamY + intMoveAfterDY
intCamZ = intCamZ + intMoveAfterDZ
RenderScene intCamDirection
LockKeys
Else
UnLockKeys
End If
End Sub
'---- SAM sound FX
Sub Sound (strSound)
Dim R, P, T
'---- You turned off sound :-(
If blnSAMSound = False Then Exit SUb
'---- If already playing then exit. Stops fast requested sounds stacking up
If TTS.WaitUntilDone(1) = False Then Exit sub
'---- Play a sound
Select Case strSound
Case "fall" : R = 25 : P = 25 : T = "oooooooooooo!"
Case "stir" : R = 25 : P = 25 : T = "oooooooooooo?"
Case "key" : R = 25 : P = 25 : T = "oyoyoyoyoyoyoyoy!"
Case "coin" : R = 25 : P = 25 : T = "iwwwwwwwww"
Case "info" : R = 25 : P = -25 : T = "x" & String(100,"m")
Case "push" : R = 25 : P = -25 : T = String(30,"2")
Case "trap" : R = 25 : P = 25 : T = String(48,"f")
Case "door" : R = 25 : P = -25 : T = String(48,"l") & "?"
Case "cdoor" : R = 12 : P = -25 : T = "xaaaaaaaaaaaaaaaaaaaaaaaa?"
Case "exit" : R = 25 : P = 25 : T = "e" & String(30,"x")
Case "err1" : R = 25 : P = 00 : T = "ffffffffffffffffffff!"
Case "err2" : R = 25 : P = 25 : T = "xnnnnnnnnnnnnnnnnnnnnnnnnn!"
Case "swit" : R = 25 : P = 25 : T = "xxxe"
Case "qust" : R = 25 : P = 1 : T = "^^^$$$^^^$$$^^^$$$^^^!"
Case "tele" : R = 25 : P = 25 : T = String(44,"7")
Case "win!" : R = -25 : P = -25 : T = "mmmmmmmmmmmmmm"
End Select
TTS.Rate = R : TTS.Speak "<PITCH MIDDLE='" & P & "'>" & T, 1
End Sub
'---- Display a message in the game that fades
Sub Message(strText, intTime)
With objCTRL(49)
.InnerText = strText
.Filters(1).Duration = intTime
.Filters(1).Play
End With
End Sub
'-------------------- Camera collisions --------------------
''91 Collisions
Function CheckCamera(intX,intY,intZ)
Dim strEvent,intIndex
Dim intDestX,intDestY,intDestZ 'Destination XYZ
Dim strNewWorldFile 'For exits
Dim intPath,intThisColour 'Path\colour of this tile (used a few times)
'---- Camera can move through everything in edit mode.
If intEditMode Then CheckCamera = 0 : Exit Function
'---- Get the block we want to check
intPath = GetWorld(intCamX + intX, intCamY + intY, intCamZ + intZ, "PT")
'---- The colour table determines what key,door,coin,quest block or info pick-up you touch
intThisColour = GetWorld(intCamX + intX, intCamY + intY, intCamZ + intZ,"CT")
If intThisColour > 255 Then intThisColour = intThisColour - 256
'---- If the block is wireframe (a quest block), then it has no collisions...exit
If intColTab(intThisColour,2) Then CheckCamera = 0 : Exit Function
'---- Did you know that Select Case True in VBS saves lots of comma delimited numbers?
Select Case True
'---- Camera can pass through these shapes
Case intPath = 0, intPath => 240
CheckCamera = 0
'---- Keys
Case intPath => 2 And intPath =< 4
dctPlayerStatus.Item("key_" & intThisColour ) = 1 ' Add it to the player's dictionary
DeleteBlock intCamX + intX, intCamY + intY, intCamZ + intZ
SetDXImage "fade", .5, "", ""
CheckCamera = 1
RenderScene intCamDirection
objCTRL(2).Filters.Item(0).Play()
If intThisColour < 10 Then
Message "You found a " & strColNames(intThisColour) & " key", 2
Else
Message "You found a key", 2
End If
Sound "key"
'---- Coins (see coin operated door)
Case intPath = 10
'---- Update player's coin count
Select Case intThisColour
Case 2 : intIndex = 3 'Gold are worth 3 (should be rare)
Case 8 : intIndex = 2 'Silver are 2 (semi-rare)
Case Else : intIndex = 1 'Bronze and custom colours = 1
End Select
dctPlayerStatus.Item("coins") = Int(dctPlayerStatus.Item("coins")) + intIndex
DeleteBlock intCamX + intX, intCamY + intY, intCamZ + intZ
CheckCamera = 0
RenderScene intCamDirection
Message "Coins = " & dctPlayerStatus.Item("coins") & " \ 100", 5
Sound "coin"
'---- Info pick-up
Case intPath = 20
CheckCamera = 1
If dctEvents.Exists ("info" & intThisColour) Then
Message dctEvents.Item ("info" & intThisColour), 5
Else
Message "Add INFO=text in the world header", 10
End If
DeleteBlock intCamX + intX, intCamY + intY, intCamZ + intZ
SetDXImage "fade", .3, "", ""
RenderScene intCamDirection
objCTRL(2).Filters.Item(0).Play()
Sound "info"
'---- Push blocks
Case intPath = 40
CheckCamera = 1
'---- Only move if no other block is above this one
If GetWorld(intCamX + intX, intCamY + intY - 1, intCamZ + intZ, "PT") <> 40 Then
'---- Check ahead of block
If Int(GetWorld(intCamX + intX * 2, intCamY + intY , intCamZ + intZ * 2, "PT")) = 0 Then
'---- Check below block 1 (can't push off ledges)
If GetWorld(intCamX + intX * 2, intCamY + intY + 1 , intCamZ + intZ * 2, "PT") Or _
intCamY = lngInvisibleFloor Then
'---- Move it
MoveBlock intCamX + intX, intCamY + intY, intCamZ + intZ, intX, 0, intZ
intDestX = Int(intX * 2) : intDestZ = Int(intZ * 2)
'---- Check below block 2 (after moving)
Select Case GetWorld(intCamX + intDestX, intCamY + 1, intCamZ + intDestZ, "PT")
'---- Once only switch
Case 81
SetWorld intCamX + intDestX, intCamY + 1, intCamZ + intDestZ, "PT", 82
intSwitchToggle = 1
CWEvent intDestX, 1, intDestZ
'---- Pressure switch up
Case 85
SetWorld intCamX + intDestX, intCamY + 1, intCamZ + intDestZ, "PT", 86
intSwitchToggle = 1
CWEvent intDestX, 1, intDestZ
'---- Pressure switch down
Case Else
If GetWorld(intCamX + intX, intCamY + 1, intCamZ + intZ, "PT") = 86 Then
SetWorld intCamX + intX, intCamY + 1, intCamZ + intZ, "PT", 85
intSwitchToggle = 0
CWEvent intX, 1, intZ
End If
End Select
RenderScene intCamDirection
LockKeys
Sound "push"
End If
End If
End If
'---- Trap floor \ secret wall
Case intPath = 41
Sound "trap" ' Trap sound first (because falling sound gets cut)
CheckCamera = 1
DeleteBlock intCamX + intX, intCamY + intY, intCamZ + intZ
'---- Random dissolve or a trapdoor?
If Int(Rnd(1)*2) Then
SetDXImage "randomdissolve", .8, "", ""
Else
SetDXImage "barn", .8, "vertical", "out"
End If
RenderScene intCamDirection
objCTRL(2).Filters.Item(0).Play()
'---- Coin operated doors
Case intPath = 42
CheckCamera = 1 : intIndex = 0
If dctPlayerStatus.Exists("coins") Then
If Int(dctPlayerStatus.Item("coins")) < (intThisColour + 1) * 10 Then
Message "You need " & (intThisColour + 1) * 10 & " coins to open this door" , 10
Sound "err2"
Else
DeleteBlock intCamX + intX, intCamY + intY, intCamZ + intZ
SetDXImage "barn", 1, "vertical", "out"
RenderScene intCamDirection
objCTRL(2).Filters.Item(0).Play()
Sound "cdoor"
End If
Else
Message "You have no coins, go and explore..." , 5 'Stops a blank record being made
Sound "err2"
End If
'---- Locked doors
Case intPath > 59 And intPath < 70
CheckCamera = 1
'---- Right key?
If dctPlayerStatus.Exists("key_" & intThisColour ) Then
DeleteBlock intCamX + intX, intCamY + intY, intCamZ + intZ
SetDXImage "barn", 2, "horizontal", "out"
RenderScene intCamDirection
objCTRL(2).Filters.Item(0).Play()
Sound "door"
'---- Don't have the right key?
Else
If intThisColour < 10 Then
Message "You need the " & strColNames(intThisColour) & " key.", 2
Else
Message "You don't have the key for this door.", 2
End If
Sound "err1"
End If
'---- Exits to other worlds
Case intPath > 69 And intPath < 80
CheckCamera = 1
'---- Is there an exit dictionary record at this XYZ position?
strEvent = intCamX + intX & "\" & intCamY + intY & "\" & intCamZ + intZ & "\"
If dctEvents.Exists(strEvent & "event") Then
'---- Check world filename (Live error message only)
strNewWorldFile = dctEvents.Item(strEvent & "event")
If Not FSO.FileExists(strHTADir & strNewWorldFile & ".cw") Then
Msgbox "This exit's destination world doesn't exist:- " & strNewWorldFile, 16 ,strCW
Exit Function
End If
'---- Save current world
SaveWorldCopy
objCTRL(41).Value = strNewWorldFile 'Set new filename in textbox
'---- Store destination XYZ (events will be cleared in the next part)
intDestX = dctEvents.Item(strEvent & "dsx")
intDestY = dctEvents.Item(strEvent & "dsy")
intDestZ = dctEvents.Item(strEvent & "dsz")
'---- Start iris transition now as the next part changes filters (the new sky\floor)
If intY Then
SetDXImage "iris", .6, "square", "out" 'Exit U\D
Else
SetDXImage "iris", .6, "circle", "out" 'Exit NESW
End If
'---- Load new world, or a savegame copy
LoadWorldCopy
'---- Position camera, update status and play iris
intCamX = intDestX : intCamY = intDestY : intCamZ = intDestZ
SavePlayerStatus
RenderScene intCamDirection
objCTRL(2).Filters.Item(0).Play()
Sound "exit"
End If
'---- Standard switch
Case intPath = 80
CheckCamera = 1
If intY = 0 Then
intSwitchToggle = 1 'Normal events (1 = Normal, 0 = reversed\opposite event)
CWEvent intX, intY, intZ 'Call the shared events sub (See below)
Sound "swit"
End If
'---- Once only switch
Case intPath = 81
CheckCamera = 1
SetWorld intCamX + intX, intCamY + intY, intCamZ + intZ, "PT", 82
intSwitchToggle = 1
CWEvent intX, intY, intZ
Sound "swit"
'---- Toggle switch
Case intPath = 83, intPath = 84
CheckCamera = 1
If intY = 0 Then
intSwitchToggle = 84 - intPath
SetWorld intCamX + intX, intCamY + intY, intCamZ + intZ, "PT", 83 + intSwitchToggle
CWEvent intX, intY, intZ
Sound "swit"
End If
'---- Pressure switch toggle (part 1)
Case intPath = 85
CheckCamera = 1
If intY Then
intSwitchToggle = 1
SetWorld intCamX + intX, intCamY + intY, intCamZ + intZ, "PT", 86
CWEvent intX, intY, intZ
Sound "swit"
End If
'---- Quest switch (no events)
Case intPath = 43
CheckCamera = 1
dctPlayerStatus.Item("quest" & (intThisColour + 10) ) = 1
SetWorld intCamX + intX, intCamY + intY, intCamZ + intZ, "PT", 44
SetDXImage "fade", 1, "", ""
RenderScene intCamDirection
objCTRL(2).Filters.Item(0).Play()
If intThisColour < 10 Then
Message "All " & strColNames(intThisColour) & " transparent items are now solid", 10
Else
'---- Live error message for wrong colour
MsgBox "This switch is not using a quest colour 0-9, so nothing will change.", 48, strCW
End If
Sound "qust"
'---- Stairs
Case intPath > 99 And intPath < 150
CheckCamera = 1
'---- Compare camera move direction to stair angle
Select Case GetWorld(intCamX + intX, intCamY + intY, intCamZ + intZ, "AN")
Case 8,22 : If intX = 0 And intZ = -1 Then CheckCamera = 0 'N
Case 9,23 : If intX = 1 And intZ = 0 Then CheckCamera = 0 'E
Case 10,20 : If intX = 0 And intZ = 1 Then CheckCamera = 0 'S
Case 11,21 : If intX = -1 And intZ = 0 Then CheckCamera = 0 'W
End Select
'---- Check above stairs, move up if empty (uses recursion)
If CheckCamera = 0 Then
If CheckCamera (intX, intY - 1, intZ ) = 0 Then
intInputDY = -1
Sound "stir"
Else
CheckCamera = 1
End If
End If
'---- "Win" block
Case intPath = 21
Message "Congratulations! You have beaten Cubeworld.", 41
SetDXImage "iris", 41, "star", "in"
objCTRL(2).Style.Visibility = "hidden"
objCTRL(2).Filters.Item(0).Play()
Sound "win!"
'---- Everything else blocks you
Case Else
CheckCamera = 1
End Select
'---- Camera leaving a presure switch? (part 2)
If GetWorld(intCamX, intCamY + 1, intCamZ, "PT") = 86 And intY = 0 And CheckCamera = 0 Then
CheckCamera = 1
intMoveAfterFilter = 1
intMoveAfterDX = intX : intMoveAfterDY = intY : intMoveAfterDZ = intZ
intSwitchToggle = 0 'Reverse events
SetWorld intCamX, intCamY + 1, intCamZ, "PT", 85
CWEvent 0, 1, 0
Sound "swit"
End If
End Function
'-------------------- Switch events --------------------
''92 Events
Sub CWEvent(intX,intY,intZ)
Dim strEvent, strSplit, intIndex
Dim intThisX,intThisY,intThisZ 'This tile's XYZ
Dim intDestX,intDestY,intDestZ 'Destination XYZ
'---- Get this XYZ
intThisX = Int(intCamX + intX) : intThisY = Int(intCamY + intY) : intThisZ = Int(intCamZ + intZ)
'---- Is there an event dictionary record at this XYZ position?
strEvent = intThisX & "\" & intThisY & "\" & intThisZ & "\"
If dctEvents.Exists(strEvent & "event") Then
'---- Get destination XYZ for event
intDestX = dctEvents.Item(strEvent & "dsx")
intDestY = dctEvents.Item(strEvent & "dsy")
intDestZ = dctEvents.Item(strEvent & "dsz")
'---- Event name can have "\" delimited values
If Instr(dctEvents.Item(strEvent & "event"),"\") Then
strSplit = Split(dctEvents.Item(strEvent & "event"), "\")
For intIndex = 0 To UBound(strSplit)
strSplit(intIndex) = Trim(strSplit(intIndex))
Next
End If
'---- Do the event
Select Case Left(LCase(dctEvents.Item(strEvent & "event")),3)
'---- Delete block (DEL, X,Y,Z)
Case "del"
SetDXImage "randomdissolve", .5, "", ""
DeleteBlock intDestX, intDestY, intDestZ
'---- Create block (ADD\PT\AN\CT, X,Y,Z)
Case "add"
SetDXImage "randomdissolve", .5, "", ""
SetBlock intDestX, intDestY, intDestZ, strSplit(1), strSplit(2), strSplit(3)
'---- Toggle block (TOG\PT\AN\CT, X,Y,Z)
Case "tog"
If GetWorld(intDestX, intDestY, intDestZ, "PT") = 0 Then
SetDXImage "randomdissolve", .6, "", ""
SetBlock intDestX, intDestY, intDestZ, strSplit(1), strSplit(2), strSplit(3)
Else
SetDXImage "randomdissolve", .6, "", ""
DeleteBlock intDestX, intDestY, intDestZ
End If
'---- Move block (MOV\DX\DY\DZ, X,Y,Z)
Case "mov"
SetDXImage "randomdissolve", .5, "", ""
If intSwitchToggle Then
If GetWorld(intDestX + Int(strSplit(1)), intDestY + Int(strSplit(2)), intDestZ + Int(strSplit(3)), "PT") = 0 Then
MoveBlock intDestX, intDestY, intDestZ, Int(strSplit(1)), Int(strSplit(2)), Int(strSplit(3))
End If
Else
If GetWorld(intDestX,intDestY,intDestZ, "PT") = 0 Then
MoveBlock intDestX + Int(strSplit(1)), intDestY + Int(strSplit(2)), intDestZ + Int(strSplit(3)), _
-Int(strSplit(1)), -Int(strSplit(2)), -Int(strSplit(3))
End If
End If
'---- Swap blocks (SWP\X\Y\Z, X,Y,Z)
Case "swp"
SetDXImage "randomdissolve", .5, "", ""
SwapBlock intDestX, intDestY, intDestZ, Int(strSplit(1)), Int(strSplit(2)), Int(strSplit(3))
'---- World change (WDC\PT\AN\CT, PT,AN,CT)
Case "wdc"
SetDXImage "randomdissolve", .5, "", ""
If intSwitchToggle Then
WorldChange strSplit(1), strSplit(2), strSplit(3), intDestX, intDestY, intDestZ
Else
WorldChange intDestX, intDestY, intDestZ, strSplit(1), strSplit(2), strSplit(3)
End If
'---- Teleport camera
Case "tel"
SetDXImage "randombars", 2, "vertical", ""
intCamX = Int(intDestX) : intCamY = Int(intDestY) : intCamZ = Int(intDestZ)
Sound "tele"
'---- Lights off (trap)
Case "drk"
intWorldLights = 0
ChangeVisibleVMLs 4
SetDXImage "fade", .5, "", ""
'---- Lights on (original fog)
Case "lit"
intWorldLights = 1
ChangeVisibleVMLs 3
SetDXImage "fade", .5, "", ""
'---- Lights on\off toggle
Case "lsw"
intWorldLights = intWorldLights + 1 And 1
If intWorldLights Then
ChangeVisibleVMLs 3
Else
ChangeVisibleVMLs 4
End If
SetDXImage "fade", .5, "", ""
End Select
'---- Change world, with a transition
RenderScene intCamDirection
objCTRL(2).Filters.Item(0).Play()
Else
Msgbox "Missing event for this switch, expect weird results.", 64, strCW
End If
End Sub
</SCRIPT>
</HTML>