Attribute VB_Name = "X3D"
Public Const PFD_DRAW_TO_WINDOW = &H4
Public Const PFD_SUPPORT_OPENGL = &H20
Public Const PFD_TYPE_RGBA = 0
Public Const PFD_MAIN_PLANE = 0
Global Const GL_TRIANGLES = &H4
Global Const GL_PROJECTION = &H1701
Global Const GL_QUADS = &H7&
Global Const GL_QUAD_STRIP = &H8
Global Const GL_DEPTH_TEST = &HB71
Global Const GL_MODELVIEW = &H1700
Global Const GL_FRONT = &H404
Global Const GL_BACK = &H405
Global Const GL_LIGHTING = &HB50
Global Const GL_LIGHT0 = &H4000
Global Const GL_LIGHT1 = &H4001
Global Const GL_LIGHT2 = &H4002
Global Const GL_LIGHT3 = &H4003
Global Const GL_LIGHT4 = &H4004
Global Const GL_LIGHT5 = &H4005
Global Const GL_LIGHT6 = &H4006
Global Const GL_LIGHT7 = &H4007
Global Const GL_AMBIENT_AND_DIFFUSE = &H1602

Public xr As GLfloat
Public yr As GLfloat
Public zr As GLfloat
Dim zx As Integer
Type PIXELFORMATDESCRIPTOR
nSize As Integer
nVersion As Integer
dwFlags As Long
iPixelType As Byte
cColorBits As Byte
cRedBits As Byte
cRedShift As Byte
cGreenBits As Byte
cGreenShift As Byte
cBlueBits As Byte
cBlueShift As Byte
cAlphaBits As Byte
cAlphaShift As Byte
cAccumBits As Byte
cAccumRedBits As Byte
cAccumGreenBits As Byte
cAccumBlueBits As Byte
cAccumAlphaBits As Byte
cDepthBits As Byte
cStencilBits As Byte
cAuxBuffers As Byte
iLayerType As Byte
bReserved As Byte
dwLayerMask As Long
dwVisibleMask As Long
dwDamageMask As Long
End Type
Public Type PARAVEC
R As Single
G As Single
B As Single
A As Single
End Type
Type Point3D
X As GLfloat
Y As GLfloat
Z As GLfloat
R As Byte
G As Byte
B As Byte
End Type
Type TriList
Points() As Point3D
PointNum As Integer
End Type
Type TDObject
Model As TriList
X As GLfloat
Y As GLfloat
Z As GLfloat
XRot As GLfloat
YRot As GLfloat
ZRot As GLfloat
ObjectName As String
End Type
Dim world(100) As TDObject
Dim worldnum As Integer
Dim PixFormat As Long
Dim ghDC As Long
Dim hRC As Long
Dim result As Long
Dim angle As Single
Dim pointer As Integer
Dim materials(100) As PARAVEC
Private Declare Function glGetError Lib "opengl32.dll" () As Long
Private Declare Function ChoosePixelFormat Lib "gdi32" (ByVal hdc As Long, pPixelFormatDescriptor As PIXELFORMATDESCRIPTOR) As Long
Private Declare Function SetPixelFormat Lib "gdi32" (ByVal hdc As Long, ByVal n As Long, pcPixelFormatDescriptor As PIXELFORMATDESCRIPTOR) As Boolean
Private Declare Function wglCreateContext Lib "opengl32.dll" (ByVal hdc As Long) As Long
Private Declare Sub wglMakeCurrent Lib "opengl32.dll" (ByVal hdc As Long, ByVal HGLRC As Long)
Private Declare Function wglDeleteContext Lib "opengl32.dll" (ByVal HGLRC As Long) As Long
Private Declare Sub glClear Lib "opengl32.dll" (ByVal Mask As Long)
Private Declare Sub glMatrixMode Lib "opengl32.dll" (ByVal mode As Long)
Private Declare Sub glLoadIdentity Lib "opengl32.dll" ()
Private Declare Sub gluPerspective Lib "glu32.dll" (ByVal fovy As Double, ByVal aspect As Double, ByVal zNear As Double, ByVal zFar As Double)
Private Declare Sub glVertex3f Lib "opengl32.dll" (ByVal X As Single, ByVal Y As Single, ByVal Z As Single)
Private Declare Sub glBegin Lib "opengl32.dll" (ByVal mode As Long)
Private Declare Sub glEnd Lib "opengl32.dll" ()
Private Declare Sub glEnable Lib "opengl32.dll" (ByVal cap As Long)
Private Declare Sub glRectf Lib "opengl32.dll" (ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single)
Private Declare Sub glPushMatrix Lib "opengl32.dll" ()
Private Declare Sub glPopMatrix Lib "opengl32.dll" ()
Private Declare Sub glCullFace Lib "opengl32.dll" (ByVal mode As Long)
Private Declare Sub glMaterialfv Lib "opengl32.dll" (ByVal face As Long, ByVal pname As Long, params As PARAVEC)
Private Declare Sub SwapBuffers Lib "gdi32" (ByVal hdc As Long)
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private 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
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Dim hdct As Long
Dim sx As Long
Dim sy As Long
Dim bb As Long
Dim bc As Long
Private Sub SetUpOGL(hdc As Long)  'Set the Screen Mode
Dim pfd As PIXELFORMATDESCRIPTOR
'Define the Screen Format
pfd.nSize = Len(pfd)
pfd.nVersion = 1
pfd.dwFlags = PFD_DRAW_TO_WINDOW Or PFD_SUPPORT_OPENGL
pfd.iPixelType = PFD_TYPE_RGBA
pfd.cColorBits = 24
pfd.cDepthBits = 32
pfd.iLayerType = PFD_MAIN_PLANE

Dim e As Long 'Make shure we are communicating with OpenGL
e = glGetError()

ghDC = hdc 'The DrawScreens DC
PixFormat = ChoosePixelFormat(ghDC, pfd)  'Select a pixel format
If PixFormat = 0 Then Stop 'If no possible pixel format than stop the program
result = SetPixelFormat(ghDC, PixFormat, pfd) 'Set the pixel/screen format
hRC = wglCreateContext(ghDC) 'Create the OpenGL Device Context
End Sub
Private Sub SetUpView(hdc As Long, ScaleWidth As Integer, ScaleHeight As Integer) 'Set up the viewport
Dim glnheight As Long
Dim glnwidth As Long
Dim gldAspect As Double

ghDC = hdc
Call wglMakeCurrent(ghDC, hRC) 'Set the current device context to the device context we created before
Call glMatrixMode(GL_PROJECTION) 'Set the clipper plane and junk
Call glLoadIdentity

glnwidth = ScaleWidth
glnheight = ScaleHeight
gldAspect = CDbl(glnwidth) / CDbl(glnheight)
Call gluPerspective(30#, gldAspect, 1#, 10#)

Call glViewport(0&, 0&, glnwidth, glnheight) 'Create the viewport
End Sub
Sub Init(hdc As Long, ScaleWidth As Integer, ScaleHeight As Integer)
SetUpOGL hdc
SetUpView hdc, ScaleWidth, ScaleHeight
Call glEnable(GL_DEPTH_TEST)
hdct = hdc
End Sub
Function Render()
Call glClear(GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT) 'Clear Graphics Buffer

For i% = 0 To worldnum - 1
glBegin GL_TRIANGLE_FAN
For Y% = 0 To world(i%).Model.PointNum
With world(i%).Model.Points(Y%)
glColor3f .R, .G, .B
glVertex3f .X + world(i%).X, .Y + world(i%).Y, .Z + world(i%).Z
End With
Next
glEnd
Next
glFlush
SwapBuffers hdct
Display_Screen = 1
End Function
Sub StartObject(PointNum As Integer, ObjectName As String)
ReDim world(worldnum).Model.Points(PointNum)
world(worldnum).ObjectName = ObjectName
worldnum = worldnum + 1
End Sub
Sub SetPoint(PointNum As Integer, X As Single, Y As Single, Z As Single, R As Byte, G As Byte, B As Byte)
Dim ObjectID As Integer
ObjectID = pointer
With world(ObjectID).Model.Points(PointNum)
.X = X
.Y = Y
.Z = Z
.R = R
.G = G
.B = B
End With
If world(ObjectID).Model.PointNum < PointNum Then
world(ObjectID).Model.PointNum = PointNum
End If
End Sub
Sub RotateObject(XRot As Single, YRot As Single, ZRot As Single)

'This rotation code is converted from a VB Programming book Called Animation Magic.  By Nick Lever(If i put the wrong name sry)  All the other code is by me
Const DEG2RAD = 0.01745329251994

Dim ax As Double, ay As Double, AZ As Double
    Dim bx As Double, by As Double, bz As Double
    Dim cx As Double, cy As Double, cz As Double
    Dim theta As Double, phi As Double, rho As Double, PF As Double
    Dim iCount As Integer, i As Integer
    
    theta = XRot * DEG2RAD
    phi = YRot * DEG2RAD
    rho = ZRot * DEG2RAD
    
    'Calculate coefficients for this object
    ax = Cos(phi) * Cos(rho)
    bx = -Cos(phi) * Sin(rho)
    cx = Sin(phi)
    ay = Sin(theta) * Sin(phi) * Cos(rho) + Cos(theta) * Sin(rho)
    by = -Sin(theta) * Sin(phi) * Sin(rho) + Cos(theta) * Cos(rho)
    cy = -Sin(theta) * Cos(phi)
    AZ = -Cos(theta) * Sin(phi) * Cos(rho) + Sin(theta) * Sin(rho)
    bz = Cos(theta) * Sin(phi) * Sin(rho) + Sin(theta) * Cos(rho)
    cz = Cos(theta) * Cos(phi)
    
    iCount = 0
    Dim pu As Integer
pu = pointer
        For pn = 0 To world(pu).Model.PointNum
        With world(pu).Model.Points(pn)
        'Transform vertex

        .X = (ax * .X + bx * .Y + cx * .Z)
        .Y = (ay * .X + by * .Y + cy * .Z)
        .Z = (AZ * .X + bz * .Y + cz * .Z)
        End With
    Next
    
End Sub
Function SetPointer(Name As String)
SetPointer = 0
For i% = 0 To worldnum
If world(i%).ObjectName = Name Then
pointer = i%
SetPointer = 1
End If
Next
End Function
Function ManualSetPointer(ObjectID As Integer)
pointer = ObjectID
End Function
Sub HideFaces(Back As Boolean)
If Back = True Then
glCullFace GL_FRONT
Else
glCullFace GL_BACK
End If
End Sub
Sub EnableLighting()
Call glEnable(GL_LIGHTING)
Call glEnable(GL_LIGHT0)
End Sub
Sub MoveObject(NewX As Single, NewY As Single, NewZ As Single)
world(pointer).X = NewX
world(pointer).Y = NewY
world(pointer).Z = NewZ
End Sub
Sub CleanUp()
Call wglMakeCurrent(vbNull, vbNull) 'Un Select the device context
result = wglDeleteContext(hRC) 'Delete the device context
End Sub