├── README.md ├── Res ├── Box.png ├── ball.png ├── RainbowBall.png ├── SoccerBall.png └── ball_yellow.svg ├── cls2DPhysic.cls ├── mod2DPhysic.bas ├── .gitignore ├── .gitattributes ├── prj2Dengine.vbp ├── frmMain.frm ├── modScenes.bas └── clsTick.cls /README.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miorsoft/VB6-2D-Physic-Engine/HEAD/README.md -------------------------------------------------------------------------------- /Res/Box.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miorsoft/VB6-2D-Physic-Engine/HEAD/Res/Box.png -------------------------------------------------------------------------------- /Res/ball.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miorsoft/VB6-2D-Physic-Engine/HEAD/Res/ball.png -------------------------------------------------------------------------------- /cls2DPhysic.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miorsoft/VB6-2D-Physic-Engine/HEAD/cls2DPhysic.cls -------------------------------------------------------------------------------- /mod2DPhysic.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miorsoft/VB6-2D-Physic-Engine/HEAD/mod2DPhysic.bas -------------------------------------------------------------------------------- /Res/RainbowBall.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miorsoft/VB6-2D-Physic-Engine/HEAD/Res/RainbowBall.png -------------------------------------------------------------------------------- /Res/SoccerBall.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miorsoft/VB6-2D-Physic-Engine/HEAD/Res/SoccerBall.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Windows image file caches 2 | Thumbs.db 3 | ehthumbs.db 4 | 5 | # Folder config file 6 | Desktop.ini 7 | 8 | # Recycle Bin used on file shares 9 | $RECYCLE.BIN/ 10 | 11 | # Windows Installer files 12 | *.cab 13 | *.msi 14 | *.msm 15 | *.msp 16 | 17 | # Windows shortcuts 18 | *.lnk 19 | 20 | *.exp 21 | *.lib 22 | *.vbw 23 | /*.dll 24 | /*.bak 25 | 26 | *.exe 27 | *.zip 28 | 29 | 30 | /ToIgnore 31 | /Frames -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | *.sln merge=union 7 | *.csproj merge=union 8 | *.vbproj merge=union 9 | *.fsproj merge=union 10 | *.dbproj merge=union 11 | *.ctx -diff 12 | *.frx -diff 13 | *.res -diff 14 | *.RES -diff 15 | *.bas eol=crlf 16 | *.cls eol=crlf 17 | *.ctl eol=crlf 18 | *.frm eol=crlf 19 | *.txt eol=crlf 20 | *.vbp eol=crlf 21 | 22 | # Standard to msysgit 23 | *.doc diff=astextplain 24 | *.DOC diff=astextplain 25 | *.docx diff=astextplain 26 | *.DOCX diff=astextplain 27 | *.dot diff=astextplain 28 | *.DOT diff=astextplain 29 | *.pdf diff=astextplain 30 | *.PDF diff=astextplain 31 | *.rtf diff=astextplain 32 | *.RTF diff=astextplain 33 | -------------------------------------------------------------------------------- /prj2Dengine.vbp: -------------------------------------------------------------------------------- 1 | Type=Exe 2 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\Windows\System32\stdole2.tlb#OLE Automation 3 | Reference=*\G{CE4F61C1-7072-4180-9107-B38562AB6ABE}#c2.0#0#..\..\VB6\____PhotoModularFX_0_3\BIN\RC6.dll#RC6 4 | Form=frmMain.frm 5 | Module=modScenes; modScenes.bas 6 | Class=cls2DPhysic; cls2DPhysic.cls 7 | Module=mod2DPhysic; mod2DPhysic.bas 8 | Class=clsTick; clsTick.cls 9 | IconForm="frmMain" 10 | Startup="frmMain" 11 | HelpFile="" 12 | Title="prj2Dengine" 13 | ExeName32="prj2Dengine.exe" 14 | Command32="" 15 | Name="prj2Dengine" 16 | HelpContextID="0" 17 | CompatibleMode="0" 18 | MajorVer=1 19 | MinorVer=0 20 | RevisionVer=193 21 | AutoIncrementVer=1 22 | ServerSupportFiles=0 23 | VersionCompanyName="Roberto Mior (aka reexre,miorsoft)" 24 | VersionLegalCopyright="Roberto Mior (aka reexre,miorsoft)" 25 | VersionProductName="2D Phyisic Engine" 26 | CompilationType=0 27 | OptimizationType=0 28 | FavorPentiumPro(tm)=-1 29 | CodeViewDebugInfo=0 30 | NoAliasing=-1 31 | BoundsCheck=-1 32 | OverflowCheck=-1 33 | FlPointCheck=-1 34 | FDIVCheck=-1 35 | UnroundedFP=-1 36 | StartMode=0 37 | Unattended=0 38 | Retained=0 39 | ThreadPerObject=0 40 | MaxNumberOfThreads=1 41 | -------------------------------------------------------------------------------- /frmMain.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmMain 3 | Caption = "Physic Engine" 4 | ClientHeight = 7965 5 | ClientLeft = 165 6 | ClientTop = 555 7 | ClientWidth = 15240 8 | BeginProperty Font 9 | Name = "Tahoma" 10 | Size = 8.25 11 | Charset = 0 12 | Weight = 400 13 | Underline = 0 'False 14 | Italic = 0 'False 15 | Strikethrough = 0 'False 16 | EndProperty 17 | LinkTopic = "Form1" 18 | ScaleHeight = 531 19 | ScaleMode = 3 'Pixel 20 | ScaleWidth = 1016 21 | StartUpPosition = 1 'CenterOwner 22 | Begin VB.CommandButton Command5 23 | Caption = "ADD Mini Chain" 24 | Height = 615 25 | Left = 13440 26 | TabIndex = 8 27 | Top = 5160 28 | Width = 975 29 | End 30 | Begin VB.CommandButton Command4 31 | Caption = "ADD Regular Poly" 32 | Height = 615 33 | Left = 13440 34 | TabIndex = 7 35 | Top = 4200 36 | Width = 975 37 | End 38 | Begin VB.CheckBox chkJPG 39 | Caption = "Save Jpg Frames" 40 | Height = 495 41 | Left = 13560 42 | TabIndex = 6 43 | Top = 6480 44 | Width = 1455 45 | End 46 | Begin VB.CommandButton Command3 47 | Caption = "ADD BOX" 48 | Height = 615 49 | Left = 13440 50 | TabIndex = 4 51 | Top = 3360 52 | Width = 975 53 | End 54 | Begin VB.ComboBox cmbScene 55 | Height = 315 56 | Left = 13440 57 | Style = 2 'Dropdown List 58 | TabIndex = 3 59 | Top = 1560 60 | Width = 1695 61 | End 62 | Begin VB.CommandButton Command2 63 | Caption = "ADD BALL" 64 | Height = 615 65 | Left = 13440 66 | TabIndex = 2 67 | Top = 2520 68 | Width = 975 69 | End 70 | Begin VB.CommandButton Command1 71 | Caption = "(RE) START" 72 | Height = 615 73 | Left = 13440 74 | TabIndex = 1 75 | Top = 120 76 | Width = 975 77 | End 78 | Begin VB.PictureBox PIC 79 | Appearance = 0 'Flat 80 | BackColor = &H80000005& 81 | BorderStyle = 0 'None 82 | ForeColor = &H00FFFFFF& 83 | Height = 6135 84 | Left = 120 85 | ScaleHeight = 409 86 | ScaleMode = 3 'Pixel 87 | ScaleWidth = 641 88 | TabIndex = 0 89 | Top = 120 90 | Width = 9615 91 | End 92 | Begin VB.Label Label1 93 | Caption = "SCENE" 94 | Height = 255 95 | Left = 13440 96 | TabIndex = 5 97 | Top = 1320 98 | Width = 1095 99 | End 100 | End 101 | Attribute VB_Name = "frmMain" 102 | Attribute VB_GlobalNameSpace = False 103 | Attribute VB_Creatable = False 104 | Attribute VB_PredeclaredId = True 105 | Attribute VB_Exposed = False 106 | Option Explicit 107 | 108 | 109 | Public WithEvents ENGINE As cls2DPhysic 110 | Attribute ENGINE.VB_VarHelpID = -1 111 | 112 | 113 | 114 | Private MouseDownX As Double 115 | Private MouseDownY As Double 116 | 117 | 118 | 119 | Private Sub chkJPG_Click() 120 | SaveFrames = (chkJPG.Value = vbChecked) 121 | End Sub 122 | 123 | Private Sub cmbScene_Change() 124 | CreateScene frmMain.cmbScene.ListIndex 125 | End Sub 126 | 127 | Private Sub cmbScene_Click() 128 | CreateScene frmMain.cmbScene.ListIndex 129 | End Sub 130 | 131 | Private Sub Command1_Click() 132 | 133 | ENGINE.BiggerGroup = 0 134 | CreateScene frmMain.cmbScene.ListIndex 135 | 136 | 137 | End Sub 138 | 139 | Private Sub Command2_Click() 140 | ENGINE.BodyCREATECircle Vec2(PicW * 0.5, 0), 5 + Rnd * 20, DefDensity 141 | 142 | ENGINE.BodySetGroup ENGINE.NofBodies, 1 143 | ENGINE.BodySetCollideWith ENGINE.NofBodies, ALL 144 | 145 | End Sub 146 | 147 | Private Sub Command3_Click() 148 | 149 | 150 | ' BodyCREATERandomPoly Vec2(PicW \ 2, 0), DefDensity 151 | ENGINE.BodyCREATEBox Vec2(PicW \ 2, 0), 60, 30 152 | ENGINE.BodySetGroup ENGINE.NofBodies, 1 153 | ENGINE.BodySetCollideWith ENGINE.NofBodies, ALL 154 | End Sub 155 | 156 | Private Sub Command4_Click() 157 | ENGINE.BodyCREATERegularPoly Vec2(PicW \ 2, 0), 12 + Rnd * 30, 12 + Rnd * 30, 3 + Int(Rnd * 10), -Int(Rnd * 2), DefDensity 158 | ENGINE.BodySetGroup ENGINE.NofBodies, 1 159 | ENGINE.BodySetCollideWith ENGINE.NofBodies, ALL 160 | End Sub 161 | 162 | Private Sub Command5_Click() 163 | ENGINE.BodyCREATEBox Vec2(PicW * 0.5, 5), 80, 15 164 | ENGINE.BodyCREATEBox Vec2(PicW * 0.5 + 70, 5), 80, 15 165 | ENGINE.JointAdd2PinsJ ENGINE.NofBodies - 1, Vec2(35, 0), ENGINE.NofBodies, Vec2(-35, 0), 0, 1, 1 166 | 167 | 168 | 'Make last 2 bodies collide with All but each other 169 | ENGINE.BodySetGroup ENGINE.NofBodies - 1, ENGINE.BiggerGroup * 2 170 | ENGINE.BodySetGroup ENGINE.NofBodies, ENGINE.BiggerGroup * 2 171 | ENGINE.BodySetCollideWith ENGINE.NofBodies - 1, ALL - ENGINE.BiggerGroup 172 | ENGINE.BodySetCollideWith ENGINE.NofBodies, ALL - ENGINE.BiggerGroup \ 2 173 | 174 | 175 | 176 | End Sub 177 | 178 | 179 | Private Sub ENGINE_CollisionEvent(bA As Long, bB As Long, posAX As Double, PosAY As Double, posBX As Double, PosBY As Double, Nx As Double, Ny As Double, ContactVelo As Double) 180 | 'Me.Caption = bA & " " & bB & " " & ContactVelo 181 | 182 | End Sub 183 | 184 | Private Sub Form_Activate() 185 | MAINLOOP 186 | End Sub 187 | 188 | Private Sub Form_Load() 189 | Randomize Timer 190 | 191 | If Dir(App.Path & "\Frames", vbDirectory) = vbNullString Then MkDir App.Path & "\Frames" 192 | If Dir(App.Path & "\Frames\*.*") <> vbNullString Then Kill App.Path & "\Frames\*.*" 193 | 194 | PIC.Height = 360 '360 195 | PIC.Width = Int(PIC.Height * 16 / 9) 196 | 197 | 198 | 199 | pHDC = PIC.hDC 200 | PicW = PIC.Width 201 | PicH = PIC.Height 202 | 203 | 204 | 205 | 206 | Set ENGINE = New cls2DPhysic 207 | 208 | 209 | ENGINE.EngineINIT PIC 210 | 211 | 212 | 213 | cmbScene.AddItem "First" 214 | cmbScene.AddItem "Distance Joints" 215 | cmbScene.AddItem "1 Pin" 216 | cmbScene.AddItem "2 Pins Joints" 217 | cmbScene.AddItem "2 Pins Joints II" 218 | cmbScene.AddItem "Slope" 219 | cmbScene.AddItem "Gum Bridge" 220 | cmbScene.AddItem "Car(Rotor)" 221 | cmbScene.AddItem "Newton Cardle" 222 | cmbScene.AddItem "(Rotor2)" 223 | cmbScene.AddItem "CAR2" 224 | cmbScene.AddItem "TEST" 225 | 226 | 227 | cmbScene.ListIndex = 4 228 | 229 | ENGINE.RenderCreateIntroFrames 230 | 231 | 232 | 233 | 'ENGINE.RenderINITRC 234 | 235 | CreateScene cmbScene.ListIndex 236 | 237 | 238 | 239 | 240 | End Sub 241 | 242 | Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) 243 | ENGINE.RenderCreateOuttroFrames 244 | 245 | End Sub 246 | 247 | Private Sub Form_Unload(Cancel As Integer) 248 | 249 | ENGINE.UnLoad 250 | End 251 | 252 | End Sub 253 | 254 | Private Sub PIC_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 255 | Dim EO As Long 256 | Dim rX As Double 257 | Dim rY As Double 258 | 259 | 260 | MouseDownX = X 261 | MouseDownY = Y 262 | 263 | 264 | ENGINE.BodyGetNearest X * 1, Y * 1, EO, rX, rY 265 | ENGINE.MouseSelectedObj = EO 266 | ENGINE.MouseDownRelX = rX 267 | ENGINE.MouseDownRelY = rY 268 | 269 | 270 | 271 | End Sub 272 | 273 | Private Sub PIC_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 274 | ENGINE.MouseMoveX = X 275 | ENGINE.MouseMoveY = Y 276 | 277 | End Sub 278 | 279 | Private Sub PIC_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 280 | Dim Dx As Double 281 | Dim DY As Double 282 | Dx = X - ENGINE.MouseDownRelX 283 | DY = Y - ENGINE.MouseDownRelY 284 | 285 | 286 | 'ENGINE.BodyApplyImpulse SelectedObj, _ 287 | Vec2MUL(Vec2(Dx, Dy), 1), _ 288 | Vec2ADD(ENGINE.BodyGetPOS(SelectedObj), Vec2(orX, orY)) 289 | 290 | 291 | ENGINE.BodyApplyImpulse ENGINE.MouseSelectedObj, _ 292 | Vec2MUL(Vec2(Dx, DY), ENGINE.BodyGetMass(ENGINE.MouseSelectedObj) * 0.0085), _ 293 | Vec2(ENGINE.MouseDownRelX, ENGINE.MouseDownRelY) 294 | 295 | 296 | 297 | 298 | ENGINE.MouseSelectedObj = 0 299 | 300 | 301 | End Sub 302 | -------------------------------------------------------------------------------- /Res/ball_yellow.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | image/svg+xml 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /modScenes.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "modScenes" 2 | Option Explicit 3 | 4 | 'feel free to create your own scene and share it at VBForums.com (VB6 Phyisc Engine) 5 | 6 | Public Sub CreateScene(Scene As Long) 7 | 8 | Dim I As Long 9 | Dim Vertices() As tVec2 10 | 11 | 12 | With frmMain.ENGINE 13 | 14 | .NofBodies = 0 15 | .NJ = 0 16 | 17 | Select Case Scene 18 | Case 0 19 | For I = 1 To 20 20 | .BodyCREATECircle Vec2(I * 55, 50), 5 + Rnd * (20) 21 | Next 22 | 23 | ' .JointAddDistanceJ 2, 3, 50 24 | ' .JointAddDistanceJ 4, 5, 50 25 | ' .JointAddDistanceJ 6, 7, 50 26 | ' .JointAddDistanceJ 8, 9, 50 27 | ' .JointAddDistanceJ 10, 11, 50 28 | 29 | .BodyCREATERandomPoly Vec2(300, 150) 30 | .BodyCREATERandomPoly Vec2(350, 150) 31 | 32 | .JointAdd2PinsJ .NofBodies - 1, Vec2(30, 0), .NofBodies, Vec2(-30, 0), 80, 0.5 33 | 34 | 35 | For I = 20 + 1 To 20 + 9 36 | 37 | .BodyCREATECircle Vec2((I - 20 - 1) * 75, PicH + 40), 65 38 | 39 | .BodySetStatic .NofBodies 40 | Next 41 | 42 | .JointAddDistanceJ 20 + 6, 5, 200 43 | 44 | 45 | 46 | '-----------ROPE 47 | .BodyCREATECircle Vec2(100, 50), 10 48 | .BodySetStatic .NofBodies 49 | .BodyCREATECircle Vec2(100, 100), 10 50 | .BodyCREATECircle Vec2(100, 150), 10 51 | .BodyCREATECircle Vec2(100, 200), 10 52 | .BodyCREATECircle Vec2(100, 250), 10 53 | .JointAddDistanceJ .NofBodies, .NofBodies - 1, 50, 1, 0 54 | .JointAddDistanceJ .NofBodies - 1, .NofBodies - 2, 50, 1, 0 55 | .JointAddDistanceJ .NofBodies - 2, .NofBodies - 3, 50, 1, 0 56 | .JointAddDistanceJ .NofBodies - 3, .NofBodies - 4, 50, 1, 0 57 | 58 | 59 | .BodyCREATERandomPoly Vec2(500, 150) 60 | 61 | .JointAdd1PinJ .NofBodies, Vec2(30, 0), 50, 0.1, 0.1 62 | For I = 1 To .NofBodies 63 | .BodySetGroup I, 1 64 | .BodySetCollideWith I, ALL 65 | Next 66 | 67 | Case 1 68 | 69 | .BodyCREATEBox Vec2(PicW * 0.5, PicH - 15), PicW * 0.9, 25 70 | .BodySetStatic 1 71 | 72 | '-----------ROPE 73 | .BodyCREATECircle Vec2(100, 50), 7 74 | .BodySetStatic .NofBodies 75 | .BodyCREATECircle Vec2(100, 100), 7 76 | .BodyCREATECircle Vec2(100, 150), 7 77 | .BodyCREATECircle Vec2(100, 200), 7 78 | .BodyCREATECircle Vec2(100, 250), 7 79 | .JointAddDistanceJ .NofBodies, .NofBodies - 1, 50, 1, 0 80 | .JointAddDistanceJ .NofBodies - 1, .NofBodies - 2, 50, 1, 0 81 | .JointAddDistanceJ .NofBodies - 2, .NofBodies - 3, 50, 1, 0 82 | .JointAddDistanceJ .NofBodies - 3, .NofBodies - 4, 50, 1, 0 83 | 84 | .BodyCREATECircle Vec2(PicW * 0.75, PicH * 0.1), 7 85 | .BodySetStatic .NofBodies 86 | .BodyCREATEBox Vec2(PicW * 0.75, PicH * 0.2), 50, 20 87 | .JointAddDistanceJ .NofBodies, .NofBodies - 1, 100, 1, 0 88 | For I = 1 To .NofBodies 89 | .BodySetGroup I, 1 90 | .BodySetCollideWith I, ALL 91 | Next 92 | Case 2 '1PIN ' 93 | 94 | 95 | .BodyCREATEBox Vec2(PicW * 0.5, PicH - 15), PicW * 0.9, 25 96 | .BodySetStatic 1 97 | 98 | .BodyCREATEBox Vec2(PicW * 0.5, PicH * 0.5), 100, 20 99 | .JointAdd1PinJ .NofBodies, Vec2(0, 0), 0 100 | 101 | .BodyCREATEBox Vec2(PicW * 0.25, PicH * 0.5), 100, 20 102 | .JointAdd1PinJ .NofBodies, Vec2(-25, 0), 0 103 | 104 | .BodyCREATEBox Vec2(PicW * 0.75, PicH * 0.4), 100, 20 105 | .JointAdd1PinJ .NofBodies, Vec2(-25, 0), 50 106 | 107 | 108 | .BodyCREATEBox Vec2(PicW * 0.9, PicH * 0.1), 100, 20 109 | .JointAdd1PinJ .NofBodies, Vec2(-25, 0), 50, 0.005, 0.005 110 | For I = 1 To .NofBodies 111 | .BodySetGroup I, 1 112 | .BodySetCollideWith I, ALL 113 | Next 114 | 115 | Case 3 '"2 Pins Joints" 116 | 117 | 'Floor 118 | .BodyCREATEBox Vec2(PicW * 0.5, PicH - 15), PicW * 0.9, 25 119 | .BodySetStatic 1 120 | 121 | .BodyCREATEBox Vec2(PicW * 0.1 + 20, PicH * 0.5), 50, 20 122 | .JointAdd1PinJ .NofBodies, Vec2(-20, 0), 40, 0.01, 0 123 | 124 | For I = 1 To 5 125 | .BodyCREATEBox Vec2(PicW * 0.1 + 20 + 70 * I, PicH * 0.5), 50, 20 126 | ' .JointAdd1PinJ .NofBodies, Vec2(-20, 0), 40, 0.01, 0 127 | .JointAdd2PinsJ .NofBodies - 1, Vec2(20, 0), _ 128 | .NofBodies, Vec2(-20, 0), 30, 1, 0 129 | Next 130 | 131 | For I = 1 To .NofBodies 132 | .BodySetGroup I, 1 133 | .BodySetCollideWith I, ALL 134 | Next 135 | 136 | 137 | 138 | Case 4 '"2 Pins Joints II 139 | 140 | 'Floor 141 | .BodyCREATEBox Vec2(PicW * 0.5, PicH - 15), PicW * 0.9, 25 142 | .BodySetStatic 1 143 | 144 | ' .BodyCREATEBox 50, 20, Vec2(PicW * 0.1 + 20, PicH * 0.4) 145 | ' .JointAdd1PinJ .NofBodies, Vec2(-20, 0), 40, 0.5, 0 146 | .BodyCREATEBox Vec2(PicW * 0.05 + 70 * 0, PicH * 0.4), 50, 20 147 | .BodySetStatic .NofBodies 148 | 149 | For I = 1 To 8 150 | .BodyCREATEBox Vec2(PicW * 0.05 + 70 * I, PicH * 0.4), 50, 20 151 | .JointAdd2PinsJ .NofBodies - 1, Vec2(20, 0), _ 152 | .NofBodies, Vec2(-20, 0), 30, 0.125, 0 153 | Next 154 | 155 | .BodySetStatic .NofBodies 156 | For I = 1 To .NofBodies 157 | .BodySetGroup I, 1 158 | .BodySetCollideWith I, ALL 159 | Next 160 | Case 5 'Slope 161 | 162 | .BodyCREATEBox Vec2(PicW * 0.2, PicH * 0.45), PicW * 0.5, 25, PI * 0.25 163 | .BodySetStatic 1 164 | .BodyCREATEBox Vec2(PicW * 0.8, PicH * 0.45), PicW * 0.5, 25, PI * 0.75 165 | .BodySetStatic .NofBodies 166 | 167 | .BodyCREATEBox Vec2(PicW * 0.5, PicH * 0.75), 58, 22 168 | .JointAdd1PinJ .NofBodies, Vec2(-25, 0), 0, 0.006, 0.006 169 | .JointAdd1PinJ .NofBodies, Vec2(25, 0), 0, 0.006, 0.006 170 | 171 | For I = 1 To .NofBodies 172 | .BodySetGroup I, 1 173 | .BodySetCollideWith I, ALL 174 | Next 175 | Case 6 'Gum Bridge 176 | 177 | For I = 1 To 8 178 | .BodyCREATEBox Vec2((I - 0.5) * 82, PicH * 0.7), 58, 22 179 | .JointAdd1PinJ .NofBodies, Vec2(-25, 0), 0, 0.006, 0.006 180 | .JointAdd1PinJ .NofBodies, Vec2(25, 0), 0, 0.006, 0.006 181 | Next 182 | For I = 1 To .NofBodies 183 | .BodySetGroup I, 1 184 | .BodySetCollideWith I, ALL 185 | Next 186 | Case 7 '''' CAR 187 | 188 | .BodyCREATEBox Vec2(PicW * 0.5, PicH - 15), PicW * 1, 25 189 | .BodySetStatic 1 190 | 191 | For I = 1 To .NofBodies 192 | .BodySetGroup I, 1 193 | .BodySetCollideWith I, ALL 194 | Next 195 | 196 | .BodySetGroup .NofBodies - 1, .BiggerGroup * 2 '=2 197 | .BodySetGroup .NofBodies, .BiggerGroup * 2 '=4 198 | .BodySetCollideWith .NofBodies - 1, ALL - .BiggerGroup '=4 199 | .BodySetCollideWith .NofBodies, ALL - .BiggerGroup \ 2 '=2 200 | 201 | .BodyCREATEBox Vec2(100, 200), 150, 20 '40 202 | .BodyCREATECircle Vec2(100 - 50, 230), 20 'WHEEL 203 | .BodySetGroup .NofBodies - 1, .BiggerGroup * 2 204 | .BodySetGroup .NofBodies, .BiggerGroup * 2 205 | .BodySetCollideWith .NofBodies - 1, ALL - .BiggerGroup 206 | .BodySetCollideWith .NofBodies, ALL - .BiggerGroup \ 2 207 | .BodyCREATECircle Vec2(100 + 50, 230), 20 'WHEEL 208 | .BodySetGroup .NofBodies, .BiggerGroup 209 | .BodySetCollideWith .NofBodies, ALL - .BiggerGroup \ 4 210 | 211 | 212 | .JointAdd2PinsJ .NofBodies - 1, Vec2(0, 0), .NofBodies - 2, Vec2(0, 0), Sqr(50 * 50 + 30 * 30) 213 | .JointAdd2PinsJ .NofBodies, Vec2(0, 0), .NofBodies - 2, Vec2(0, 0), Sqr(50 * 50 + 30 * 30) 214 | 215 | .JointAdd2PinsJ .NofBodies - 1, Vec2(0, 0), .NofBodies - 2, Vec2(-50, 0), 30, 0.02, 0.02 216 | .JointAdd2PinsJ .NofBodies, Vec2(0, 0), .NofBodies - 2, Vec2(50, 0), 30, 0.02, 0.02 217 | 218 | 219 | 220 | .JoinAddRotorJ .NofBodies - 1, Vec2(20, 0), 0.07 221 | 222 | 223 | Case 8 'newton cardle 224 | 225 | 226 | 'Floor 227 | .BodyCREATEBox Vec2(PicW * 0.5, PicH - 15), PicW * 0.9, 25 228 | .BodySetStatic 1 229 | 230 | 231 | For I = 1 To 5 232 | 233 | .BodyCREATECircle Vec2(200 + I * 50, 50), 25 234 | .JointAdd1PinJ .NofBodies, Vec2(0, 0), 140, 0.1, 0.1 235 | 236 | Next 237 | 238 | 239 | For I = 1 To .NofBodies 240 | .BodySetGroup I, 1 241 | .BodySetCollideWith I, ALL 242 | Next 243 | 244 | Case 9 '''' Rotor2 245 | 246 | .BodyCREATEBox Vec2(PicW * 0.5, PicH - 15), PicW * 1, 25 247 | .BodySetStatic 1 248 | 249 | .BodyCREATEBox Vec2(100, 200), 80, 33 250 | .BodyCREATEBox Vec2(140, 200), 80, 33 251 | .JoinAddRotor2J .NofBodies - 1, Vec2(35, 0), .NofBodies, Vec2(-35, 0), 0.1, 0.1 252 | 253 | .BodyCREATEBox Vec2(400, 200), 85, 22 254 | .BodyCREATEBox Vec2(440, 200), 85, 22 255 | .JoinAddRotor2J .NofBodies - 1, Vec2(12, 0), .NofBodies, Vec2(-12, 0), 0.1, 0.1 256 | 257 | 258 | 259 | For I = 1 To .NofBodies 260 | .BodySetGroup I, 1 261 | .BodySetCollideWith I, ALL 262 | Next 263 | 264 | .BodySetGroup .NofBodies - 1, .BiggerGroup * 2 '=2 265 | .BodySetGroup .NofBodies, .BiggerGroup * 2 '=4 266 | .BodySetCollideWith .NofBodies - 1, ALL - .BiggerGroup '=4 267 | .BodySetCollideWith .NofBodies, ALL - .BiggerGroup \ 2 '=2 268 | 269 | 270 | .BodySetGroup .NofBodies - 3, .BiggerGroup * 2 '=2 271 | .BodySetGroup .NofBodies - 2, .BiggerGroup * 2 '=4 272 | .BodySetCollideWith .NofBodies - 3, ALL - .BiggerGroup '=4 273 | .BodySetCollideWith .NofBodies - 2, ALL - .BiggerGroup \ 2 '=2 274 | 275 | 276 | 277 | Case 10 278 | ' CAR 2 Vertices test 279 | Dim CarL As Double 280 | Dim CarH As Double 281 | Dim WR As Double 282 | Dim WDX As Double 283 | Dim WDY As Double 284 | 285 | 286 | CarL = 111 '80 287 | CarH = 15 '25 '30 288 | WDX = 30 289 | WDY = 20 290 | WR = 15 291 | 292 | .BodyCREATEBox Vec2(PicW * 0.5, PicH - 15), PicW * 1, 25 293 | .BodySetStatic 1 294 | 295 | 296 | For I = 1 To .NofBodies 297 | .BodySetGroup I, 1 298 | .BodySetCollideWith I, ALL 299 | Next 300 | 301 | .BodySetGroup .NofBodies - 1, .BiggerGroup * 2 '=2 302 | .BodySetGroup .NofBodies, .BiggerGroup * 2 '=4 303 | .BodySetCollideWith .NofBodies - 1, ALL - .BiggerGroup '=4 304 | .BodySetCollideWith .NofBodies, ALL - .BiggerGroup \ 2 '=2 305 | 306 | 307 | .BodyCREATEBox Vec2(50, 240), CarL, CarH, , True 308 | 309 | 310 | .BodyCREATECircle Vec2(50 - WDX, 240 + WDY), WR 'WHEEL 311 | .BodySetFriction .NofBodies, 0.5, 0.4 312 | 313 | .BodySetGroup .NofBodies - 1, .BiggerGroup * 2 314 | .BodySetGroup .NofBodies, .BiggerGroup * 2 315 | .BodySetCollideWith .NofBodies - 1, ALL - .BiggerGroup 316 | .BodySetCollideWith .NofBodies, ALL - .BiggerGroup \ 2 317 | 318 | .BodyCREATECircle Vec2(50 + WDX, 240 + WDY), WR 'WHEEL 319 | .BodySetFriction .NofBodies, 0.5, 0.4 320 | 321 | .BodySetGroup .NofBodies, .BiggerGroup 322 | .BodySetCollideWith .NofBodies, ALL - .BiggerGroup \ 4 323 | 324 | ''Diagonals 325 | .JointAdd2PinsJ .NofBodies - 1, Vec2(0, 0), .NofBodies - 2, Vec2(0, 0), Sqr(WDX * WDX + WDY * WDY) 326 | .JointAdd2PinsJ .NofBodies, Vec2(0, 0), .NofBodies - 2, Vec2(0, 0), Sqr(WDX * WDX + WDY * WDY) 327 | 328 | 'Vericals 329 | .JointAdd2PinsJ .NofBodies - 1, Vec2(0, 0), .NofBodies - 2, Vec2(-WDX, 0), WDY, 0.015, 0.015 330 | .JointAdd2PinsJ .NofBodies, Vec2(0, 0), .NofBodies - 2, Vec2(WDX, 0), WDY, 0.015, 0.015 331 | 332 | 333 | 334 | .JoinAddRotorJ .NofBodies - 1, Vec2(WR, 0), 0.07 335 | 336 | 337 | ReDim Vertices(3) 338 | 339 | Vertices(1) = Vec2(PicW * 0.25, PicH - 28) 340 | Vertices(2) = Vec2(PicW * 0.25 + 140, PicH - 28 - 40) 341 | Vertices(3) = Vec2(PicW * 0.25 + 140, PicH - 28) 342 | 343 | .BodyCREATEPolygon Vertices 344 | ' .BodySetStatic .NofBodies 345 | .BodySetGroup .NofBodies, 1 346 | .BodySetCollideWith .NofBodies, ALL 347 | 348 | For I = 1 To UBound(Vertices) 349 | Vertices(I) = Vec2ADD(Vertices(I), Vec2(255, 0)) 350 | Next 351 | ' Vertices(4) = Vec2ADD(Vertices(4), Vec2(-50, 0)) 352 | .BodyCREATEPolygon Vertices 353 | '' .BodySetStatic .NofBodies 354 | .BodySetGroup .NofBodies, 1 355 | .BodySetCollideWith .NofBodies, ALL 356 | 357 | 358 | 359 | 360 | 361 | Case 11 '"2 Pins Joints" 362 | 363 | 'Floor 364 | .BodyCREATEBox Vec2(PicW * 0.5, PicH - 15), PicW * 0.9, 25 365 | .BodySetStatic 1 366 | 367 | .BodyCREATEBox Vec2(PicW * 0.5 + 20, PicH * 0.25), 50, 20 368 | .JointAdd1PinJ .NofBodies, Vec2(-20, 0), 40, 0.01, 0 369 | 370 | For I = 1 To 2 371 | .BodyCREATEBox Vec2(PicW * 0.5 + 20 + 70 * I, PicH * 0.25), 50, 20 372 | ' .JointAdd1PinJ .NofBodies, Vec2(-20, 0), 40, 0.01, 0 373 | 374 | Next 375 | 376 | .JointAdd2PinsJ .NofBodies - 2, Vec2(20, 0), _ 377 | .NofBodies - 1, Vec2(-20, 0), 30, 1, 0 378 | 379 | 380 | .JointAdd2PinsAlignedJ .NofBodies, .NofBodies - 1, 60, Vec2(1, 0), 0.01, 0.01 381 | 382 | For I = 1 To .NofBodies 383 | .BodySetGroup I, 1 384 | .BodySetCollideWith I, ALL 385 | Next 386 | 387 | 388 | End Select 389 | 390 | 391 | End With 392 | 393 | End Sub 394 | 395 | -------------------------------------------------------------------------------- /clsTick.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "clsTick" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | ' Tick Class Module by Vesa Piittinen < http://merri.net/ > 15 | ' --------------------------------------------------------- 16 | ' Makes it possible to run portions of code X times a second! 17 | 18 | Option Explicit 19 | 20 | ' default setting for late indicator 21 | Private Const DEFAULT_LATETICKS As Currency = 20 22 | 23 | ' for better DoEvents handling 24 | Private Const QS_KEY = &H1& 25 | Private Const QS_MOUSEMOVE = &H2& 26 | Private Const QS_MOUSEBUTTON = &H4& 27 | Private Const QS_POSTMESSAGE = &H8& 28 | Private Const QS_TIMER = &H10& 29 | Private Const QS_PAINT = &H20& 30 | Private Const QS_SENDMESSAGE = &H40& 31 | Private Const QS_HOTKEY = &H80& 32 | Private Const QS_ALLINPUT = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY) 33 | Private Const QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON) 34 | Private Const QS_INPUT = (QS_MOUSE Or QS_KEY) 35 | Private Const QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY) 36 | 37 | ' tick data 38 | Private Type TICKS 39 | ID As Long ' identifier ID 40 | Count As Long ' number of ticks done 41 | Ending As Currency ' the next ending tick 42 | Freq As Currency ' tick frequency 43 | NoSkip As Boolean ' should always (atleast try) to stay on time? 44 | End Type 45 | 46 | ' internal variables 47 | Dim m_curFreq As Currency 48 | Dim m_curLateTick As Currency 49 | Dim m_curLateTicks As Currency 50 | Dim m_dblFreqToMS As Double 51 | 52 | Private Tick() As TICKS 53 | 54 | ' for better DoEvents handling 55 | Private Declare Function GetQueueStatus Lib "user32" (ByVal qsFlags As Long) As Long 56 | ' for timing 57 | Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long 58 | Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long 59 | ' to prevent 100% processor usage 60 | Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 61 | ' add a new timed event 62 | Public Function Add(ByVal FramesPerSecond As Double, Optional ByVal ID As Long = 0, Optional ByVal NoFrameSkip As Boolean = False) As Long 63 | Dim blnNoArrayInit As Boolean, lngNewIndex As Long 64 | ' check for invalid input values 65 | If ID < 0 Then Add = -1: Exit Function 66 | If FramesPerSecond <= 0 Then Add = -1: Exit Function 67 | ' check if array is initialized 68 | blnNoArrayInit = (Not Tick) = -1 69 | ' skip IDE error... 70 | On Error Resume Next: Debug.Assert 0.1: On Error GoTo 0 71 | ' if array is initialized, we can get UBound 72 | If Not blnNoArrayInit Then lngNewIndex = UBound(Tick) + 1 73 | ' add new item 74 | ReDim Preserve Tick(lngNewIndex) 75 | ' set settings 76 | With Tick(lngNewIndex) 77 | .ID = ID 78 | .Freq = CCur(CDbl(m_curFreq) / FramesPerSecond) 79 | End With 80 | ' return the new index 81 | Add = lngNewIndex 82 | End Function 83 | ' how many times a timed event has occurred? 84 | Public Function Count(ByVal Index As Long) As Long 85 | Dim blnNoArrayInit As Boolean 86 | ' invalid index? 87 | If Index < 0 Then Exit Function 88 | ' check if array is initialized 89 | blnNoArrayInit = (Not Tick) = -1 90 | ' skip IDE error... 91 | On Error Resume Next: Debug.Assert 0.1: On Error GoTo 0 92 | ' no array, nothing to remove 93 | If blnNoArrayInit Then Exit Function 94 | ' out of upper bound? 95 | If Index > UBound(Tick) Then Exit Function 96 | ' finally... return the count 97 | Count = Tick(Index).Count 98 | End Function 99 | ' how many times timed events of certain identifier have occurred? 100 | Public Function CountByID(ByVal ID As Long) As Long 101 | Dim blnNoArrayInit As Boolean, lngA As Long, lngCount As Long 102 | ' invalid ID? 103 | If ID < 0 Then Exit Function 104 | ' check if array is initialized 105 | blnNoArrayInit = (Not Tick) = -1 106 | ' skip IDE error... 107 | On Error Resume Next: Debug.Assert 0.1: On Error GoTo 0 108 | ' no array, nothing to remove 109 | If blnNoArrayInit Then Exit Function 110 | ' count totals by ID 111 | For lngA = 0 To UBound(Tick) 112 | If Tick(lngA).ID = ID Then lngCount = lngCount + Tick(lngA).Count 113 | Next lngA 114 | ' finally... return the count 115 | CountByID = lngCount 116 | End Function 117 | ' late indicator: changing this value sets how eagerly event is considered to be late 118 | Public Property Get LateIndicator() As Currency 119 | LateIndicator = m_curLateTicks 120 | End Property 121 | ' smaller value = less eager, bigger value = more eager 122 | ' bigger value means an event is moved easier further into the future 123 | Public Property Let LateIndicator(ByVal NewValue As Currency) 124 | If NewValue <= 1 Then Exit Property 125 | m_curLateTicks = NewValue 126 | m_curLateTick = -(m_curFreq / m_curLateTicks) 127 | End Property 128 | ' remove a timed event 129 | Public Function Remove(ByVal Index As Long) As Boolean 130 | Dim blnNoArrayInit As Boolean, lngA As Long, lngTicks As Long 131 | If Index < 0 Then Exit Function 132 | ' check if array is initialized 133 | blnNoArrayInit = (Not Tick) = -1 134 | ' skip IDE error... 135 | On Error Resume Next: Debug.Assert 0.1: On Error GoTo 0 136 | ' no array, nothing to remove 137 | If blnNoArrayInit Then Exit Function 138 | ' out of upper bound? 139 | lngTicks = UBound(Tick) - 1 140 | If (Index - 1) > lngTicks Then Exit Function 141 | ' finally, remove 142 | If lngTicks >= 0 Then 143 | ' remove the current index by overwriting 144 | For lngA = Index To lngTicks 145 | Tick(Index) = Tick(Index + 1) 146 | Next lngA 147 | ' remove last item 148 | ReDim Preserve Tick(lngTicks) 149 | Else 150 | ' remove whole array 151 | Erase Tick 152 | End If 153 | ' success 154 | Remove = True 155 | End Function 156 | ' remove timed events of certain identifier 157 | Public Function RemoveByID(ByVal ID As Long) As Long 158 | Dim blnNoArrayInit As Boolean, lngA As Long, lngB As Long, lngCount As Long 159 | If ID < 0 Then Exit Function 160 | ' check if array is initialized 161 | blnNoArrayInit = (Not Tick) = -1 162 | ' skip IDE error... 163 | On Error Resume Next: Debug.Assert 0.1: On Error GoTo 0 164 | ' no array, nothing to remove 165 | If blnNoArrayInit Then Exit Function 166 | ' loop through all items 167 | For lngA = UBound(Tick) To 0 Step -1 168 | ' remove ones with a matching ID 169 | If Tick(lngA).ID = ID Then 170 | If UBound(Tick) > 0 Then 171 | ' remove current item 172 | For lngB = lngA To UBound(Tick) - 1 173 | Tick(lngB) = Tick(lngB + 1) 174 | Next lngB 175 | ' remove the last item of the array 176 | ReDim Preserve Tick(UBound(Tick) - 1) 177 | ' increase counter 178 | lngCount = lngCount + 1 179 | Else 180 | ' remove the last item in array 181 | Erase Tick 182 | ' increase counter 183 | lngCount = lngCount + 1 184 | Exit For 185 | End If 186 | End If 187 | Next lngA 188 | ' return number of removed items 189 | RemoveByID = lngCount 190 | End Function 191 | ' reset event amount counter 192 | Public Function ResetCount(ByVal Index As Long) As Boolean 193 | Dim blnNoArrayInit As Boolean 194 | ' invalid index? 195 | If Index < 0 Then Exit Function 196 | ' check if array is initialized 197 | blnNoArrayInit = (Not Tick) = -1 198 | ' skip IDE error... 199 | On Error Resume Next: Debug.Assert 0.1: On Error GoTo 0 200 | ' no array, nothing to remove 201 | If blnNoArrayInit Then Exit Function 202 | ' out of upper bound? 203 | If Index > UBound(Tick) Then Exit Function 204 | ' finally... reset the count 205 | Tick(Index).Count = 0 206 | ResetCount = True 207 | End Function 208 | ' reset event amount counter of certain identifier 209 | Public Function ResetCountByID(ByVal ID As Long) As Long 210 | Dim blnNoArrayInit As Boolean, lngA As Long, lngCount As Long 211 | ' invalid ID? 212 | If ID < 0 Then Exit Function 213 | ' check if array is initialized 214 | blnNoArrayInit = (Not Tick) = -1 215 | ' skip IDE error... 216 | On Error Resume Next: Debug.Assert 0.1: On Error GoTo 0 217 | ' no array, nothing to remove 218 | If blnNoArrayInit Then Exit Function 219 | ' reset counts by ID 220 | For lngA = 0 To UBound(Tick) 221 | If Tick(lngA).ID = ID Then 222 | Tick(lngA).Count = 0 223 | lngCount = lngCount + 1 224 | End If 225 | Next lngA 226 | ' finally... return the amount of items we reseted 227 | ResetCountByID = lngCount 228 | End Function 229 | ' this can be used to make ticks occur based on same time 230 | ' if not used, all ticks start off at slightly different times 231 | Public Function Start() As Boolean 232 | Dim blnNoArrayInit As Boolean, curTick As Currency, lngA As Long 233 | ' check if array is initialized 234 | blnNoArrayInit = (Not Tick) = -1 235 | ' skip IDE error... 236 | On Error Resume Next: Debug.Assert 0.1: On Error GoTo 0 237 | ' no array, we can't start 238 | If blnNoArrayInit Then Exit Function 239 | ' get current tick 240 | QueryPerformanceCounter curTick 241 | ' set starting time for all 242 | For lngA = 0 To UBound(Tick) 243 | Tick(lngA).Ending = curTick 244 | Next lngA 245 | ' success! 246 | Start = True 247 | End Function 248 | ' this returns the INDEX of the next tick 249 | Public Function WaitForNext() As Long 250 | Dim curDifference As Currency, curTick As Currency, lngA As Long, lngIndex As Long 251 | ' WARNING! WE HAVE NO ERROR DETECTION! THIS FUNCTION ASSUMES THERE ARE TICKS! 252 | ' process DoEvents only if needed to 253 | If GetQueueStatus(QS_SENDMESSAGE Or QS_ALLEVENTS) <> 0 Then DoEvents 254 | ' figure out the next tick 255 | For lngA = 1 To UBound(Tick) 256 | If Tick(lngA).Ending < Tick(lngIndex).Ending Then lngIndex = lngA 257 | Next lngA 258 | ' increase counter 259 | Tick(lngIndex).Count = Tick(lngIndex).Count + 1 260 | ' get current tick 261 | QueryPerformanceCounter curTick 262 | ' because of the falling behind prevention, 263 | ' we need to set this if it is not initialized 264 | If Tick(lngIndex).Ending = 0 Then Tick(lngIndex).Ending = curTick 265 | ' then wait for the tick 266 | curDifference = Tick(lngIndex).Ending - curTick 267 | ' check if we are late or in advance; or perfectly on time 268 | If curDifference >= 0 Then 269 | ' we might be early, so we have to wait a bit 270 | lngA = CLng(CDbl(curDifference) * m_dblFreqToMS) 271 | ' wait for a few milliseconds if necessary 272 | If lngA > 0 Then Sleep lngA 273 | ' set the next time 274 | Tick(lngIndex).Ending = Tick(lngIndex).Ending + Tick(lngIndex).Freq 275 | Else 276 | If Not Tick(lngIndex).NoSkip Then 277 | ' we are late, but by how much? 278 | If curDifference > m_curLateTick Then 279 | ' not too badly, we can process the next tick right on time 280 | Tick(lngIndex).Ending = Tick(lngIndex).Ending + Tick(lngIndex).Freq 281 | Else 282 | ' we are so badly late in processing that we must SKIP PROCESSING 283 | ' if we wouldn't do this, then slow computers would just be all too slow 284 | Tick(lngIndex).Ending = curTick + Tick(lngIndex).Freq 285 | End If 286 | Else 287 | ' we are late, but this tick never skips 288 | Tick(lngIndex).Ending = Tick(lngIndex).Ending + Tick(lngIndex).Freq 289 | End If 290 | End If 291 | ' return index 292 | WaitForNext = lngIndex 293 | End Function 294 | ' this returns the ID of the next tick 295 | Public Function WaitForNextID() As Long 296 | Dim curDifference As Currency, curTick As Currency, lngA As Long, lngIndex As Long 297 | ' WARNING! WE HAVE NO ERROR DETECTION! THIS FUNCTION ASSUMES THERE ARE TICKS! 298 | ' process DoEvents only if needed to 299 | If GetQueueStatus(QS_SENDMESSAGE Or QS_ALLEVENTS) <> 0 Then DoEvents 300 | ' figure out the next tick 301 | For lngA = 1 To UBound(Tick) 302 | If Tick(lngA).Ending < Tick(lngIndex).Ending Then lngIndex = lngA 303 | Next lngA 304 | ' increase counter 305 | Tick(lngIndex).Count = Tick(lngIndex).Count + 1 306 | ' get current tick 307 | QueryPerformanceCounter curTick 308 | ' because of the falling behind prevention, 309 | ' we need to set this if it is not initialized 310 | If Tick(lngIndex).Ending = 0 Then Tick(lngIndex).Ending = curTick 311 | ' then wait for the tick 312 | curDifference = Tick(lngIndex).Ending - curTick 313 | ' check if we are late or in advance; or perfectly on time 314 | If curDifference >= 0 Then 315 | ' we might be early, so we have to wait a bit 316 | lngA = CLng(CDbl(curDifference) * m_dblFreqToMS) 317 | ' wait for a few milliseconds if necessary 318 | If lngA > 0 Then Sleep lngA 319 | ' set the next time 320 | Tick(lngIndex).Ending = Tick(lngIndex).Ending + Tick(lngIndex).Freq 321 | Else 322 | If Not Tick(lngIndex).NoSkip Then 323 | ' we are late, but by how much? 324 | If curDifference > m_curLateTick Then 325 | ' not too badly, we can process the next tick right on time 326 | Tick(lngIndex).Ending = Tick(lngIndex).Ending + Tick(lngIndex).Freq 327 | Else 328 | ' we are so badly late in processing that we must SKIP PROCESSING 329 | ' if we wouldn't do this, then slow computers would just be all too slow 330 | Tick(lngIndex).Ending = curTick + Tick(lngIndex).Freq 331 | End If 332 | Else 333 | ' we are late, but this tick never skips 334 | Tick(lngIndex).Ending = Tick(lngIndex).Ending + Tick(lngIndex).Freq 335 | End If 336 | End If 337 | ' return id 338 | WaitForNextID = Tick(lngIndex).ID 339 | End Function 340 | Private Sub Class_Initialize() 341 | ' get frequency (= length of a second) 342 | QueryPerformanceFrequency m_curFreq 343 | ' for converting frequency to MS 344 | m_dblFreqToMS = 1000 / CDbl(m_curFreq) 345 | ' set the default late indicator value 346 | m_curLateTicks = DEFAULT_LATETICKS 347 | m_curLateTick = -(m_curFreq / m_curLateTicks) 348 | End Sub 349 | Private Sub Class_Terminate() 350 | ' clear memory 351 | Erase Tick 352 | End Sub 353 | --------------------------------------------------------------------------------