FreeBasic

Великолепный пример записи видео. В начале предоставляется возможность выбора кодека для сжатия, далее с помощью библиотеки OpenGL в окне проигрывается 3D анимация, которая как раз и записывается. Пример маленький, простой и информативный. 
Платформа: Windows.
Автор: D.J. Peters 2009  - Его сайт.

' AVI Encoder
' Written by D.J. Peters (2009)
' Exported to a single BI file by Kristopher Windsor

#INCLUDE Once "fbgfx.bi"

#INCLUDE "gl/gl.bi"

Const AVIIF_KEYFRAME = &H10


Enum FILEFLAGS
OF_WRITE  = &H0001

OF_CREATE = &H1000

End Enum


Enum AVISAVEFLAGS
ICMF_CHOOSE_KEYFRAME       = (1 Shl 0)
ICMF_CHOOSE_DATARATE       = (1 Shl 1)
ICMF_CHOOSE_PREVIEW        = (1 Shl 2)
ICMF_CHOOSE_ALLCOMPRESSORS = (1 Shl 3)
End Enum


Type AVIFileInfo
    As Uinteger dwMaxBytesPerSec
    As Uinteger dwFlags
    As Uinteger dwCaps
    As Uinteger dwStreams
    As Uinteger dwSuggestedBufferSize
    As Uinteger dwWidth
    As Uinteger dwHeight
    As Uinteger dwScale
    As Uinteger dwRate
    As Uinteger dwLength
    As Uinteger dwEditCount
    As String * 63 szFileType
End Type


Type AVIStreamInfo
    As Uinteger fccType
    As Uinteger fccHandler
    As Uinteger dwFlags
    As Uinteger dwCaps
    As Ushort   wPriority
    As Ushort   wLanguage
    As Uinteger dwScale
    As Uinteger dwRate
    As Uinteger dwStart
    As Uinteger dwLength
    As Uinteger dwInitialFrames
    As Uinteger dwSuggestedBufferSize
    As Uinteger dwQuality
    As Uinteger dwSampleSize
    As Uinteger l,t,w,b
    As Uinteger dwEditCount
    As Uinteger dwFormatChangeCount
    As String * 63 szName
End Type


Type AVICOMPRESSOPTIONS
    As Uinteger fccType
    As Uinteger fccHandler
    As Uinteger dwKeyFrameEvery
    As Uinteger dwQuality
    As Uinteger dwBytesPerSecond
    As Uinteger dwFlags
    As Any Ptr  lpFormat
    As Uinteger cbFormat
    As Any Ptr  lpParms
    As Uinteger cbParms
    As Uinteger dwInterleaveEvery
End Type


Type PAVICOMPRESSOPTIONS As AVICOMPRESSOPTIONS Ptr


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


Type AVISaveCallback As Function (Byval nPercent As Integer) As Integer

Type AVIFILE   As Any Ptr

Type AVISTREAM As Any Ptr


Declare Function String2FOURCC       Lib "winmm"    Alias "mmioStringToFOURCCA"  (Byval As String, Byval As UInteger=0) As Uinteger

Declare Sub      AVIFileInit         Lib "avifil32" Alias "AVIFileInit"
Declare Sub      AVIFileExit         Lib "avifil32" Alias "AVIFileExit"
Declare Function AVIFileOpen         Lib "avifil32" Alias "AVIFileOpenA"         (Byval As AVIFILE Ptr, Byval strfile As String, Byval flag As FILEFLAGS, Byval lpClass As Any Ptr) As Integer

Declare Function AVIFileRelease      Lib "avifil32" Alias "AVIFileRelease"       (Byval As AVIFILE) As Integer

Declare Function AVIFileCreateStream Lib "avifil32" Alias "AVIFileCreateStreamA" (Byval As AVIFILE, Byval As AVISTREAM Ptr, Byval As AVIStreamInfo Ptr) As Integer

Declare Function AVIStreamRelease    Lib "avifil32" Alias "AVIStreamRelease"     (Byval As AVISTREAM) As Integer

Declare Function AVIMakeCompressedStream Lib "avifil32" Alias "AVIMakeCompressedStream"(Byval As AVISTREAM Ptr, Byval As AVISTREAM , Byval As AVICOMPRESSOPTIONS Ptr, Byval lpClassHandler As Any Ptr) As Integer

Declare Function AVISaveOptions      Lib "avifil32" Alias "AVISaveOptions"       (Byval hParent  As Integer, Byval As AVISAVEFLAGS, Byval nStreams As Uinteger, Byval As AVISTREAM Ptr, Byval As PAVICOMPRESSOPTIONS Ptr) As Integer

Declare Function AVISaveOptionsFree  Lib "avifil32" Alias "AVISaveOptionsFree"   (Byval nStreams As Integer, Byval As PAVICOMPRESSOPTIONS Ptr) As Integer

Declare Function AVIStreamSetFormat  Lib "avifil32" Alias "AVIStreamSetFormat"   (Byval As AVISTREAM, Byval As Integer, Byval As Any Ptr, Byval As Integer) As Integer

Declare Function AVIStreamWrite      Lib "avifil32" Alias "AVIStreamWrite"       (Byval As AVISTREAM, Byval nPos As Integer, Byval nStream As Integer, Byval lpPixel As Any Ptr, Byval bytes As Integer, Byval flag As Integer, Byval swritten As Integer Ptr, Byval bwritten As Integer Ptr) As Integer


Dim Shared As AVIFILE             file
Dim Shared As AVISTREAM           stream
Dim Shared As AVISTREAM           encoderstream
Dim Shared As AVIStreamInfo       streaminfo
Dim Shared As AVICOMPRESSOPTIONS  compressoptions
Dim Shared As PAVICOMPRESSOPTIONS Ptr ArrayOptions
Dim Shared As BITMAPINFOHEADER    Bitmapformat

' avicapture.bi
' written by d.j.peters (joshy)
Dim Shared As Byte Ptr avi_lpBits, avi_lpScreen
Dim Shared As Integer avi_screen_x, avi_screen_y, avi_frame_rate, avi_frame_count, avi_hWin
Dim Shared As Double avi_timer

ArrayOptions = Callocate(4)
ArrayOptions[0] = @compressoptions

Sub avi_start (file_name  As String, _
    screen_x   As Integer, _
    screen_y   As Integer, _
    frame_rate As Integer)
    Dim As Integer ff = Freefile


    avi_screen_x = screen_x
    avi_screen_y = screen_y
    avi_frame_rate = frame_rate

    Open file_name For Output As ff: Close ff
    Screencontrol fb.GET_WINDOW_HANDLE, avi_hWin
    AVIFileInit

    If AVIFileOpen(@file, file_name, OF_WRITE Or OF_CREATE,0)<>0 Then

        AVIFileExit
        ? "error: AVIFileOpen!"
        Beep: Sleep: End 1

    End If

    With streaminfo
        .fccType = String2FOURCC("vids")
        .dwScale = 1

        .dwRate = avi_frame_rate
        .dwSuggestedBufferSize = avi_screen_x * avi_screen_y * 3 ' RGB
        .l = 0: .t = 0: .w = avi_screen_x:.b = avi_screen_y
    End With

    With BitmapFormat
        .biSize = 40

        .biWidth = avi_screen_x
        .biHeight = avi_screen_y
        .biPlanes = 1

        .biBitCount = 24

        .biCompression = 0 ' raw rgb
        .biSizeImage = avi_screen_x * avi_screen_y * 3 ' rgb
        avi_lpbits = Callocate(.biSizeImage)
    End With

    If AVIFileCreateStream(file, @stream, @streaminfo) Then

        AVIFileRelease(file)
        AVIFileExit
        ? "error: AVIFileCreateStream!": Beep: Sleep: End 1

    End If

    If AVISaveOptions(avi_hWin, &H7, 1, @stream,ArrayOptions) <> 1 Then

        AVIStreamRelease(stream)
        AVIFileRelease(file)
        AVIFileExit
        ? "error: AVISaveOptions!": Beep: Sleep: End 1

    End If

    If AVIMakeCompressedStream(@encoderstream,stream,ArrayOptions[0], 0) Then

        AVISaveOptionsFree(1, ArrayOptions)
        AVIStreamRelease(stream)
        AVIFileRelease(file)
        AVIFileExit
        ? "error: AVIMakeCompressedStream!": Beep: Sleep: End 1

    End If

    If AVIStreamSetFormat(encoderstream, 0, @BitmapFormat, 40) Then

        AVISaveOptionsFree(1, ArrayOptions)
        AVIStreamRelease(encoderstream)
        AVIStreamRelease(stream)
        AVIFileRelease(file)
        AVIFileExit
        ? "error: AVIStreamSetFormat!": Beep: Sleep: End 1

    End If

End Sub


Sub avi_capture
    Static As Integer x, y, d, s

    If avi_frame_count = 0 Then avi_timer = Timer


    avi_lpScreen = Screenptr

    ' from bottom to top
    avi_lpScreen += (avi_screen_y - 1) * (avi_screen_x * 4)
    For y=0 To avi_screen_y-1

        d = y * avi_screen_x * 3: s = 0

        For x = 0 To avi_screen_x - 1

            ' ARGB32 to RGB24
            avi_lpBits[d + 0] = avi_lpScreen[s + 0]
            avi_lpBits[d + 1] = avi_lpScreen[s + 1]
            avi_lpBits[d + 2] = avi_lpScreen[s + 2]
            d += 3: s += 4

        Next

        avi_lpScreen -= (avi_screen_x * 4)
    Next

    AVIStreamWrite(encoderstream, _
    avi_frame_count, _
    1, _
    avi_lpBits, _
    BitmapFormat.biSizeImage, 0, 0, 0)
    avi_frame_count += 1


    While avi_frame_count / (Timer - avi_timer) > avi_frame_rate: Wend 'limit FPS
End Sub


' save OpenGL framebuffer as AVI frame
Sub avi_capture_gl
    Dim As Ubyte tmp
    Dim As Ubyte Ptr lpRGB
    If avi_frame_count = 0 Then avi_timer = Timer

    ' get framebuffer
    glReadPixels(0,0,avi_screen_x,avi_screen_y,GL_RGB,GL_UNSIGNED_BYTE,avi_lpBits)
    ' swap red and blue
    lpRGB=avi_lpBits
    For i As Integer=0 To avi_screen_x*avi_screen_y-1

        tmp=lpRGB[0]
        lpRGB[0]=lpRGB[2]
        lpRGB[2]=tmp
        lpRGB+=3
    Next

    ' write one AVI frame
    AVIStreamWrite(encoderstream, avi_frame_count, 1, avi_lpBits, BitmapFormat.biSizeImage, 0, 0, 0)
    avi_frame_count += 1

    While (avi_frame_count / (Timer - avi_timer)) > avi_frame_rate
        Sleep 3

    Wend
End Sub


Sub avi_end
    ' now free saveoptions,release streams,file and dll
    AVISaveOptionsFree(1,ArrayOptions)
    AVIStreamRelease(EncoderStream)
    AVIStreamRelease(Stream)
    AVIFileRelease(File)
    AVIFileExit
End Sub


'главный файл

#INCLUDE "fbgfx.bi"
#INCLUDE "GL/gl.bi"

#INCLUDE "GL/glu.bi"



'
' main
'
Const scr_w=320

Const scr_h=240


Dim rtri As Single, rquad As Single


avi_start "test.avi", scr_w,scr_h, 20 ' 20 frames per second
Screenres scr_w,scr_h,,32,FB.GFX_OPENGL

glViewport     0,0,scr_w,scr_h
glMatrixMode   GL_PROJECTION
glLoadIdentity

gluPerspective 45, scr_w/scr_h, 0.1, 100

glMatrixMode   GL_MODELVIEW
glLoadIdentity

glShadeModel   GL_SMOOTH
glClearColor   0,0,0,1

glClearDepth   1

glEnable       GL_DEPTH_TEST
glDepthFunc    GL_LEQUAL
glHint         GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST

Do

    glClear        GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT
    glLoadIdentity
    glTranslatef   -1.5, 0, -6

    glRotatef      rtri, 0, 1, 0

    glBegin GL_TRIANGLES
    glColor3f 1, 0, 0:glVertex3f  0, 1, 0

    glColor3f 0, 1, 0:glVertex3f -1,-1, 0

    glColor3f 0, 0, 1:glVertex3f  1,-1, 0

    glEnd
    glLoadIdentity
    glTranslatef   1.5, 0  ,-6

    glRotatef      rquad,  1, 0  , 0

    glBegin GL_QUADS
    glColor3f 1, 0, 0:glVertex3f -1, 1, 0

    glColor3f 0, 1, 0:glVertex3f  1, 1, 0

    glColor3f 0, 0, 1:glVertex3f  1,-1, 0

    glColor3f 1, 1, 0:glVertex3f -1,-1, 0

    glEnd
    rtri  += 1

    rquad += 2

    avi_capture_gl
    Flip

Loop While Inkey = ""
avi_end
End