Nice work @mdikjens! I increased the length to 60 seconds, and it worked.
I tweaked the code slightly to create a video file using the current timestamp, so as not to overwrite the previous file, and at the end it shows the filename in an inputbox that you can copy to the clipboard.
I tweaked the code slightly to create a video file using the current timestamp, so as not to overwrite the previous file, and at the end it shows the filename in an inputbox that you can copy to the clipboard.
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.
' -----------------------------------------------------------------------------
' Reply #8
' From: mdijkens, Member
' Date: 3/23/2025 12:51 PM (This post was last modified: 3/23/2025 12:56 PM by mdijkens.)
' I used your code as a basis but refactored several things.
' There is now one big AVI header type that is rewritten in the end.
' Also image and audiosamples are now generated inline so no mem limit anymore.
' You can now create AVI's up to 4GB (I think that is some AVI limit?)
' =============================================================================
' GLOBAL VARIABLES
' =============================================================================
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' =============================================================================
' GENERATE VIDEO
' =============================================================================
' FILENAME = EXE NAME + TIMESTAMP + ".AVI"
Dim sFileName As String
sFileName = NoExt$(m_ProgramName$) + "." + GetTimestamp$ + ".avi"
'CreateAVI sFileName, 3, 800, 600, 30, 44100
CreateAVI sFileName, 60, 720, 480, 30, 44100
' /////////////////////////////////////////////////////////////////////////////
Sub CreateAVI (fn$, videoDuration As Integer, _
frameWidth As Long, frameHeight As Long, _
vidFPS As Integer, sampleRate As Long)
Const bytesPerPixel = 4
Type AVIheader
riffHeader As String * 4
riffSize As Long
aviSig As String * 4
listHdrl As String * 4
hdrlSize As Long ' Size from hdrlSig to cbSize (74*4 + 7*2)
hdrlSig As String * 4
avihChunkID As String * 4
avihChunkSize As Long
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
vwidth As Long ' Video width in pixels
vheight As Long ' Video height in pixels
reserved As String * 16 ' Reserved bytes (set to 0)
listStrlVid As String * 4
strlVidSize As Long ' Size from strlVidSig to clrImportant (=31*4)
strlVidSig As String * 4
strhVidID As String * 4
strhVidSize As Long
fccType As String * 4 ' Stream type (e.g., "vids" or "auds")
fccHandler As String * 4 ' Codec handler (e.g., "DIB " for uncompressed video)
streamflags As Long ' Stream flags
priority As Integer ' Priority (unused)
language As Integer ' Language code (unused)
initialFrames0 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)
streamSuggestedBufferSize 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
strfVidID As String * 4
strfVidSize As Long
size As Long ' Size of this header (40 bytes)
iwidth As Long ' Width of the image in pixels
iheight 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)
listStrlAud As String * 4
strlAudSize As Long ' Size from strlAudSig to cbSize (22*4 + 7*2)
strlAudSig As String * 4
strhAudID As String * 4
strhAudSize As Long
afccType As String * 4 ' AUDIO Stream type (e.g., "vids" or "auds")
afccHandler As String * 4 ' AUDIO Codec handler (e.g., "DIB " for uncompressed video)
astreamflags As Long ' AUDIO Stream flags
apriority As Integer ' AUDIO Priority
alanguage As Integer ' AUDIO Language code
ainitialFrames As Long ' AUDIO Initial frames
ascale As Long ' AUDIO Time scale for the stream
arate As Long ' AUDIO Data rate (scale/rate = FPS for video)
astart As Long ' AUDIO Start time (usually 0)
alength As Long ' AUDIO Length of the stream (in time units)
astreamSuggestedBufferSize As Long ' AUDIO Suggested buffer size for the stream
aquality As Long ' AUDIO Quality indicator (-1 for default)
asampleSize As Long ' AUDIO Sample size (0 for video, nonzero for audio)
aframeLeft As Long ' AUDIO For video: left coordinate of the source rectangle
aframeTop As Long ' AUDIO For video: top coordinate of the source rectangle
aframeRight As Long ' AUDIO For video: right coordinate of the source rectangle
aframeBottom As Long ' AUDIO For video: bottom coordinate of the source rectangle
strfAudID As String * 4
strfAudSize As Long
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)
listMovi As String * 4
moviSize As Long
moviSig As String * 4
End Type
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 header As AVIheader
Dim numFrames As Long: numFrames = vidFPS * videoDuration
Dim frameSize As Long: frameSize = frameWidth * frameHeight * bytesPerPixel ' Total size of one 32-bit frame
Dim totalSamplesPerChannel As Long: totalSamplesPerChannel = videoDuration * sampleRate
Dim idxArr(1 To numFrames + videoDuration) As ChunkIndex
Dim idxCount As Long: idxCount = 0
Dim avi$
avi$ = m_ProgramPath$ + fn$
If _FileExists(avi$) Then Kill avi$
Dim fileNum As Integer: fileNum = FreeFile: Open avi$ For Binary As #fileNum
header.riffHeader = "RIFF"
header.riffSize = 0
header.aviSig = "AVI "
header.listHdrl = "LIST"
header.hdrlSize = 74 * 4 + 7 * 2
header.hdrlSig = "hdrl"
header.avihChunkID = "avih"
header.avihChunkSize = 56
header.microSecPerFrame = 1000000 \ vidFPS
header.maxBytesPerSec = frameSize * vidFPS
header.paddingGranularity = 0
header.flags = &H110 ' AVIF_HASINDEX flag
header.totalFrames = numFrames
header.initialFrames = 0
header.streams = 2 ' 2 streams: video + audio (stereo is 1 stream and mono also)
header.suggestedBufferSize = frameSize
header.vwidth = frameWidth
header.vheight = frameHeight
header.reserved = String$(16, Chr$(0))
header.listStrlVid = "LIST"
header.strlVidSize = 29 * 4 + 4 * 2
header.strlVidSig = "strl"
header.strhVidID = "strh"
header.strhVidSize = 64
header.fccType = "vids"
header.fccHandler = "DIB " ' Uncompressed video (DIB)
header.streamflags = 0
header.priority = 0
header.language = 0
header.initialFrames = 0
header.scale = 1
header.rate = vidFPS
header.start = 0
header.length = numFrames
header.streamSuggestedBufferSize = frameSize
header.quality = -1
header.sampleSize = 0
header.frameLeft = 0
header.frameTop = 0
header.frameRight = frameWidth
header.frameBottom = frameHeight
header.strfVidID = "strf"
header.strfVidSize = 40
header.size = 40
header.iwidth = frameWidth
header.iheight = -frameHeight ' Negative height indicates top-down format
header.planes = 1
header.bitCount = 32
header.compression = 0 ' BI_RGB = uncompressed
header.sizeImage = frameSize
header.xPelsPerMeter = 0
header.yPelsPerMeter = 0
header.clrUsed = 0
header.clrImportant = 0
header.listStrlAud = "LIST"
header.strlAudSize = 22 * 4 + 7 * 2
header.strlAudSig = "strl"
header.strhAudID = "strh"
header.strhAudSize = 64
header.afccType = "auds"
header.afccHandler = String$(4, 0) ' For PCM audio, this is typically empty
header.astreamflags = 0
header.apriority = 0
header.alanguage = 0
header.ainitialFrames = 0
header.ascale = 1
header.arate = sampleRate
header.astart = 0
header.alength = totalSamplesPerChannel
header.astreamSuggestedBufferSize = sampleRate * 4 ' 2 channels x 2 bytes per sample (is used 16bit stereo waveform sound, 1 integer to 1 sample)
header.aquality = -1
header.asampleSize = 4 ' 4 bytes per stereo sample (2 bytes left + 2 bytes right)
header.aframeLeft = 0
header.aframeTop = 0
header.aframeRight = 0
header.aframeBottom = 0
header.strfAudID = "strf"
header.strfAudSize = 16
header.wFormatTag = 1
header.nChannels = 2
header.nSamplesPerSec = sampleRate
header.wBitsPerSample = 16
header.nBlockAlign = header.nChannels * (header.wBitsPerSample \ 8)
header.nAvgBytesPerSec = header.nSamplesPerSec * header.nBlockAlign
header.cbSize = 0
header.listMovi = "LIST"
header.moviSize = 0
header.moviSig = "movi"
Put #fileNum, , header
Dim moviDataStart As Long: moviDataStart = Seek(fileNum)
' --------------------------------------------------------------
' 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 chunkOffset As Long
Dim frameChunkID As String: frameChunkID = "00db"
Dim padByte As String: padByte = Chr$(0)
Dim chunkOffsetAud As Long
Dim audioChunkID As String: audioChunkID = "01wb"
Dim audioChunkSize As Long
Dim As Integer SampleL, SampleR 'Variables for left and right channel samples
Dim sm As _MEM
Dim img As Long: img = _NewImage(frameWidth, frameHeight, 32)
'Dim img2 As Long: img2 = _NewImage(frameWidth, frameHeight, 32)
Dim freq As Single: freq = 500 'Starting frequency in Hz
Dim videoIndex As Long: videoIndex = 0
Dim frame As String: frame = Space$(frameSize)
Dim sTotal As String
Locate 1, 1: Print "Generating video file " + Chr$(34) + fn$ + Chr$(34)
sTotal = " of " + _Trim$(Str$(videoDuration))
For sec% = 1 To videoDuration
' SHOW PROGRESS
Locate 3, 1: Print _Trim$(Str$(sec%)) + sTotal + " ";
' Write video chunks
For i% = 1 To vidFPS
chunkOffset = Seek(fileNum) - moviDataStart
Put #fileNum, , frameChunkID
Put #fileNum, , frameSize
videoIndex = videoIndex + 1
_Dest img '@@
Cls: _PrintMode _KeepBackground
For j% = 1 To 100
Line (Rnd * frameWidth, Rnd * frameHeight)-(Rnd * frameWidth, Rnd * frameHeight), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), B
Next j%
_PrintString (350, 250), "Video Frame " + _ToStr$(videoIndex)
_Dest 0
'_PutImage (0, 0), img, img2, (0, frameHeight)-(frameWidth, 0) ' For VLC Player
'_PutImage (0, 0), img, img2 ' For WMP, MPC-HC Player
sm = _MemImage(img)
frame = Space$(frameSize)
_MemGet sm, sm.OFFSET, frame
_MemFree sm
Put #fileNum, , frame
If (frameSize Mod 2) <> 0 Then Put #fileNum, , padByte
idxCount = idxCount + 1
idxArr(idxCount).chunkID = frameChunkID
idxArr(idxCount).flags = &H10 ' Keyframe flag
idxArr(idxCount).offset = chunkOffset
idxArr(idxCount).size = frameSize
Next i%
' Write audio chunk for the current second
chunkOffsetAud = Seek(fileNum) - moviDataStart
Put #fileNum, , audioChunkID
audioChunkSize = sampleRate * 2 * 2 ' 1 second = sampleRate * (2 channels x 2 bytes)
Put #fileNum, , audioChunkSize
audioBuffer$ = String$(sampleRate * 4, 0)
For l& = 0 To sampleRate - 1
t! = l& / sampleRate: pan! = l& / totalSamplesPerChannel
freq = freq + 5 - 10 * Int(Rnd * 2)
SampleL = (32767 * 0.9 * (1 - pan!) * Sin(2 * 3.14159 * freq * t!)) And &HFFFF
SampleR = (32767 * 0.9 * pan! * Sin(2 * 3.14159 * freq * t!)) And &HFFFF
Asc(audioBuffer$, l& * 4 + 1) = SampleL And &HFF
Asc(audioBuffer$, l& * 4 + 2) = (SampleL \ 256) And &HFF
Asc(audioBuffer$, l& * 4 + 3) = SampleR And &HFF
Asc(audioBuffer$, l& * 4 + 4) = (SampleR \ 256) And &HFF
Next l&
Put #fileNum, , audioBuffer$
idxCount = idxCount + 1
idxArr(idxCount).chunkID = audioChunkID
idxArr(idxCount).flags = 0
idxArr(idxCount).offset = chunkOffsetAud
idxArr(idxCount).size = audioChunkSize
Next sec%
_Dest 0
_FreeImage img
currPos = Seek(fileNum)
header.moviSize = currPos - moviSizePos - 4
header.riffSize = Seek(fileNum) - 8
Dim idxHeader As String: idxHeader = "idx1": Put #fileNum, , idxHeader
Dim idxSize As Long: idxSize = idxCount * 16: Put #fileNum, , idxSize
Dim n As Long
For n = 1 To idxCount
Put #fileNum, , idxArr(n).chunkID
Put #fileNum, , idxArr(n).flags
Put #fileNum, , idxArr(n).offset
Put #fileNum, , idxArr(n).size
Next n
Put #fileNum, 1, header
Close #fileNum
Print
' Display file name/path in inputbox so user can copy to clipboard.
Dim in$
in$ = _INPUTBOX$(m_ProgramName$, _
"File created." + chr$(13) + _
"Open it with your media player program" + chr$(13) + _
"(VLC player recommended).", _
avi$) ' title, message, default
End Sub ' CreateAVI
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' In the format yyyy-mm-dd hh:mm:ss
' in 24-hour time.
Function CurrentDateTime$
CurrentDateTime$ = Mid$(Date$, 7, 4) + "-" + _
Mid$(Date$, 1, 5) + " " + _
Time$
End Function ' CurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' Return filename sFile without file extension (anything after last ".")
Function NoExt$ (sFile As String)
Dim iPos As Integer
iPos = _InStrRev(sFile, ".")
If iPos > 0 Then
If Len(sFile) > 1 Then
If iPos > 1 Then
NoExt$ = Left$(sFile, iPos - 1)
Else
' dot is first character, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' file only has one character, the dot, removing it returns blank!
' our version will just return the name unchanged
' but you can return blank if you prefer
NoExt$ = sFile
End If
Else
' no dot found
' return the name unchanged
NoExt$ = sFile
End If
End Function ' NoExt$
' /////////////////////////////////////////////////////////////////////////////
' Get timestamp for filename
' In the format yyyymmdd_hhmmss
' in 24-hour time.
Function GetTimestamp$
Dim MyDate$
Dim MyTime$
MyDate$ = Date$
MyTime$ = Time$
MyDate$ = Right$(MyDate$, 4) + Left$(MyDate$, 2) + Mid$(MyDate$, 4, 2)
MyTime$ = Replace$(MyTime$, ":", "")
GetTimestamp$ = MyDate$ + "_" + MyTime$
End Function ' GetTimestamp$
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Before using be sure to initialize random seed with:
' Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
' Usage:
' NewString$ = Replace$(OldString$, FindThis$, ReplaceWithThis$)
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$