03-23-2025, 02:26 AM
I ran it and it works! Brilliant!
Then I tried modifying it to generate a longer video (3 minutes) at standard DV resolution (720x480), and added a simple progress counters to the loops.
And removed any DIM statements from inside the loops, because it seems inefficient to be redimming over and over again inside a loop.
(I notice a lot of folks just put DIM statements willy nilly inside the code, I was always taught to put them all up top, nice and neat!)
And I moved the file name into a parameter for CreateAvi and moved the erasing the file if it alread exists inside of that too.
But anyway, it started working, creating frames, and then the program just dies when it gets to 1799 frames.
I wonder why? (modified code below)
Then I tried modifying it to generate a longer video (3 minutes) at standard DV resolution (720x480), and added a simple progress counters to the loops.
And removed any DIM statements from inside the loops, because it seems inefficient to be redimming over and over again inside a loop.
(I notice a lot of folks just put DIM statements willy nilly inside the code, I was always taught to put them all up top, nice and neat!)
And I moved the file name into a parameter for CreateAvi and moved the erasing the file if it alread exists inside of that too.
But anyway, it started working, creating frames, and then the program just dies when it gets to 1799 frames.
I wonder why? (modified code below)
Code: (Select All)
' AVI file format
' https://qb64phoenix.com/forum/showthread.php?tid=3550
' From: Petr, Mini-Mod
' Date: 3/22/2025 4:42 AM
' I've been wanting this for a really long time. A program that creates a valid
' AVI format with sound. The following program only creates (does not play) an
' uncompressed AVI file, which also contains uncompressed stereo audio. For this
' reason, prepare about 180 megabytes of free disk space for the test. I think
' it's already quite complicated, so if I add compression to it, it would be much
' more complicated. I will deal with compression, but I don't know how far I will
' get, because I encounter many obstacles.
' I must warn you that Windows Media Player blurs the image due to the player's
' internal filters, VLC player has the best outputs. MPC-HC plays it too, but it
' rotates the image. I can rotate the image in AVI, but then it is rotated again
' in Windows Media Player and in VLC. It's kind of a beginning... and also an
' extreme. First I deal with compression in GIF and save every byte and now tens
' of MegaBytes are no big deal...
' It's uncompressed, so expect a data rate somewhere around 60 megabytes per
' second. QB64PE can handle that speed just fine.
' -----------------------------------------------------------------------------
' Program creates an uncompressed AVI file with uncompressed animation and uncompressed audio.
' The uncompressed format is easier to understand, though I discovered that the AVI file itself
' is a topic suitable for psychiatry...
' -------------------------
' Video Constants
' -------------------------
Const vidFPS = 30 ' Frames per second for the video
Const bytesPerPixel = 4 ' Each pixel in 32-bit image (BGRA) takes 4 bytes
Const cFileName$ = "VideoTest2.avi"
' -------------------------
' Structure Definitions
' -------------------------
Type AVIMainHeader
microSecPerFrame As Long ' Microseconds per frame
maxBytesPerSec As Long ' Maximum data rate
paddingGranularity As Long ' Padding granularity
flags As Long ' AVI flags (e.g., HASINDEX)
totalFrames As Long ' Total number of frames in the video
initialFrames As Long ' Initial frames (typically 0)
streams As Long ' Number of streams (video, audio, etc.)
suggestedBufferSize As Long ' Suggested buffer size for playback
width As Long ' Video width in pixels
height As Long ' Video height in pixels
reserved As String * 16 ' Reserved bytes (set to 0)
End Type
Type AVIStreamHeader
fccType As String * 4 ' Stream type (e.g., "vids" or "auds")
fccHandler As String * 4 ' Codec handler (e.g., "DIB " for uncompressed video)
flags As Long ' Stream flags
priority As Integer ' Priority (unused)
language As Integer ' Language code (unused)
initialFrames As Long ' Initial frames (unused)
scale As Long ' Time scale for the stream
rate As Long ' Data rate (scale/rate = FPS for video)
start As Long ' Start time (usually 0)
length As Long ' Length of the stream (in time units)
suggestedBufferSize As Long ' Suggested buffer size for the stream
quality As Long ' Quality indicator (-1 for default)
sampleSize As Long ' Sample size (0 for video, nonzero for audio)
frameLeft As Long ' For video: left coordinate of the source rectangle
frameTop As Long ' For video: top coordinate of the source rectangle
frameRight As Long ' For video: right coordinate of the source rectangle
frameBottom As Long ' For video: bottom coordinate of the source rectangle
End Type
Type BITMAPINFOHEADER
size As Long ' Size of this header (40 bytes)
width As Long ' Width of the image in pixels
height As Long ' Height of the image (negative for top–down)
planes As Integer ' Number of color planes (must be 1)
bitCount As Integer ' Bits per pixel (24 for 24-bit, 32 for 32-bit)
compression As Long ' Compression method (0 = BI_RGB for uncompressed)
sizeImage As Long ' Size of the image data in bytes
xPelsPerMeter As Long ' Horizontal resolution (pixels per meter)
yPelsPerMeter As Long ' Vertical resolution (pixels per meter)
clrUsed As Long ' Number of colors used (0 = all)
clrImportant As Long ' Number of important colors (0 = all)
End Type
Type WAVEFORMATEX
wFormatTag As Integer ' Audio format code (1 = PCM)
nChannels As Integer ' Number of audio channels (2 for stereo)
nSamplesPerSec As Long ' Sample rate in Hz
nAvgBytesPerSec As Long ' Average bytes per second
nBlockAlign As Integer ' Block alignment in bytes
wBitsPerSample As Integer ' Bits per sample (16 for 16-bit PCM)
cbSize As Integer ' Extra size (0 for PCM)
End Type
' Video Parameters
Dim numSeconds As Long ' how long video should carry on
Dim numFrames As Long ' 90 frames = 3 seconds of video
Dim frameWidth As Long ' Video width in pixels
Dim frameHeight As Long ' Video height in pixels
Dim frameSize As Long
' Create Test Frame Array
ReDim Frames(-1 To -1) As String
Dim i As Long
Dim s As String
Dim sm As _MEM
' -------------------------
' Video Parameters
' -------------------------
'numFrames = 90
numSeconds = 60 * 3 ' 3 minutes
numFrames = vidFPS * numSeconds
'frameWidth = 800: frameHeight = 600
frameWidth = 720: frameHeight = 480 ' standard DV resolution
frameSize = frameWidth * frameHeight * bytesPerPixel ' Total size of one 32-bit frame
ReDim Frames(1 To numFrames) As String
' -------------------------
' Create Test Frame Array
' -------------------------
s = Space$(frameSize)
$If WIN Then
pad$ = "\"
$Else
pad$ = "/"
$End If
fn$ = _CWD$ + pad$ + cFileName$
Print "Generating file "; fn$
preDest = _Dest ' Save current destination settings
Dim img As Long, img2 As Long
_Dest 0
Locate 2, 1: Print "numFrames=" + _Trim$(Str$(numFrames))
Locate 3, 1: Print "lbound(Frames) = " + _Trim$(Str$(LBound(Frames)))
Locate 4, 1: Print "ubound(Frames) = " + _Trim$(Str$(UBound(Frames)))
For i = 1 To numFrames
' SHOW PROGRESS
_Dest 0
Locate 5, 1
Print Right$(" " + _Trim$(Str$(i)), 6) + " of " + _Trim$(Str$(numFrames));
img2 = _NewImage(frameWidth, frameHeight, 32)
_Dest img2 'Set current destination to img2
Cls ' Set not transparent background in frame
_PrintMode _KeepBackground
' Draw 100 random colored lines
For x = 1 To 100
Line (Rnd * 50, Rnd * 50)-(Rnd * 750, Rnd * 550), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), B
Next x
' Print frame number text at a fixed position
_PrintString (350, 250), "Video Frame " + Str$(i), img2
img = _NewImage(frameWidth, frameHeight, 32)
' For VLC Player use this line:
' _PutImage (0, 0), img2, img, (0, frameHeight)-(frameWidth, 0)
' For WMP, MPC-HC Player use:
_PutImage (0, 0), img2, img
_FreeImage img2
sm = _MemImage(img)
_MemGet sm, sm.OFFSET, s
_MemFree sm
_FreeImage img
Frames(i) = s ' Store frame data as string
Next i
_Dest preDest ' Restore previous destination
' -------------------------
' Simulate Audio
' -------------------------
Dim sampleRate As Long: sampleRate = 44100 ' Audio sample rate in Hz
Dim totalSeconds As Long: totalSeconds = numFrames \ vidFPS ' Duration of video in seconds
Dim totalSamplesPerChannel As Long: totalSamplesPerChannel = totalSeconds * sampleRate
Dim totalSamples As Long: totalSamples = totalSamplesPerChannel * 2 ' Stereo: two channels
ReDim audioSamples(1 To totalSamples) As Integer
' Generate a tone with panning effect (from left to right)
Dim freq As Single: freq = 500 ' Starting frequency in Hz
Dim As Integer SampleL, SampleR ' Variables for left and right channel samples
Dim t As Single, normAmp As Single: normAmp = 0.9
Dim total2 As Long
total2 = totalSamplesPerChannel - 1
For i = 1 To total2
' SHOW PROGRESS
_Dest 0
Locate 6, 1
Print Right$(" " + _Trim$(Str$(i)), 6) + " of " + _Trim$(Str$(total2));
t = i / sampleRate
' Calculate pan value from 0 (left) to 1 (right)
pan = i / (totalSamplesPerChannel - 1)
' Left channel amplitude = 0.9*(1 - pan), right channel amplitude = 0.9*pan
If Rnd * 10 > 5 Then f = 5 Else f = -5
freq = freq + f
SampleL = 32767 * 0.9 * (1 - pan) * Sin(2 * 3.14159 * freq * t)
SampleR = 32767 * 0.9 * pan * Sin(2 * 3.14159 * freq * t)
audioSamples(2 * i + 1) = SampleL
audioSamples(2 * i + 2) = SampleR
Next i
' ---------------------------
' Create AVI file with audio
' ---------------------------
CreateAVI cFileName$, Frames(), frameWidth, frameHeight, numFrames, audioSamples(), sampleRate
Print "File created. Open it with your media player program. Recommended is VLC Player."
' -------------------------------------------------------------
' Function to write an AVI file with video + audio (16-bit PCM)
' -------------------------------------------------------------
Sub CreateAVI (FileName$, Frames() As String, frameWidth As Long, frameHeight As Long, _
numFrames As Long, audioSamples() As Integer, sampleRate As Long)
If _FileExists(FileName$) Then Kill FileName$
Dim frameSize As Long: frameSize = frameWidth * frameHeight * bytesPerPixel
Dim fileNum As Integer: fileNum = FreeFile
Open FileName$ For Binary As #fileNum
Dim videoDuration As Long
videoDuration = numFrames \ vidFPS
Dim totalAudioSamples As Long
totalAudioSamples = UBound(audioSamples)
Dim stereoFrames As Long
stereoFrames = totalAudioSamples \ 2
' -------------------------------------------
' Define chunk index structure for AVI index
' -------------------------------------------
Type ChunkIndex
chunkID As String * 4 ' Chunk identifier (e.g., "00db" for video, "01wb" for audio)
flags As Long ' Flags (e.g., keyframe flag)
offset As Long ' Offset of chunk data from start of 'movi' section
size As Long ' Size of chunk data in bytes
End Type
Dim maxChunks As Long
maxChunks = numFrames + videoDuration + 10
Dim idxArr(1 To maxChunks) As ChunkIndex
Dim idxCount As Long: idxCount = 0
' --------------------------------------------------------
' RIFF and AVI chunks
' --------------------------------------------------------
Dim riffHeader As String: riffHeader = "RIFF"
Dim tmpStr As String: tmpStr = riffHeader
Put #fileNum, , tmpStr
Dim riffSizePos As Long: riffSizePos = LOF(fileNum) + 1
Dim dummyLong As Long: dummyLong = 0
Put #fileNum, , dummyLong ' placeholder for RIFF size
Dim aviSig As String: aviSig = "AVI "
tmpStr = aviSig
Put #fileNum, , tmpStr
' --------------------------------------------------------
' LIST hdrl chunk (header list)
' --------------------------------------------------------
Dim listHdrl As String: listHdrl = "LIST"
tmpStr = listHdrl
Put #fileNum, , tmpStr
Dim hdrlSizePos As Long: hdrlSizePos = LOF(fileNum) + 1
Put #fileNum, , dummyLong ' placeholder for hdrl size
Dim hdrlSig As String: hdrlSig = "hdrl"
tmpStr = hdrlSig
Put #fileNum, , tmpStr
' --------------------------------------------------------
' avih chunk (Main AVI header)
' --------------------------------------------------------
Dim avihChunkID As String: avihChunkID = "avih"
tmpStr = avihChunkID
Put #fileNum, , tmpStr
Dim avihChunkSize As Long: avihChunkSize = 56
Put #fileNum, , avihChunkSize
Dim mainHdr As AVIMainHeader
mainHdr.microSecPerFrame = 1000000 \ vidFPS
mainHdr.maxBytesPerSec = frameSize * vidFPS
mainHdr.paddingGranularity = 0
mainHdr.flags = &H110 ' AVIF_HASINDEX flag
mainHdr.totalFrames = numFrames
mainHdr.initialFrames = 0
mainHdr.streams = 2 ' 2 streams: video + audio (stereo is 1 stream and mono also)
mainHdr.suggestedBufferSize = frameSize
mainHdr.width = frameWidth
mainHdr.height = frameHeight
mainHdr.reserved = String$(16, Chr$(0))
Put #fileNum, , mainHdr
' --------------------------------------------------------
' LIST strl chunk for video stream
' --------------------------------------------------------
Dim listStrlVid As String: listStrlVid = "LIST"
tmpStr = listStrlVid
Put #fileNum, , tmpStr
Dim strlVidSizePos As Long: strlVidSizePos = LOF(fileNum) + 1
Put #fileNum, , dummyLong
Dim strlVidSig As String: strlVidSig = "strl"
tmpStr = strlVidSig
Put #fileNum, , tmpStr
' -- strh (video stream header)
Dim strhVidID As String: strhVidID = "strh"
tmpStr = strhVidID
Put #fileNum, , tmpStr
Dim strhVidSize As Long: strhVidSize = 64
Put #fileNum, , strhVidSize
Dim streamHdrVid As AVIStreamHeader
streamHdrVid.fccType = "vids"
streamHdrVid.fccHandler = "DIB " ' Uncompressed video (DIB)
streamHdrVid.flags = 0
streamHdrVid.priority = 0
streamHdrVid.language = 0
streamHdrVid.initialFrames = 0
streamHdrVid.scale = 1
streamHdrVid.rate = vidFPS
streamHdrVid.start = 0
streamHdrVid.length = numFrames
streamHdrVid.suggestedBufferSize = frameSize
streamHdrVid.quality = -1
streamHdrVid.sampleSize = 0
streamHdrVid.frameLeft = 0
streamHdrVid.frameTop = 0
streamHdrVid.frameRight = frameWidth
streamHdrVid.frameBottom = frameHeight
Put #fileNum, , streamHdrVid
' --------------------------------------------------------
' -- strf (video format chunk) -> BITMAPINFOHEADER
' --------------------------------------------------------
Dim strfVidID As String: strfVidID = "strf"
tmpStr = strfVidID
Put #fileNum, , tmpStr
Dim strfVidSize As Long: strfVidSize = 40
Put #fileNum, , strfVidSize
Dim bmpInfo As BITMAPINFOHEADER
bmpInfo.size = 40
bmpInfo.width = frameWidth
bmpInfo.height = -frameHeight ' Negative height indicates top-down format
bmpInfo.planes = 1
bmpInfo.bitCount = 32
bmpInfo.compression = 0 ' BI_RGB = uncompressed
bmpInfo.sizeImage = frameSize
bmpInfo.xPelsPerMeter = 0
bmpInfo.yPelsPerMeter = 0
bmpInfo.clrUsed = 0
bmpInfo.clrImportant = 0
Put #fileNum, , bmpInfo
Dim currPos As Long
currPos = LOF(fileNum) + 1
Dim calcStrlVidSize As Long: calcStrlVidSize = currPos - strlVidSizePos - 4
Seek #fileNum, strlVidSizePos
Put #fileNum, , calcStrlVidSize
Seek #fileNum, currPos
' --------------------------------------------------------
' LIST strl chunk for audio stream
' --------------------------------------------------------
Dim listStrlAud As String: listStrlAud = "LIST"
tmpStr = listStrlAud
Put #fileNum, , tmpStr
Dim strlAudSizePos As Long: strlAudSizePos = LOF(fileNum) + 1
Put #fileNum, , dummyLong
Dim strlAudSig As String: strlAudSig = "strl"
tmpStr = strlAudSig
Put #fileNum, , tmpStr
' --------------------------------------------------------
' -- strh (audio stream header)
' --------------------------------------------------------
Dim strhAudID As String: strhAudID = "strh"
tmpStr = strhAudID
Put #fileNum, , tmpStr
Dim strhAudSize As Long: strhAudSize = 64
Put #fileNum, , strhAudSize
Dim streamHdrAud As AVIStreamHeader
streamHdrAud.fccType = "auds"
streamHdrAud.fccHandler = String$(4, 0) ' For PCM audio, this is typically empty
streamHdrAud.flags = 0
streamHdrAud.priority = 0
streamHdrAud.language = 0
streamHdrAud.initialFrames = 0
streamHdrAud.scale = 1
streamHdrAud.rate = sampleRate
streamHdrAud.start = 0
streamHdrAud.length = stereoFrames
streamHdrAud.suggestedBufferSize = sampleRate * 4 ' 2 channels x 2 bytes per sample (is used 16bit stereo waveform sound, 1 integer to 1 sample)
streamHdrAud.quality = -1
streamHdrAud.sampleSize = 4 ' 4 bytes per stereo sample (2 bytes left + 2 bytes right)
streamHdrAud.frameLeft = 0
streamHdrAud.frameTop = 0
streamHdrAud.frameRight = 0
streamHdrAud.frameBottom = 0
Put #fileNum, , streamHdrAud
' --------------------------------------------------------
' -- strf (audio format chunk) -> WAVEFORMATEX (16 bytes)
' --------------------------------------------------------
Dim strfAudID As String: strfAudID = "strf"
tmpStr = strfAudID
Put #fileNum, , tmpStr
Dim strfAudSize As Long: strfAudSize = 16
Put #fileNum, , strfAudSize
Dim wf As WAVEFORMATEX
wf.wFormatTag = 1
wf.nChannels = 2
wf.nSamplesPerSec = sampleRate
wf.wBitsPerSample = 16
wf.nBlockAlign = wf.nChannels * (wf.wBitsPerSample \ 8)
wf.nAvgBytesPerSec = wf.nSamplesPerSec * wf.nBlockAlign
wf.cbSize = 0
Put #fileNum, , wf
currPos = LOF(fileNum) + 1
Dim calcStrlAudSize As Long: calcStrlAudSize = currPos - strlAudSizePos - 4
Seek #fileNum, strlAudSizePos
Put #fileNum, , calcStrlAudSize
Seek #fileNum, currPos
currPos = LOF(fileNum) + 1
Dim hdrlSize As Long: hdrlSize = currPos - hdrlSizePos - 4
Seek #fileNum, hdrlSizePos
Put #fileNum, , hdrlSize
Seek #fileNum, currPos
' ----------------------------------------------------------
' LIST movi chunk (contains the actual video and audio data)
' ----------------------------------------------------------
Dim listMovi As String: listMovi = "LIST"
tmpStr = listMovi
Put #fileNum, , tmpStr
Dim moviSizePos As Long: moviSizePos = LOF(fileNum) + 1
Put #fileNum, , dummyLong
Dim moviSig As String: moviSig = "movi"
tmpStr = moviSig
Put #fileNum, , tmpStr
Dim moviDataStart As Long: moviDataStart = LOF(fileNum) + 1
' --------------------------------------------------------------
' Interleaved writing of video and audio chunks:
' For each second: 30 video frames and 1 audio chunk (1 second) - this solution MUST NOT BE ALWAYS OPTIMAL! is possible writing sound data after every 5 th frame...
' --------------------------------------------------------------
Dim framesPerSec As Long: framesPerSec = vidFPS
Dim videoIndex As Long: videoIndex = 1
Dim sec As Long
Dim f As Long
Dim chunkOffset As Long
Dim frameChunkID As String
Dim currFrameSize As Long
Dim padByte As String
Dim chunkOffsetAud As Long
Dim audioChunkID As String
Dim audioChunkSize As Long
Dim startAud As Long
Dim endAud As Long
Dim k As Long
Dim audioBuffer As String
Dim sampleValue As Integer
Dim uVal As Long
Dim padByteAud As String
Dim moviSize As Long
Dim riffSize As Long
Dim idxHeader As String
Dim idxSize As Long
Dim n As Long
For sec = 1 To videoDuration
' Write video chunks
For f = 1 To framesPerSec
' SHOW PROGRESS
_Dest 0
Locate 6, 1
Print Right$(" " + _Trim$(Str$(sec)), 7) + " of " + _Trim$(Str$(videoDuration)) + _
", " + _
Right$(" " + _Trim$(Str$(f)), 7) + " of " + _Trim$(Str$(framesPerSec)) + _
" ";
If videoIndex > numFrames Then Exit For
chunkOffset = LOF(fileNum) - moviDataStart + 1
frameChunkID = "00db"
tmpStr = frameChunkID
Put #fileNum, , tmpStr
currFrameSize = frameSize
Put #fileNum, , currFrameSize
Put #fileNum, , Frames(videoIndex)
If (currFrameSize Mod 2) <> 0 Then
padByte = Chr$(0)
Put #fileNum, , padByte
End If
idxCount = idxCount + 1
idxArr(idxCount).chunkID = frameChunkID
idxArr(idxCount).flags = &H10 ' Keyframe flag
idxArr(idxCount).offset = chunkOffset
idxArr(idxCount).size = currFrameSize
videoIndex = videoIndex + 1
Next f
' Write audio chunk for the current second
chunkOffsetAud = LOF(fileNum) - moviDataStart + 1
audioChunkID = "01wb"
tmpStr = audioChunkID
Put #fileNum, , tmpStr
audioChunkSize = sampleRate * 2 * 2 ' 1 second = sampleRate * (2 channels x 2 bytes)
Put #fileNum, , audioChunkSize
startAud = (sec - 1) * (sampleRate * 2) + 1
endAud = startAud + (sampleRate * 2) - 1
If endAud > UBound(audioSamples) Then endAud = UBound(audioSamples)
audioBuffer = ""
For k = startAud To endAud
' SHOW PROGRESS
_Dest 0
Locate 6, 1
Print Right$(" " + _Trim$(Str$(sec)), 7) + " of " + _Trim$(Str$(videoDuration)) + _
", " + _
Right$(" " + _Trim$(Str$(k)), 7) + " of " + _Trim$(Str$(endAud)) + _
" ";
sampleValue = audioSamples(k)
uVal = sampleValue And &HFFFF ' Convert to 16-bit two's complement representation
audioBuffer = audioBuffer + Chr$(uVal And &HFF) + Chr$((uVal \ 256) And &HFF)
Next k
Put #fileNum, , audioBuffer
If (audioChunkSize Mod 2) <> 0 Then
padByteAud = Chr$(0)
Put #fileNum, , padByteAud
End If
idxCount = idxCount + 1
idxArr(idxCount).chunkID = audioChunkID
idxArr(idxCount).flags = 0
idxArr(idxCount).offset = chunkOffsetAud
idxArr(idxCount).size = audioChunkSize
Next sec
currPos = LOF(fileNum) + 1
moviSize = currPos - moviSizePos - 4
Seek #fileNum, moviSizePos
Put #fileNum, , moviSize
Seek #fileNum, currPos
riffSize = LOF(fileNum) - 8 + 1
Seek #fileNum, riffSizePos
Put #fileNum, , riffSize
Seek #fileNum, LOF(fileNum) + 1
idxHeader = "idx1"
tmpStr = idxHeader
Put #fileNum, , tmpStr
idxSize = idxCount * 16
Put #fileNum, , idxSize
For n = 1 To idxCount
' SHOW PROGRESS
_Dest 0
Locate 7, 1
Print Right$(" " + _Trim$(Str$(n)), 7) + " of " + _Trim$(Str$(idxCount)) + _
" ";
Put #fileNum, , idxArr(n).chunkID
Put #fileNum, , idxArr(n).flags
Put #fileNum, , idxArr(n).offset
Put #fileNum, , idxArr(n).size
Next n
Close #fileNum
End Sub ' CreateAVI