thevolumecalcbak.bas

VB小游戏,三为动画效果,请大家留意 赌东道

Attribute VB_Name = "MyModule"
Option Explicit

'-- Constants for drawing functions
Public Const SRCAND = &H8800C6
Public Const SRCCOPY = &HCC0020
Public Const SRCERASE = &H440328
Public Const SRCINVERT = &H660046
Public Const SRCPAINT = &HEE0086
Public Const BLACKNESS = &H42
Public Const WHITENESS = &HFF0062

'-- Constants for Pens and Brush functions
Public Const PS_SOLID = 0
Public Const PS_DASH = 1
Public Const PS_DOT = 2
Public Const PS_DASHDOT = 3
Public Const PS_DASHDOTDOT = 4
Public Const PS_NULL = 5
Public Const PS_INSIDEFRAME = 6

'-- Other Contants
Public Const Pi = 3.14159265358979 / 180

'-- Types for drawing functions
Public Type POINTAPI
        X As Long
        Y As Long
End Type

'-- My own Type for the 3D objects information
Public Type My3DPosXYZType
    X As Long
    Y As Long
    Z As Long
End Type

Public Type My3DInfoType
    PosX As Long
    PosY As Long
    PosZ As Long
    TurnLR As Long
    TurnUD As Long
    TurnTU As Long
    MyPoints() As POINTAPI              '-- For storage after 2D convertion
    My3DPoints() As My3DPosXYZType      '-- Original 3D space Coordinates
    My3DCoordinates() As My3DPosXYZType '-- 3D space Coordinates after Rotations and Transformations
    DrawOrder() As Long                 '-- Order of which the 3D Panes will be drawn
End Type

'-- Device Context functions
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

'-- Drawing functions
Public Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long

'-- Pens and Brushes
Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

'-- Other functions
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

'-- Variables used for Device Context and Drawing functions
Public ScreenDC As Long        '--To store the handle to the Screen Device Context
Public BackBuffer As Long      '--To store the HDC (Handle to Device Context) to a Memory Device Context to be used as a BackBuffer
Public BackBitmap As Long      '--To store the Drawing Space Object Handle for the HDC that is used as the BackBuffer

'-- Variables to store Pen and Brush handles
Public MyPens() As Long
Public MyBrushes() As Long

'-- Variables For 3D Objects
Public ShapeA As My3DInfoType   '--3D Object = Cube
Public ShapeB As My3DInfoType   '--3D Object = Pyramid
Public ShapeC As My3DInfoType   '--3D Object = Cylinder
Public ShapeD As My3DInfoType   '--3D Object = Cone
Public ShapeE As My3DInfoType   '--3D Object = Sphere -- kinda useless but have to use in order not to violate the 3D Engine and Atomosphere

'-- Temporary Variables for miscellaneous use
Public Aa As Long
Public Ab As Long
Public Ac As Long
Public Ad As Long
Public Ax As Long
Public Ay As Long
Public TempDrawOrder() As Long
Public TempArray() As Long
Public TempPoints As My3DPosXYZType
Public Delay

Sub Main()
    
    InitializeDeviceContext
    'Testing
    Initialize3DObjects
    CreatePensBrushes
    
    Do
        'For Delay = 0 To 100000: Next Delay
        
        Ad = Ad + 1
        Ad = Ad Mod 360
        
        ShapeA.PosX = Sin((Ad) * Pi) * 400
        ShapeA.PosY = 0
        ShapeA.PosZ = Cos((Ad) * Pi) * 2000 + 3000
        ShapeA.TurnUD = ShapeA.TurnUD + 1 'Int(Rnd * 11) - 5
        ShapeA.TurnLR = ShapeA.TurnLR + 2 'Int(Rnd * 11) - 5
        ShapeA.TurnTU = ShapeA.TurnTU + 0 'Int(Rnd * 11) - 5
        'DrawShapeA
        
        ShapeB.PosX = Sin((Ad + 72) * Pi) * 400
        ShapeB.PosY = 0
        ShapeB.PosZ = Cos((Ad + 72) * Pi) * 2000 + 3000
        ShapeB.TurnUD = ShapeB.TurnUD + 0 'Int(Rnd * 11) - 5
        ShapeB.TurnLR = ShapeB.TurnLR + 2 'Int(Rnd * 11) - 5
        ShapeB.TurnTU = ShapeB.TurnTU + 1 'Int(Rnd * 11) - 5
        'DrawShapeB
        
        ShapeC.PosX = Sin((Ad + 144) * Pi) * 400
        ShapeC.PosY = 0
        ShapeC.PosZ = Cos((Ad + 144) * Pi) * 2000 + 3000
        ShapeC.TurnUD = ShapeC.TurnUD + 3
        ShapeC.TurnLR = ShapeC.TurnLR + 2
        ShapeC.TurnTU = ShapeC.TurnTU + 1
        'DrawShapeC
        
        ShapeD.PosX = Sin((Ad + 216) * Pi) * 400
        ShapeD.PosY = 0
        ShapeD.PosZ = Cos((Ad + 216) * Pi) * 2000 + 3000
        ShapeD.TurnUD = ShapeD.TurnUD + 1
        ShapeD.TurnLR = ShapeD.TurnLR + 2
        ShapeD.TurnTU = ShapeD.TurnTU + 1
        'DrawShapeD
        
        ShapeE.PosX = Sin((Ad + 288) * Pi) * 400
        ShapeE.PosY = 0
        ShapeE.PosZ = Cos((Ad + 288) * Pi) * 2000 + 3000
        'DrawShapeE
        
        DrawAllShapes
        
        Ax = ((Screen.Width / Screen.TwipsPerPixelX) - 320) / 2
        Ay = ((Screen.Height / Screen.TwipsPerPixelY) - 240) / 2
        BitBlt ScreenDC, Ax, Ay, 320, 240, BackBuffer, 0, 0, SRCCOPY
        BitBlt BackBuffer, 0, 0, 320, 240, BackBuffer, 0, 0, WHITENESS
        DoEvents
    Loop Until GetAsyncKeyState(27) < -1
    
    DeletePensBrushes
    ReleaseDeviceContext
End Sub

'-- This Sub Initializes all the Memory Device Context
Sub InitializeDeviceContext()
'----Retrieving the handle to Screen Device Context
    ScreenDC = GetDC(0)

'----Creating Memory BackBuffer compatible to the current Screen mode
    BackBuffer = CreateCompatibleDC(ScreenDC)
    BackBitmap = CreateCompatibleBitmap(ScreenDC, 320, 240)
    DeleteObject SelectObject(BackBuffer, BackBitmap)

End Sub

'-- This Sub Unloads all the Memory Device Context
Sub ReleaseDeviceContext()
'----Releasing the handle to Screen Device Context
    ReleaseDC 0, ScreenDC

'----Flush the Memory BackBuffer
    DeleteDC BackBuffer
    DeleteObject BackBitmap

End Sub

'-- This Sub Sets all the neccesary variables for the 3D animation
Sub Initialize3DObjects()
'----Setting All the Variables
'----ShapeA - Cube
    ShapeA.PosX = 100
    ShapeA.PosY = 100
    ShapeA.PosZ = 100
    ShapeA.TurnLR = 0
    ShapeA.TurnUD = 0
    ShapeA.TurnTU = 0
    ReDim ShapeA.MyPoints(23)
    ReDim ShapeA.My3DPoints(23)
    ReDim ShapeA.My3DCoordinates(23)
    ReDim ShapeA.DrawOrder(5)
    
    ShapeA.My3DPoints(0).X = -100
    ShapeA.My3DPoints(0).Y = -100
    ShapeA.My3DPoints(0).Z = -100
    ShapeA.My3DPoints(1).X = 100
    ShapeA.My3DPoints(1).Y = -100
    ShapeA.My3DPoints(1).Z = -100
    ShapeA.My3DPoints(2).X = 100
    ShapeA.My3DPoints(2).Y = 100
    ShapeA.My3DPoints(2).Z = -100
    ShapeA.My3DPoints(3).X = -100
    ShapeA.My3DPoints(3).Y = 100
    ShapeA.My3DPoints(3).Z = -100
    
    ShapeA.My3DPoints(4).X = -100
    ShapeA.My3DPoints(4).Y = -100
    ShapeA.My3DPoints(4).Z = 100
    ShapeA.My3DPoints(5).X = 100
    ShapeA.My3DPoints(5).Y = -100
    ShapeA.My3DPoints(5).Z = 100
    ShapeA.My3DPoints(6).X = 100
    ShapeA.My3DPoints(6).Y = 100
    ShapeA.My3DPoints(6).Z = 100
    ShapeA.My3DPoints(7).X = -100
    ShapeA.My3DPoints(7).Y = 100
    ShapeA.My3DPoints(7).Z = 100
    
    ShapeA.My3DPoints(8).X = -100
    ShapeA.My3DPoints(8).Y = -100
    ShapeA.My3DPoints(8).Z = -100
    ShapeA.My3DPoints(9).X = -100
    ShapeA.My3DPoints(9).Y = 100
    ShapeA.My3DPoints(9).Z = -100
    ShapeA.My3DPoints(10).X = -100
    ShapeA.My3DPoints(10).Y = 100
    ShapeA.My3DPoints(10).Z = 100
    ShapeA.My3DPoints(11).X = -100
    ShapeA.My3DPoints(11).Y = -100
    ShapeA.My3DPoints(11).Z = 100
    
    ShapeA.My3DPoints(12).X = 100
    ShapeA.My3DPoints(12).Y = -100
    ShapeA.My3DPoints(12).Z = -100
    ShapeA.My3DPoints(13).X = 100
    ShapeA.My3DPoints(13).Y = 100
    ShapeA.My3DPoints(13).Z = -100
    ShapeA.My3DPoints(14).X = 100
    ShapeA.My3DPoints(14).Y = 100
    ShapeA.My3DPoints(14).Z = 100
    ShapeA.My3DPoints(15).X = 100
    ShapeA.My3DPoints(15).Y = -100
    ShapeA.My3DPoints(15).Z = 100
    
    ShapeA.My3DPoints(16).X = -100
    ShapeA.My3DPoints(16).Y = -100
    ShapeA.My3DPoints(16).Z = -100
    ShapeA.My3DPoints(17).X = 100
    ShapeA.My3DPoints(17).Y = -100
    ShapeA.My3DPoints(17).Z = -100
    ShapeA.My3DPoints(18).X = 100
    ShapeA.My3DPoints(18).Y = -100
    ShapeA.My3DPoints(18).Z = 100
    ShapeA.My3DPoints(19).X = -100
    ShapeA.My3DPoints(19).Y = -100
    ShapeA.My3DPoints(19).Z = 100
    
    ShapeA.My3DPoints(20).X = -100
    ShapeA.My3DPoints(20).Y = 100
    ShapeA.My3DPoints(20).Z = -100
    ShapeA.My3DPoints(21).X = 100
    ShapeA.My3DPoints(21).Y = 100
    ShapeA.My3DPoints(21).Z = -100
    ShapeA.My3DPoints(22).X = 100
    ShapeA.My3DPoints(22).Y = 100
    ShapeA.My3DPoints(22).Z = 100
    ShapeA.My3DPoints(23).X = -100
    ShapeA.My3DPoints(23).Y = 100
    ShapeA.My3DPoints(23).Z = 100
    
'----ShapeB - Pyramid
    ShapeB.PosX = 100
    ShapeB.PosY = 100
    ShapeB.PosZ = 100
    ShapeB.TurnLR = 0
    ShapeB.TurnUD = 0