[RESOLVED] open gl and layered window?

[Black_Storm]

hi,i attached a project with other language to used open gl and layered window (i guess its writed with vc++),any body can convert it to vb6 or any sample about open gl and layered window?

GLLayeredWindow.zip



i am looking for any sample with open gl to can draw or load image or teture then rotate or skew and etc and then show result like as layered window.

[Black_Storm]

any sample ?

[reexre]

Searching my hard disc I found eight chapters written by
Hans Henning Klein.
On the net they can be found here:
e.g. chapter 3
https://activevb.de/tutorials/opengl...tchapter3.html

translated to ENGLISH:
https://activevb-de.translate.goog/t..._x_tr_pto=wapp
(click "Example project for the tutorial" to download ZIP)

tutorial list:
https://activevb.de/tutorials/index-...ls.html#opengl

[Black_Storm]

thanks but It seems that the example you sent is more about OpenGL training. I had a lot of trainings like the old nehe websites, but my question is about the layered window. I still haven't found an example with the VB6 language, and only examples with I have found the language of VC++ and etc,i just want can draw with opengl and then show like as layered like as attached image or sample in post 1,
I also have the same problem, for example, to save the output as a photo in OpenGL with vb6 too,i found some samples with vc++ and etc again but in vb6?

[OptionBase1]

Still writing wish lists to Sample Claus?

[Black_Storm]

Still writing wish lists to Sample Claus?

Of course, I always try to achieve my goals and find answers to my questions, but don't you know that this is a simple question that there are many examples of in other languages, but in this case I still couldn't find an example for this situation


Always try to achieve your dreams and don't just give worthless answers that don't help

[Black_Storm]

I'm still searching about it, but it's strange that there are many examples in other languages, but I haven't found any in VB6 yet.

for example with vc++:
http://rsdn.org/article/opengl/layeredopengl.xml#ELB
https://stackoverflow.com/questions/...w-opengl-win32
https://www.dhpoware.com/demos/glLayeredWindows.html
https://stackoverflow.com/questions/...ent-background

or about render to image :
https://www.daniweb.com/programming/...ender-to-image

but int vb6?

[Black_Storm]

i edited this module to can save output opengl as bmp so my question in post 4 about how can save output opengl rendering solved with this :

Save OpenGl Output as BMP :

Option Explicit
Public Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, source As Any, ByVal length As Long)
Private Type BitmapInfoHeader
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BitmapFileHeader
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type
    
    Public Function LongToString(pLong) As String
        Dim lByte As Byte
        Dim lStr As String
        Dim lCpt
        On Error GoTo Gestion_Erreurs
        If pLong = 0 Then LongToString = "": Exit Function
        Do
            RtlMoveMemory lByte, ByVal pLong + lCpt, 1
            If lByte = 0 Then Exit Do
            lStr = lStr & Chr(lByte)
            lCpt = lCpt + 1
        Loop
        LongToString = lStr
        Exit Function
Gestion_Erreurs:
        LongToString = ""
    End Function
    
    Public Function SaveToBMP(pFile As String) As Boolean
        Dim f As Integer
        Dim lBFH As BitmapFileHeader
        Dim lHeader As BitmapInfoHeader
        Dim lImgData() As Byte
        Dim lView(1 To 4) As Long
        Dim lWidth As Long, lHeight As Long
        Dim lFormat As Long
        On Error GoTo Gestion_Erreurs:
        
        glGetIntegerv GL_VIEWPORT, lView(1)
        lWidth = lView(3) - lView(1)
        lHeight = lView(4) - lView(2)
        
        lHeader.biBitCount = 24
        lHeader.biCompression = 0&
        lHeader.biPlanes = 1
        lHeader.biWidth = lWidth
        lHeader.biHeight = lHeight
        lHeader.biSize = Len(lHeader)
        lHeader.biSizeImage = (lWidth * lHeight * 3) + (4 - ((lWidth * 3) Mod 4)) * lHeight
        
        ReDim lImgData(0 To Len(lHeader) + lHeader.biSizeImage - 1)
        
        
        RtlMoveMemory lImgData(0), lHeader, Len(lHeader)
        
        ' Data format depending on OpenGL version
        'If Val(LongToString(glGetString(GL_VERSION))) > 1.2 Or InStr(1, LongToString(glGetString(GL_EXTENSIONS)), "GL_EXT_BGRA", vbTextCompare) > 0 Then
         lFormat = &H80E0& ' = GL_BGR ou GL_BGR_EXT
        'Else
         'lFormat = &H1907& ' = GL_RGB
        'End If
        
        glReadPixels lView(1), lView(2), lWidth, lHeight, lFormat, GL_UNSIGNED_BYTE, lImgData(Len(lHeader))
        'If lFormat = &H1907& Then ConvertRGBtoBGR VarPtr(lImgData(Len(lHeader))), lWidth, lHeight ' = GL_RGB
        
        With lBFH
            .bfType = &H4D42
            #If VBA7 Then
                .bfOffBits = LenB(lBFH) + LenB(lHeader)
            #Else
                .bfOffBits = Len(lBFH) + Len(lHeader)
                #End If
                .bfSize = .bfOffBits + _
                lHeader.biSizeImage
            End With
            ' Recupere un numero de fichier
            f = FreeFile
            On Error Resume Next
            ' Supprime le fichier s'il existe
            Kill pFile
            On Error GoTo Gestion_Erreurs:
            ' Ouvre le fichier
            Open pFile For Binary As f
            ' Ecrit l'en-tete BMP
            Put f, , lBFH
            ' Ecrit les donnees image
            Put f, , lImgData
            ' Ferme le Fichier
Gestion_Erreurs:
            Close f
            
            If Err.Number = 0 Then SaveToBMP = True
        End Function
        
        '---------------------------------------------------------------------------------------
        ' Conversion de RGB vers BGR (utile si version 1.1)
        '---------------------------------------------------------------------------------------
        Private Function ConvertRGBtoBGR(pBits, pWidth As Long, pHeight As Long)
            Dim lByte As Byte
            Dim lCpt As Long
            For lCpt = 1 To pWidth * pHeight
                ' Conserve le B dans lByte
                RtlMoveMemory lByte, ByVal pBits + (lCpt - 1) * 3 + 2, 1
                ' Remplace le B par le R
                RtlMoveMemory ByVal pBits + (lCpt - 1) * 3 + 2, ByVal pBits + (lCpt - 1) * 3, 1
                ' Remplace le R par le B conservé dans lByte
                RtlMoveMemory ByVal pBits + (lCpt - 1) * 3, lByte, 1
            Next
        End Function

and about use after rendering :

Private Sub Command1_Click()
    SaveToBMP App.Path & "\demo.bmp"
End Sub

image result : https://postimg.cc/Cz4k8sj9


but still i am searching and working about render like as layered window so if any body found any sample about it send here.

[Black_Storm]

now i resolved my problem with that save as bmp module posted in no 8 like this :
image link : https://postimg.cc/LnQFFPfK


but if i want dont save as bmp file and then show like as layered so i guess its need convert output rendered like as dib and then show in picturebox or etc how can do that?

i did try for render in picturebox and then apply setlayeredwindow function but its not worked,i found this module for conver hdc to dib and dib to hdc too :

Option Explicit
 
Public Const BI_RGB = 0&
Public Const BI_RLE4 = 2&
Public Const BI_RLE8 = 1&
 
Public Const DIB_RGB_COLORS = 0 '  color table in RGBs
Public Const DIB_PAL_COLORS = 1 '  color table in palette indices
Public Const DIB_PAL_INDICES = 2 '  No color table indices into surf palette
Public Const DIB_PAL_PHYSINDICES = 2 '  No color table indices into surf palette
Public Const DIB_PAL_LOGINDICES = 4 '  No color table indices into DC palette
 
Public Const SRCCOPY = &HCC0020         ' (DWORD) dest = source
 
Public Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
 
Public Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
 
Public Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
 
Public Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As Long ' RGBQUAD
End Type
 
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 CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
Public Declare Function GetObjectType Lib "gdi32" (ByVal hgdiobj As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpbi As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpbi As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) 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
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
 
Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
 
Public Function GetBitmapData(hdc As Long, Width As Long, Height As Long, value() As Byte, Optional ByVal ReSize As Double = 1) As Boolean
    Dim bi As BITMAPINFO, mhDC As Long, bitsPtr As Long, hDIB As Long
    Dim bDibFrom() As Byte, Size As Long, old_bmp As Long, Ret As Long
    Dim RWidth As Integer, RHeight As Integer
    Dim tSAFrom As SAFEARRAY2D
    
    mhDC = CreateCompatibleDC(0)
    If mhDC <> 0 Then
        With bi.bmiHeader
            .biSize = Len(bi.bmiHeader)
            
            If ReSize <> 1 Then
                RWidth = Width * ReSize
                .biWidth = RWidth
                RHeight = Height * ReSize
                .biHeight = RHeight
            Else
                .biWidth = Width
                .biHeight = Height
            End If
            
            .biPlanes = 1
            .biBitCount = 24
            .biCompression = BI_RGB
            .biSizeImage = BytesPerScanLine(.biWidth, .biBitCount) * .biHeight
        End With
        
        hDIB = CreateDIBSection(mhDC, bi, DIB_RGB_COLORS, bitsPtr, 0, 0)
        
        If hDIB <> 0 Then
            old_bmp = SelectObject(mhDC, hDIB)
            
            If ReSize <> 1 Then
                Ret = StretchBlt(mhDC, 0, 0, Width * ReSize, Height * ReSize, hdc, 0, 0, Width, Height, SRCCOPY)
            Else
                Ret = BitBlt(mhDC, 0, 0, Width, Height, hdc, 0, 0, SRCCOPY)
            End If
        Else
            DeleteDC mhDC
            Exit Function
        End If
    End If
    
    Size = bi.bmiHeader.biSizeImage
    
    If (Size > 0) Then
        ReDim value(Size - 1)
        
        With tSAFrom
            .cbElements = 1
            .cDims = 2
            .Bounds(0).lLbound = 0
            .Bounds(0).cElements = bi.bmiHeader.biHeight
            .Bounds(1).lLbound = 0
            .Bounds(1).cElements = BytesPerScanLine(bi.bmiHeader.biWidth, bi.bmiHeader.biBitCount)
            .pvData = bitsPtr
        End With
        
        CopyMemory ByVal VarPtrArray(bDibFrom()), VarPtr(tSAFrom), 4
        CopyMemory value(0), bDibFrom(0, 0), Size
        
        'Clear the temporary array descriptor, This is necessary under NT4.
        CopyMemory ByVal VarPtrArray(bDibFrom), 0&, 4
    End If
    
    DeleteObject hDIB
    SelectObject mhDC, old_bmp
    DeleteDC mhDC
    
    GetBitmapData = True
End Function
 
Public Function SetBitmapData(ByVal hdc As Long, ByVal Width As Long, ByVal Height As Long, ByVal value As Long, Optional ByVal ReSize As Double = 1) As Boolean
    Dim bi As BITMAPINFO, mhDC As Long, bitsPtr As Long, hDIB As Long
    Dim bDibFrom() As Byte, old_bmp As Long, Ret As Long
    
    mhDC = CreateCompatibleDC(0)
    If mhDC <> 0 Then
        With bi.bmiHeader
            .biSize = Len(bi.bmiHeader)
            .biWidth = Width
            .biHeight = Height
            .biPlanes = 1
            .biBitCount = 24
            .biCompression = BI_RGB
            .biSizeImage = BytesPerScanLine(.biWidth, .biBitCount) * .biHeight
        End With
        
        hDIB = CreateDIBSection(mhDC, bi, DIB_RGB_COLORS, bitsPtr, 0, 0)
        
        If hDIB <> 0 Then
            old_bmp = SelectObject(mhDC, hDIB)
            Ret = SetDIBits(mhDC, hDIB, 0, bi.bmiHeader.biHeight, ByVal value, bi, DIB_RGB_COLORS)
            
            If ReSize <> 1 Then
                Ret = StretchBlt(hdc, 0, 0, Width * ReSize, Height * ReSize, mhDC, 0, 0, Width, Height, SRCCOPY)
            Else
                Ret = BitBlt(hdc, 0, 0, Width, Height, mhDC, 0, 0, SRCCOPY)
            End If
        Else
            DeleteDC mhDC
            Exit Function
        End If
    End If
    
    DeleteObject hDIB
    SelectObject mhDC, old_bmp
    DeleteDC mhDC
    
    SetBitmapData = Ret > 0
End Function
 
Public Function BytesPerScanLine(Width As Long, BitCount As Integer) As Long
    BytesPerScanLine = (Width * BitCount)
    If (BytesPerScanLine Mod 32 > 0) Then BytesPerScanLine = BytesPerScanLine + 32 - (BytesPerScanLine Mod 32)
    BytesPerScanLine = BytesPerScanLine \ 8
End Function

but i dont know how can use this module to can convert that rendered opengl and convert dib then show in picturebox

[The trick]

https://www.cyberforum.ru/blogs/354370/blog2760.html

[Black_Storm]

https://www.cyberforum.ru/blogs/354370/blog2760.html

i saw this before, your sample is base on direct x and when i wana run it show error.

if i wanna use codes there is some problem like as these :

you are using in makeScreenShot :

texRefl.LockRect 0, lrc, ByVal 0&, D3DLOCK_DISCARD
and
texRefl.UnlockRect 0

and then lrc used here :

StretchBlt dstDc, 0, 0, refQ, refQ, srcDc, 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, vbSrcCopy
memcpy ByVal lrc.pBits, ByVal lpDat, refQ * refQ * 4

in tmrFPS_Timer :

'srfOff.LockRect lrc, ByVal 0&, 0
'SetDIBitsToDevice Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, 0, 0, 0, Me.ScaleHeight, ByVal lrc.pBits, biWnd, 0
'srfOff.UnlockRect

so its need convert to opengl ,how can fix it or can you just send a sample used opengl drawing and show like as layred base on ur sample ?

i used this codes but not run correct , if i wanna disable make screen shot its jst run with empty invisible window and if i wanna enable that function its show error in this line :

memcpy ByVal VarPtr(lImgData(0)), ByVal lpDat, ScaleWidth * ScaleHeight * 4

all codes :

Option Explicit


Private Type Size
    cx  As Long
    cy  As Long
End Type


Private Type RGBQUAD
    rgbBlue     As Byte
    rgbGreen    As Byte
    rgbRed      As Byte
    rgbReserved As Byte
End Type


Private Type BITMAPINFOHEADER
    biSize          As Long
    biWidth         As Long
    biHeight        As Long
    biPlanes        As Integer
    biBitCount      As Integer
    biCompression   As Long
    biSizeImage     As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed       As Long
    biClrImportant  As Long
End Type


Private Type BITMAPINFO
    bmiHeader   As BITMAPINFOHEADER
    bmiColors   As RGBQUAD
End Type


Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, ByVal crKey As Long, pblend As Long, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC 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 SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const pi                As Double = 3.14159275180032
Private Const refQ              As Long = 512
Private Const WS_EX_LAYERED     As Long = &H80000
Private Const GWL_EXSTYLE       As Long = -20
Private Const ULW_ALPHA         As Long = &H2
Private Const AB_32Bpp255       As Long = 33488896
Private Const HTCAPTION         As Long = 2
Private Const WM_NCLBUTTONDOWN  As Long = &HA1
Private Const HWND_TOPMOST      As Long = -1
Private Const SWP_NOMOVE        As Long = &H2
Private Const SWP_NOSIZE        As Long = &H1


Private biWnd   As BITMAPINFO
Private mRot    As Single


Dim PrgRun As Boolean
Private hrc As Long


Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Then Unload Me
End Sub


Private Sub Form_Load()
    SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
    SetWindowLong Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    '
    biWnd.bmiHeader.biSize = Len(biWnd.bmiHeader)
    biWnd.bmiHeader.biBitCount = 32
    biWnd.bmiHeader.biHeight = -ScaleHeight
    biWnd.bmiHeader.biWidth = ScaleWidth
    biWnd.bmiHeader.biPlanes = 1
    
    'biWnd.bmiHeader.biBitCount = 24
    'biWnd.bmiHeader.biCompression = 0&
    biWnd.bmiHeader.biSizeImage = (ScaleWidth * ScaleWidth * 3) + (4 - ((ScaleWidth * 3) Mod 4)) * ScaleWidth
    drawgl
    
End Sub
Sub drawgl()
    PrgRun = True '
    If CreateGLWindow(Me, ScaleWidth, ScaleHeight, 24) Then
        tmrFPS.Enabled = True
    End If
End Sub


Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        ReleaseCapture
        SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
    End If
End Sub


Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static oy As Single
    If Button = vbRightButton Then mRot = mRot + (oy - Y) / 30
    oy = Y
End Sub


Private Sub tmrFPS_Timer()
    Static frame    As Long
    
    If PrgRun Then
        Static r3eck As GLfloat
        Static r4eck As GLfloat
        Dim lImgData() As Byte
        
        glClear clrColorBufferBit Or clrDepthBufferBit
        glLoadIdentity
        
        glTranslatef 0, 0, -1
        
        glRotatef r3eck, 0#, 1#, 0#
        
        glBegin bmTriangles
        
        glColor3f 1#, 0#, 0#
        glVertex3f 0#, 1#, 0#
        glColor3f 0#, 1#, 0#
        glVertex3f -1#, -1#, 1#
        glColor3f 0#, 0#, 1#
        glVertex3f 1#, -1#, 1#
        glColor3f 1#, 0#, 0#
        glVertex3f 0#, 1#, 0#
        glColor3f 0#, 0#, 1#
        glVertex3f 1#, -1#, 1#
        glColor3f 0#, 1#, 0#
        glVertex3f 1#, -1#, -1#
        glColor3f 1#, 0#, 0#
        glVertex3f 0#, 1#, 0#
        glColor3f 0#, 1#, 0#
        glVertex3f 1#, -1#, -1#
        glColor3f 0#, 0#, 1#
        glVertex3f -1#, -1#, -1#
        glColor3f 1#, 0#, 0#
        glVertex3f 0#, 1#, 0#
        glColor3f 0#, 0#, 1#
        glVertex3f -1#, -1#, -1#
        glColor3f 0#, 1#, 0#
        glVertex3f -1#, -1#, 1#
        glEnd
        
        SwapBuffers (Me.hdc)
        DoEvents
        
        
        If (frame Mod 20) = 0 Then makeScreenShot
        frame = frame + 1
        
        '        'srfOff.LockRect lrc, ByVal 0&, 0
        '        'SetDIBitsToDevice Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, 0, 0, 0, Me.ScaleHeight, ByVal lrc.pBits, biWnd, 0
        '        'srfOff.UnlockRect
        
        ReDim lImgData(0 To Len(biWnd.bmiHeader) + biWnd.bmiHeader.biSizeImage - 1)
        
        Dim lView(1 To 4) As Long
        Dim lWidth As Long, lHeight As Long
        
        glGetIntegerv GL_VIEWPORT, lView(1)
        lWidth = lView(3) - lView(1)
        lHeight = lView(4) - lView(2)
        
        memcpy lImgData(0), biWnd, Len(biWnd)
        glReadPixels lView(1), lView(2), ScaleWidth, ScaleHeight, &H80E0&, GL_UNSIGNED_BYTE, lImgData(Len(biWnd))
        SetDIBitsToDevice hdc, 0, 0, ScaleWidth, Me.ScaleHeight, 0, 0, 0, Me.ScaleHeight, ByVal VarPtr(lImgData(0)), biWnd, 0
        
        Dim pt  As Size
        Dim sz  As Size
        Dim pos As Size
        pt.cx = Me.Left / Screen.TwipsPerPixelX:  pt.cy = Me.Top / Screen.TwipsPerPixelY
        sz.cx = Me.ScaleWidth: sz.cy = Me.ScaleHeight
        UpdateLayeredWindow Me.hWnd, Me.hdc, pt, sz, Me.hdc, pos, 0, AB_32Bpp255, ULW_ALPHA
        
        r3eck = r3eck + 0.8
        r4eck = r4eck - 0.8
        
    Else
        If hrc <> 0 Then
            wglMakeCurrent 0, 0
            wglDeleteContext (hrc)
        End If
        tmrFPS.Enabled = False
        End
        
    End If
    
    
End Sub


Private Function makeScreenShot()
    '
    'glActiveTexture( GL_TEXTURE0 + unit );
    'glBindTexture( GL_TEXTURE_2D, backbufferTextureHandle );
    'glBindFramebuffer( GL_READ_FRAMEBUFFER, framebufferHandle );
    'glCopyTexSubImage2D(
    '        GL_TEXTURE_2D,
    '        0, // level
    '        0, 0, // offset
    '        0, 0, // x, y
    '        screenX, screenY );
    'glBindFramebuffer( GL_DRAW_FRAMEBUFFER, framebufferHandle );
    '
    '
    'glBindFramebuffer( GL_DRAW_FRAMEBUFFER, 0 ); // Default framebuffer
    'glBindFramebuffer( GL_READ_FRAMEBUFFER, framebufferHandle );
    'glBlitFramebuffer(
    '        0, 0, screenX, screenY,
    '        0, 0, screenX, screenY,
    '        GL_COLOR_BUFFER_BIT,
    '        GL_NEAREST
    
    
    
    Dim srcDc   As Long
    Dim dstDc   As Long
    Dim bi      As BITMAPINFO
    Dim oldBmp  As Long
    Dim newBmp  As Long
    Dim lpDat   As Long
    
    Dim lImgData() As Byte
    
    'Dim lrc  As D3DLOCKED_RECT
    'texRefl.LockRect 0, lrc, ByVal 0&, D3DLOCK_DISCARD
    
    srcDc = GetDC(0)
    If srcDc = 0 Then Unload Me: Exit Function
    dstDc = CreateCompatibleDC(srcDc)
    If dstDc = 0 Then Unload Me: Exit Function
    
    bi.bmiHeader.biBitCount = 32
    bi.bmiHeader.biHeight = -ScaleHeight
    bi.bmiHeader.biWidth = ScaleWidth
    bi.bmiHeader.biPlanes = 1
    bi.bmiHeader.biSize = Len(bi.bmiHeader)
    'biWnd.bmiHeader.biBitCount = 24
    'biWnd.bmiHeader.biCompression = 0&
    
    bi.bmiHeader.biSizeImage = (ScaleWidth * ScaleWidth * 3) + (4 - ((ScaleWidth * 3) Mod 4)) * ScaleWidth
    ReDim lImgData(0 To Len(bi.bmiHeader) + bi.bmiHeader.biSizeImage - 1)
    Dim lView(1 To 4) As Long
    Dim lWidth As Long, lHeight As Long
    glGetIntegerv GL_VIEWPORT, lView(1)
    lWidth = lView(3) - lView(1):     lHeight = lView(4) - lView(2)
    memcpy lImgData(0), bi, Len(bi)
    glReadPixels lView(1), lView(2), ScaleWidth, ScaleHeight, &H80E0&, GL_UNSIGNED_BYTE, lImgData(Len(bi))
    


    newBmp = CreateDIBSection(srcDc, bi, 0, lpDat, 0, 0)
    If newBmp = 0 Then Unload Me: Exit Function
    oldBmp = SelectObject(dstDc, newBmp)
    StretchBlt dstDc, 0, 0, ScaleWidth, ScaleHeight, srcDc, 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, vbSrcCopy
    
    'memcpy ByVal lrc.pBits, ByVal lpDat, refQ * refQ * 4
    memcpy ByVal VarPtr(lImgData(0)), ByVal lpDat, ScaleWidth * ScaleHeight * 4
    
    SelectObject dstDc, oldBmp
    DeleteObject newBmp
    DeleteDC dstDc
    ReleaseDC 0, srcDc
    ' texRefl.UnlockRect 0
End Function


Public Function CreateGLWindow(frm As Form, Width As Integer, Height As Integer, Bits As Integer) As Boolean
    Dim pfd As PIXELFORMATDESCRIPTOR ' pfd erklärt Windows, wie das Fenster beschaffen sein soll
    Dim PixelFormat As GLuint ' enthält das Ergebnis vom Versuch, ein Fenster mit den gegebenen Parametern zu erstellen
    
    pfd.cColorBits = Bits
    pfd.cDepthBits = 32
    pfd.dwFlags = PFD_DRAW_TO_WINDOW Or PFD_SUPPORT_OPENGL Or PFD_DOUBLEBUFFER
    pfd.iLayerType = PFD_MAIN_PLANE 'Die Hauptebene auf der gezeichnt wird.
    pfd.iPixelType = PFD_TYPE_RGBA 'Pixel werden im RGBA Modus dargestellt.
    pfd.nSize = Len(pfd) 'Größe der Struktur sollte natürlich stimmen
    pfd.nVersion = 1 'Versionsnummer
    
    PixelFormat = ChoosePixelFormat(frm.hdc, pfd) 'Windows nach einem oben beschriebenen Pixelformat fragen
    If PixelFormat <> 0 Then
        If SetPixelFormat(frm.hdc, PixelFormat, pfd) <> 0 Then
            'Einrichten des Pixelformates war erfolgreich
            hrc = wglCreateContext(frm.hdc)
            If hrc <> 0 Then
                'ein Rendering Kontext wurde erstellt
                If wglMakeCurrent(frm.hdc, hrc) <> 0 Then
                    'Der Kontext wurde aktiviert
                    frm.Show 'Fenster anzeigen
                    glShadeModel smSmooth 'schaltet schöne Farbübergange ein
                    glEnable GL_BLEND
                    glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA
                    
                    glClearColor 0#, 0#, 0#, 0# 'schwarzer Hintergrund
                    glClearDepth 1# 'Tiefenpuffer zurücksetzten (später mehr)
                    glEnable glcDepthTest 'Aktivierung des Tiefentests (später mehr)
                    glDepthFunc cfLEqual 'Typ des Tiefentests (später mehr)
                    glHint htPerspectiveCorrectionHint, hmNicest 'Art der Perspectivenansicht
                    'hmNicest = beste Ansicht / hmFastest = schnellste Darstellung
                    CreateGLWindow = True
                End If
            End If
        End If
    End If
End Function


Public Sub ReSizeGLScene(ByVal Width As GLsizei, ByVal Height As GLsizei)
    
    If Height = 0 Then
        Height = 1
    End If
    glViewport 0, 0, Width, Height
    glMatrixMode mmProjection
    glLoadIdentity
    
    gluPerspective 45#, Width / Height, 0.1, 100#
    
    glMatrixMode mmModelView
    glLoadIdentity
    
End Sub

[Black_Storm]

i made 2 another versions based on post 8,resolved better than post 9.