Keskustelu: Koodit: VB6: OpenGL:n käyttö VB:llä

Option Explicit

Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long
Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Long) As Long

Private Const CCDEVICENAME = 32
Private Const CCFORMNAME = 32
Private Const DM_BITSPERPEL = &H40000
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000

Private Type DEVMODE
    dmDeviceName        As String * CCDEVICENAME
    dmSpecVersion       As Integer
    dmDriverVersion     As Integer
    dmSize              As Integer
    dmDriverExtra       As Integer
    dmFields            As Long
    dmOrientation       As Integer
    dmPaperSize         As Integer
    dmPaperLength       As Integer
    dmPaperWidth        As Integer
    dmScale             As Integer
    dmCopies            As Integer
    dmDefaultSource     As Integer
    dmPrintQuality      As Integer
    dmColor             As Integer
    dmDuplex            As Integer
    dmYResolution       As Integer
    dmTTOption          As Integer
    dmCollate           As Integer
    dmFormName          As String * CCFORMNAME
    dmUnusedPadding     As Integer
    dmBitsPerPel        As Integer
    dmPelsWidth         As Long
    dmPelsHeight        As Long
    dmDisplayFlags      As Long
    dmDisplayFrequency  As Long
End Type

Private hrc As Long
Private fullscreen As Boolean

Private rtri As GLfloat

Private OldWidth As Long
Private OldHeight As Long
Private OldBits As Long
Private OldVertRefresh As Long

Public Sub ReSizeGLScene(ByVal Width As GLsizei, ByVal Height As GLsizei)
' Alustaa GL ikkunan
    If Height = 0 Then              ' Näin estetään A Divide By Zero By errori
        Height = 1
    End If
    glViewport 0, 0, Width, Height  ' Resetoi nykyinen Viewportti
    glMatrixMode mmProjection       ' Valitsee Matriisin
    glLoadIdentity                  ' Resetoi Matrix

    ' Laskee suhteen ikkunaan
    gluPerspective 45#, Width / Height, 0.7, 100#

    glMatrixMode mmModelView        ' Valitsee Modelview Matriisin
    glLoadIdentity                  ' Ja resetoi sen
End Sub

Public Function InitGL() As Boolean
' Vähän asetuksia...
    glShadeModel smSmooth               'Pehmeä varjostus käyttöön

    glClearColor 0#, 0#, 0#, 0#         ' Musta tausta

    glClearDepth 1#                     ' Syvyys puskurointi asetus
    glEnable glcDepthTest               ' Syvyys testi
    glDepthFunc cfLEqual                ' Testin tyyppi

    glHint htPerspectiveCorrectionHint, hmNicest    ' Perspektiivin lasku

    InitGL = True
End Function


Public Sub KillGLWindow()
    If hrc Then                            'Hrc katsoo onko rendeöinti
        If wglMakeCurrent(0, 0) = 0 Then             'Voimmeko vapauttaa DC:n ja RC:n?
            MsgBox "DC:n ja RC:n vapautus epäonnistui.", vbInformation, "SHUTDOWN ERROR"
        End If

        If wglDeleteContext(hrc) = 0 Then           'Voidaanko RC poistaa?
            MsgBox "Release Rendering Context Failed.", vbInformation, "SHUTDOWN ERROR"
        End If
        hrc = 0                                     'Asettaa RC arvon nollaksi (NULL)
    End If

End Sub
Public Function CreateGLWindow(frm As Form, Width As Integer, Height As Integer, Bits As Integer, fullscreenflag As Boolean) As Boolean
    Dim PixelFormat As GLuint
    Dim pfd As PIXELFORMATDESCRIPTOR

    pfd.cAccumAlphaBits = 0
    pfd.cAccumBits = 0
    pfd.cAccumBlueBits = 0
    pfd.cAccumGreenBits = 0
    pfd.cAccumRedBits = 0
    pfd.cAlphaBits = 0
    pfd.cAlphaShift = 0
    pfd.cAuxBuffers = 0
    pfd.cBlueBits = 0
    pfd.cBlueShift = 0
    pfd.cColorBits = Bits
    pfd.cDepthBits = 16
    pfd.cGreenBits = 0
    pfd.cGreenShift = 0
    pfd.cRedBits = 0
    pfd.cRedShift = 0
    pfd.cStencilBits = 0
    pfd.dwDamageMask = 0
    pfd.dwflags = PFD_DRAW_TO_WINDOW Or PFD_SUPPORT_OPENGL Or PFD_DOUBLEBUFFER
    pfd.dwLayerMask = 0
    pfd.dwVisibleMask = 0
    pfd.iLayerType = PFD_MAIN_PLANE
    pfd.iPixelType = PFD_TYPE_RGBA
    pfd.nSize = Len(pfd)
    pfd.nVersion = 1

    PixelFormat = ChoosePixelFormat(frm.hDC, pfd)
    If PixelFormat = 0 Then                     'Löysikö Windows sopivan pixeliformaatin?
        KillGLWindow
        MsgBox "Ei löydä sopivaa pixeliformaattia.", vbExclamation, "ERROR"
        CreateGLWindow = False
    End If

    If SetPixelFormat(frm.hDC, PixelFormat, pfd) = 0 Then 'Voimmeko asettaa pixeli formaatin
        KillGLWindow
        MsgBox "Ei voida asettaa pixeliformaattia.", vbExclamation, "ERROR"
        CreateGLWindow = False
    End If

    hrc = wglCreateContext(frm.hDC)
    If (hrc = 0) Then                           'Voidaanki renderoida?
        KillGLWindow
        MsgBox "Ei voida asettaa GL renderöintiä.", vbExclamation, "ERROR"
        CreateGLWindow = False
    End If

    If wglMakeCurrent(frm.hDC, hrc) = 0 Then    'Yritetään aktivoida renderöinti
        KillGLWindow
        MsgBox "Ei voida aktivoida GL renderöintiä.", vbExclamation, "ERROR"
        CreateGLWindow = False
    End If
    frm.Show                                    'Näytä ikkuna
    SetForegroundWindow frm.hWnd                'Vähän parempi prioriteetti
    ReSizeGLScene frm.ScaleWidth, frm.ScaleHeight 'Asettaa perspektiivin GL Näyttöön

    If Not InitGL() Then                        'Alusta uusi luotu GL ikkuna
        KillGLWindow                            'Resetoi ikkuna
        MsgBox "Alustus virhe.", vbExclamation, "ERROR"
        CreateGLWindow = False
    End If

    CreateGLWindow = True            'Ja valmis

End Function


Public Function DrawGLScene() As Boolean
  'Tässä piirretään kuvio
    glClear clrColorBufferBit Or clrDepthBufferBit  'Tyhjentää näytön sekä Syvyys puskurin
    glLoadIdentity

    glTranslatef 0#, 0#, -4#                      'Liikutta syvyys suunnassa 4 GL pistettä (tai mitä nyt ovat)
    glRotatef rtri, 0#, 0#, 1#          'Rotatoi Z akselin ympäri


    glBegin bmTriangles                  'Triangles eli käytetään kolmiota
        glColor3f 1#, 0#, 0#                        'Punainen
        glVertex3f 0#, 1, 0#                        'yläpuoli
        glColor3f 0#, 1#, 0#                        'vihreä
        glVertex3f -1#, -1#, 0#                     'vasen alhaalla
        glColor3f 0#, 0#, 1#                        'sininen
        glVertex3f 1#, -1#, 0#                      'alhaalla oikealla
    glEnd                                           'ja näin

    rtri = rtri + 0.2                   'Kasvattaa kolmion rotaatio muuttujaa

    DrawGLScene = True
End Function

Sub Main()
    Dim Done As Boolean
    Dim frm As Form
    Done = False

    'Luodaan OpenGL ikkuna
    Set frm = New Form1
    If Not CreateGLWindow(frm, 640, 480, 16, fullscreen) Then
        Done = True                             'Sulje jos ikkunaa ei luotu
    End If

    Do While Not Done
        '
        If (Not DrawGLScene) Then  'Päivitetään vain jos aktivoitu
            Unload frm                          'DrawGLScene merkitsee quittaamista
        Else                                    'Ei ole aikaa quitata, Päivitä näyttö
            SwapBuffers (frm.hDC)               'TublaPuskuri käyttöön
            DoEvents
        End If

        Done = frm.Visible = False              'Jos formi näkyy olemme valmiit
    Loop
    'Sulje
    Set frm = Nothing
    End
End Sub