VBAでOpenGLを使う

**VBAもOpenGLが使えます**

(まず最初に)
<font color="Red">**本コードでPCやデータに異常・損害が発生しても、作成者は一切責任を取りません。自己責任でお願いいたします。**
あと32bit版でしか動作確認してません。
</span>

なお、VBO/VAOは使用不可（多分）なので、遅いです。
ディスプレイリストで頑張る感じになると思います。
Win環境ならwglUseFontBitmapsA(W)利用で、文字列も表示可能です。
~~誰かいい感じの三次元グラフ作ってくんねーかな。~~



例：
![gl.gif](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/1225394/542ebb22-1ecc-86d8-1894-02d068c90993.gif)



```VB:UserForm1(フォーム：コマンドボタン・フレーム・スクロールバー要)
Private WithEvents glControl As GLFrame
Private GL As GL
Private stl As STLFile
Private Roll As Double, Pitch As Double, Mat() As Double
Private Material As Color4
Private Sub CommandButton1_Click()
    stl = LoadSTL(Application.GetOpenFilename)
    glControl.Refresh
End Sub
Private Sub UserForm_Initialize()
    Set glControl = New GLFrame
    Set GL = New GL
    ReDim Mat(3, 3) As Double
    Mat(0, 0) = 1: Mat(1, 1) = 1: Mat(2, 2) = 1: Mat(3, 3) = 1
    Material = Color4(0.3, 0.7, 0.3, 1)
End Sub
Private Sub UserForm_Activate()
    glControl.Init Me.Frame1, GL
End Sub
Private Sub GLControl_Load()
    With GL
        .Enable GL_LIGHT0
        .Enable GL_LIGHTING
        .Viewport 0, 0, glControl.Width, glControl.Height
        .Materialfv GL_FRONT, GL_AMBIENT_AND_DIFFUSE, VarPtr(Material)
    End With
    glControl.Refresh
End Sub
Private Sub ScrollBar1_Change()
    glControl.Refresh
End Sub
Private Sub GLControl_DragDelta(ByVal DeltaX As Double, DeltaY As Double, Button As Integer)
    If Button <> 1 Then Exit Sub
    Roll = Roll + DeltaX * 0.005
    Pitch = Pitch + DeltaY * 0.005
    Mat(0, 0) = Cos(Roll): Mat(1, 0) = -Sin(Roll): Mat(0, 1) = Sin(Roll): Mat(1, 1) = Cos(Roll)
    glControl.Refresh
End Sub
Private Sub GLControl_Paint()
    With GL
        .Clear GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT
        
        .MatrixMode GL_PROJECTION
        .LoadIdentity
        .Perspective Me.ScrollBar1.value, glControl.Width / glControl.Height, 10, 3000
        .LookAt 0, -1000, 1000, 0, 0, 50, 0, 0, 1

        .MatrixMode GL_MODELVIEW
        .LoadIdentity
        
        .MultMatrixd (VarPtr(Mat(0, 0)))
        If Not Not stl.Vertex Then
            .PushMatrix
                .EnableClientState GL_VERTEX_ARRAY
                .EnableClientState GL_NORMAL_ARRAY
                .NormalPointer GL_DOUBLE, 0, VarPtr(stl.Normal(0))
                .VertexPointer 3, GL_DOUBLE, 0, VarPtr(stl.Vertex(0))
                .DrawArrays GL_TRIANGLES, 0, UBound(stl.Vertex) + 1
                .DisableClientState GL_NORMAL_ARRAY
                .DisableClientState GL_VERTEX_ARRAY
            .PopMatrix
        End If
        .SwapBuffers
    End With
End Sub
```

よくあるサンプル表示と同じような感じ
OpenGLの描画開始は、Userform.Activate以降にしないと失敗します。


```VB:GLFrame(クラスモジュール)
Option Explicit
Private WithEvents Frame As MSForms.Frame
Private Const PIX_SCALE As Double = (1 / 72) * 96 '★環境依存
Public Event Load()
Public Event Paint()
Public Event DragDelta(ByVal DeltaX As Double, DeltaY As Double, Button As Integer)
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal IAcessible As Object, ByRef hWnd As LongPtr) As LongPtr
Private px As Double, py As Double
Private GL As GL
Private Sub Class_Terminate()
    GL.PaintEnd
End Sub
Private Sub Frame_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    px = X
    py = Y
End Sub
Private Sub Frame_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 0 Then Exit Sub
    RaiseEvent DragDelta(px - X, py - Y, Button)
    px = X: py = Y
End Sub
Public Sub Refresh()
    RaiseEvent Paint
End Sub
Public Property Get Width() As Double
    Width = Frame.Width * PIX_SCALE
End Property
Public Property Get Height() As Double
    Height = Frame.Height * PIX_SCALE
End Property
Public Sub Init(ByRef TargetFrame As MSForms.Frame, ByRef RefGL As GL)
    Dim hw As LongPtr
    Set GL = RefGL
    DoEvents
    WindowFromAccessibleObject TargetFrame, hw
    With TargetFrame
        .caption = ""
        .BorderStyle = fmBorderStyleSingle
        .SpecialEffect = fmSpecialEffectFlat
    End With
    With GL
        .hWnd = hw
        .PaintStart
        .ClearColor 1, 1, 1, 1
        .Enable GL_DEPTH_TEST
    End With
    Set Frame = TargetFrame
    DoEvents
    RaiseEvent Load
End Sub
```

OpenGLを使うためのフレームコントロール拡張クラス
OpenGLが描画の為に必要なハンドルを取得できるのは、
VBAではFormとFrameのみです(InkPicture等も可能ですが、オプション扱いだと思うので除外)。
なので、基本的に描画先はFrame一択です。

PIX_SCALE計算はOpenGLが**ピクセル単位の縦/横幅**を要求するので必要ですが、
環境依存なので、必要に応じて書き換える必要があります。




```VB:GLH(標準モジュール)
Option Explicit
Public Enum Glenum
    GL_AMBIENT_AND_DIFFUSE = &H1602
    GL_COLOR_BUFFER_BIT = &H4000
    GL_DEPTH_BUFFER_BIT = &H100
    GL_DEPTH_TEST = &HB71
    GL_LIGHT0 = &H4000
    GL_LIGHTING = &HB50
    GL_MODELVIEW = &H1700
    GL_PROJECTION = &H1701
    GL_TRIANGLES = &H4
    GL_FRONT = 1028
    GL_VERTEX_ARRAY = 32884
    GL_NORMAL_ARRAY = 32885
    GL_DOUBLE = &H140A
    PFD_DOUBLEBUFFER = 1
    PFD_DRAW_TO_WINDOW = 4
    PFD_SUPPORT_OPENGL = 32
End Enum
Public Type PIXELFORMATDESCRIPTOR
    nSize As Long
    nVersion As Long
    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 Vector3d
    X As Double
    Y As Double
    z As Double
End Type
Public Type Color4
    R As Single
    G As Single
    B As Single
    A As Single
End Type
Public Type B4
    B(3) As Byte
End Type
Public Type S1
    S As Single
End Type
Public Type L1
    L As Long
End Type
Public Type STLFile
    Vertex() As Vector3d
    Normal() As Vector3d
End Type
Public Sub UserFormShow()
    Dim Form As Object
    Set Form = New UserForm1
    Form.Show
End Sub
Public Function B2Single(ByRef B1, ByRef B2, ByRef B3, ByRef B4) As Single
    Dim X As B4, Y As S1
    With X: .B(0) = B1: .B(1) = B2: .B(2) = B3: .B(3) = B4: End With
    LSet Y = X
    B2Single = Y.S
End Function
Public Function B2Long(ByRef B1, ByRef B2, ByRef B3, ByRef B4) As Long
    Dim X As B4, Y As L1
    With X: .B(0) = B1: .B(1) = B2: .B(2) = B3: .B(3) = B4: End With
    LSet Y = X
    B2Long = Y.L
End Function
Public Function Vector3d(ByVal X As Double, ByVal Y As Double, ByVal z As Double) As Vector3d
    With Vector3d: .X = X: .Y = Y: .z = z: End With
End Function
Public Function Color4(ByVal R As Single, ByVal G As Single, ByVal B As Single, ByVal A As Single) As Color4
    With Color4: .A = A: .B = B: .G = G: .R = R: End With
End Function
Public Function LoadSTL(FilePath) As STLFile
    Dim Vertex() As Vector3d, Normal() As Vector3d
    Dim inputFn As Long, Fcnt As Long, i As Long, k As Long, B() As Byte, L As Long, m As Long, n As Long
    inputFn = FreeFile
    Open FilePath For Binary As #inputFn
        ReDim B(LOF(inputFn))
        Get #inputFn, , B
    Close #inputFn
    Fcnt = -1 + 3 * B2Long(B(80), B(81), B(82), B(83))
    ReDim Vertex(Fcnt) As Vector3d
    ReDim Normal(Fcnt) As Vector3d
    i = 84
    Do
        L = k + 0
        m = k + 1
        n = k + 2
        Normal(L) = Vector3d(B2Single(B(i + 0), B(i + 1), B(i + 2), B(i + 3)), B2Single(B(i + 4), B(i + 5), B(i + 6), B(i + 7)), B2Single(B(i + 8), B(i + 9), B(i + 10), B(i + 11)))
        Normal(m) = Normal(L)
        Normal(n) = Normal(L)
        Vertex(L) = Vector3d(B2Single(B(i + 12), B(i + 13), B(i + 14), B(i + 15)), B2Single(B(i + 16), B(i + 17), B(i + 18), B(i + 19)), B2Single(B(i + 20), B(i + 21), B(i + 22), B(i + 23)))
        Vertex(m) = Vector3d(B2Single(B(i + 24), B(i + 25), B(i + 26), B(i + 27)), B2Single(B(i + 28), B(i + 29), B(i + 30), B(i + 31)), B2Single(B(i + 32), B(i + 33), B(i + 34), B(i + 35)))
        Vertex(n) = Vector3d(B2Single(B(i + 36), B(i + 37), B(i + 38), B(i + 39)), B2Single(B(i + 40), B(i + 41), B(i + 42), B(i + 43)), B2Single(B(i + 44), B(i + 45), B(i + 46), B(i + 47)))
        k = k + 3
        i = i + 50
    Loop Until k >= Fcnt
    LoadSTL.Vertex = Vertex
    LoadSTL.Normal = Normal
End Function
```

構造体や列挙の定義をしています。
10進数と16進数が混じっているのは、
16進数で32767以上の列挙体を宣言していると
マイナスの値になるからです~~ファック~~。
<font color="Red">
追記：私が未熟なだけでした。
16進表記でも後ろに&をつければOKです。
※コメント参照(**神アドバイス  by @nukie_53さん**)
</span>






STL読み込み用の関数も下記を参考に作成しました。
>https://www.hiramine.com/programming/3dmodelfileformat/stlfileformat.html

STL読み込み時に必要なバイト変換に関しては下記を参考にしました。
>https://qiita.com/rsuzuki101111/items/2b57d7eda708616e1315
>https://qiita.com/nukie_53/items/d3920bf3cfe230d9fbc8

```VB:GL(クラスモジュール)
Option Explicit
'■関数
'User32
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
'Gdi32
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function ChoosePixelFormat Lib "gdi32" (ByVal hdc As LongPtr, ByRef pfd As PIXELFORMATDESCRIPTOR) As Long
Private Declare PtrSafe Function SetPixelFormat Lib "gdi32" (ByVal hdc As LongPtr, ByVal format As Long, ByRef ppfd As PIXELFORMATDESCRIPTOR) As Long
Private Declare PtrSafe Function SwapBuffersA Lib "gdi32" Alias "SwapBuffers" (ByVal hdc As LongPtr) As Long
'/Glu拡張
Private Declare PtrSafe Sub gluPerspective Lib "glu32.dll" (ByVal FovY As Double, ByVal aspect As Double, ByVal zNear As Double, ByVal zfar As Double)
Private Declare PtrSafe Sub gluLookAt Lib "glu32.dll" (ByVal eyeX As Double, ByVal eyeY As Double, ByVal eyeZ As Double, _
                                                       ByVal centerX As Double, ByVal centerY As Double, ByVal centerZ As Double, _
                                                       ByVal upx As Double, ByVal upy As Double, ByVal upz As Double)
'OpenGL
'開始/終了処理
Private Declare PtrSafe Function wglCreateContext Lib "opengl32.dll" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function wglMakeCurrent Lib "opengl32.dll" (ByVal hdc As LongPtr, ByVal hGLRC As LongPtr) As Long
Private Declare PtrSafe Function wglDeleteContext Lib "opengl32.dll" (ByVal hdc As LongPtr) As Long
'座標系
Private Declare PtrSafe Sub glMultMatrixd Lib "opengl32.dll" (ByVal Ptr As LongPtr)
Private Declare PtrSafe Sub glMatrixMode Lib "opengl32.dll" (ByVal Glenum As Long)
Private Declare PtrSafe Sub glPushMatrix Lib "opengl32.dll" ()
Private Declare PtrSafe Sub glPopMatrix Lib "opengl32.dll" ()
Private Declare PtrSafe Sub glLoadIdentity Lib "opengl32.dll" ()
Private Declare PtrSafe Sub glViewport Lib "opengl32.dll" (ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long)
'ON/OFF
Private Declare PtrSafe Sub glEnable Lib "opengl32.dll" (ByVal Glenum As Long)
Private Declare PtrSafe Sub glDisable Lib "opengl32.dll" (ByVal Glenum As Long)
Private Declare PtrSafe Sub glEnableClientState Lib "opengl32.dll" (ByVal Glenum As Long)
Private Declare PtrSafe Sub glDisableClientState Lib "opengl32.dll" (ByVal Glenum As Long)
'色
Private Declare PtrSafe Sub glMaterialfv Lib "opengl32.dll" (ByVal Face As Long, ByVal pname As Long, ByVal param As LongPtr)
Private Declare PtrSafe Sub glClear Lib "opengl32.dll" (ByVal Mask As Long)
Private Declare PtrSafe Sub glClearColor Lib "opengl32.dll" (ByVal red As Single, ByVal green As Single, ByVal blue As Single, ByVal alpha As Single)
'ポイント描画
Private Declare PtrSafe Sub glNormalPointer Lib "opengl32.dll" (ByVal Glenum As Long, ByVal Stride As Long, ByVal Ptr As LongPtr)
Private Declare PtrSafe Sub glVertexPointer Lib "opengl32.dll" (ByVal Size As Long, ByVal Glenum As Long, ByVal Stride As Long, ByVal Ptr As LongPtr)
Private Declare PtrSafe Sub glDrawArrays Lib "opengl32.dll" (ByVal Glenum As Long, ByVal First As Long, ByVal Size As Long)

'■変数
Private pfd As PIXELFORMATDESCRIPTOR
Public hformat As Long, hGLRC As LongPtr, hdc As LongPtr
Private myhwnd As LongPtr
Public Sub EnableClientState(ByVal Gle As Glenum)
    Call glEnableClientState(Gle)
End Sub
Public Sub DisableClientState(ByVal Gle As Glenum)
    Call glDisableClientState(Gle)
End Sub
Public Sub VertexPointer(ByVal Size As Long, ByVal Gle As Glenum, ByVal Stride As Long, ByVal Ptr As LongPtr)
    Call glVertexPointer(Size, Gle, Stride, Ptr)
End Sub
Public Sub NormalPointer(ByVal Gle As Glenum, ByVal Stride As Long, ByVal Ptr As LongPtr)
    Call glNormalPointer(Gle, Stride, Ptr)
End Sub
Public Sub DrawArrays(ByVal Mode As Glenum, ByVal First As Long, ByVal Size As Long)
    Call glDrawArrays(Mode, First, Size)
End Sub
Public Sub MultMatrixd(ByVal Ptr As LongPtr)
    Call glMultMatrixd(Ptr)
End Sub
Public Sub PaintStart()
    Call wglMakeCurrent(hdc, hGLRC)
End Sub
Public Sub PaintEnd()
    Call SwapBuffersA(hdc)
    Call wglMakeCurrent(0, 0)
End Sub
Public Sub MakeCurrent(ByVal hdc As LongPtr, ByVal hGLRC As LongPtr)
    Call wglMakeCurrent(hdc, hGLRC)
End Sub
Public Sub SwapBuffers()
    Call SwapBuffersA(hdc)
End Sub
Public Sub Viewport(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long)
    Call glViewport(X, Y, Width, Height)
End Sub
Public Sub Enable(ByVal Gle As Glenum)
    Call glEnable(Gle)
End Sub
Public Sub Disable(ByVal Gle As Glenum)
    Call glDisable(Gle)
End Sub
Public Sub MatrixMode(ByVal Gle As Glenum)
    Call glMatrixMode(Gle)
End Sub
Public Sub Materialfv(ByVal GLe1 As Glenum, ByVal GLe2 As Glenum, ByVal param As LongPtr)
    Call glMaterialfv(GLe1, GLe2, param)
End Sub
Public Sub LoadIdentity()
    Call glLoadIdentity
End Sub
Public Sub PushMatrix()
    Call glPushMatrix
End Sub
Public Sub PopMatrix()
    Call glPopMatrix
End Sub
Public Sub Clear(Optional ByVal Mask As Long = 16384)
    Call glClear(Mask)
End Sub
Public Sub ClearColor(ByVal red As Single, ByVal green As Single, ByVal blue As Single, ByVal alpha As Single)
    Call glClearColor(red, green, blue, alpha)
End Sub
Public Sub Perspective(ByVal FovY As Double, ByVal aspect As Double, ByVal zNear As Double, ByVal zfar As Double)
    Call gluPerspective(FovY, aspect, zNear, zfar)
End Sub
Public Sub LookAt(ByVal eyeX As Double, ByVal eyeY As Double, ByVal eyeZ As Double, ByVal centerX As Double, ByVal centerY As Double, ByVal centerZ As Double, ByVal upx As Double, ByVal upy As Double, ByVal upz As Double)
    Call gluLookAt(eyeX, eyeY, eyeZ, centerX, centerY, centerZ, upx, upy, upz)
End Sub
'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Property Let hWnd(newPtr As LongPtr)
    myhwnd = newPtr
    Call Inithwnd
End Property
Public Property Get hWnd() As LongPtr
    hWnd = myhwnd
End Property
Private Sub Inithwnd() '前処理
    If hdc <> 0 Then Releasehwnd
    hdc = GetDC(myhwnd)
    hformat = ChoosePixelFormat(hdc, pfd)
    Call SetPixelFormat(hdc, hformat, pfd)
    hGLRC = wglCreateContext(hdc)
End Sub
Private Sub Releasehwnd()
    Call wglMakeCurrent(0, 0)
    Call wglDeleteContext(hGLRC)
    Call ReleaseDC(myhwnd, hdc)
End Sub
Private Sub Class_Initialize()
    With pfd
        .nSize = 40 ' LenB(pfd)
        .nVersion = 1
        .dwFlags = (PFD_DOUBLEBUFFER Or PFD_DRAW_TO_WINDOW Or PFD_SUPPORT_OPENGL)
        .cColorBits = 32
        .cRedBits = 0
        .cRedShift = 0
        .cGreenBits = 0
        .cGreenShift = 0
        .cBlueBits = 0
        .cBlueShift = 0
        .cAlphaBits = 0
        .cAlphaShift = 0
        .cAccumBits = 0
        .cAccumRedBits = 0
        .cAccumGreenBits = 0
        .cAccumBlueBits = 0
        .cAccumAlphaBits = 0
        .cDepthBits = 32
        .cStencilBits = 8
        .cAuxBuffers = 0
        .iLayerType = 0 'PFD_MAIN_PLANE
        .bReserved = 0
        .dwLayerMask = 0
        .dwVisibleMask = 0
        .dwDamageMask = 0
    End With
End Sub
Private Sub Class_Terminate()
    Call Releasehwnd
End Sub
```

OpenGLのラッパー（今回使う関数のみ）
必要に応じていろいろ追加してください。