VBAもOpenGLが使えます
(まず最初に)
本コードでPCやデータに異常・損害が発生しても、作成者は一切責任を取りません。自己責任でお願いいたします。
あと32bit版でしか動作確認してません。
なお、VBO/VAOは使用不可（多分）なので、遅いです。
ディスプレイリストで頑張る感じになると思います。
Win環境ならwglUseFontBitmapsA(W)利用で、文字列も表示可能です。
誰かいい感じの三次元グラフ作ってくんねーかな。
例：
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以降にしないと失敗します。
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がピクセル単位の縦/横幅を要求するので必要ですが、
環境依存なので、必要に応じて書き換える必要があります。
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以上の列挙体を宣言していると
マイナスの値になるからですファック。
追記：私が未熟なだけでした。
16進表記でも後ろに&をつければOKです。
※コメント参照(神アドバイス by @nukie_53さん)
STL読み込み用の関数も下記を参考に作成しました。
https://www.hiramine.com/programming/3dmodelfileformat/stlfileformat.html
STL読み込み時に必要なバイト変換に関しては下記を参考にしました。
https://qiita.com/rsuzuki101111/items/2b57d7eda708616e1315
https://qiita.com/nukie_53/items/d3920bf3cfe230d9fbc8
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のラッパー（今回使う関数のみ）
必要に応じていろいろ追加してください。