Video no Excel em ASCII

Como criar um video em texto ASCII no Excel:

(arquivo para baixar no final da pagina!)

Primeiro passo:

Escolher um video e o audio dele em .WAV

Use um conversor de video para ASCII existem varios por ai, use a recomendação de video 30fps a 640x480

Segundo passo, como rodar no Excel:

Pegue os codigos gerados e coloque no excel em celulas adicionadas em linhas

copie um quadro e adicione em um range (em geral 9 colunas por 19 linhas) que caiba o quadro corretamente dentro do range sem que este fique distorcido, ajuste o zoom da planilha caso seja necessário.

incorpore o objeto wav a sua planilha (inserir>objeto>package)

Terceiro passo:

Vamos ao VBA...

Vamos chamar a "winmm.dll" para poder o wav no excel:

Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
        (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Depois declarar as variaveis:

'Sound constants
Private Const SND_SYNC = &H0
Private Const SND_ASYNC = &H1
Private Const SND_NODEFAULT = &H2
Private Const SND_LOOP = &H8
Private Const SND_NOSTOP = &H10
'Audio file
Public AudioFile As String
'Interrupt playing
Public StopPlaying As Boolean

As funções de execução do WAV:

Sub PlayBack()
   WAVPlay AudioFile
End Sub
Sub PlayBackLoop()
   WAVLoop AudioFile
End Sub
Sub PlayBackStop()
    Call WAVPlay(vbNullString)
End Sub
Sub WAVLoop(File As String)
    Dim SoundName As String
    Dim wFlags As Long
    Dim x As Long
   
    SoundName = File
    wFlags = SND_ASYNC Or SND_LOOP
    x = sndPlaySound(SoundName, wFlags)
    If x = 0 Then MsgBox "Can't play the audio file. ", vbCritical, "Error"
End Sub
Sub WAVPlay(File As String)
    Dim SoundName As String
    Dim wFlags As Long
    Dim x As Long
   
    SoundName = File
    wFlags = SND_ASYNC Or SND_NODEFAULT
    x = sndPlaySound(SoundName, wFlags)
    If x = 0 Then MsgBox "Can't play the audio file. ", vbCritical, "Error"
End Sub

Agora vamos extrair o objeto WAV:

O que ele faz: procura os objetos incorporados na planilha e salva como .wav de acordo com a condição a seguir no proximo Sub

Sub ExtractWAV()
Dim tmpFileName As String
Dim FileNumber As Integer
Dim myFileId As Long
Dim MyFileLen As Long
Dim myIndex As Long
Dim FileLen As Long
Dim i As Long
Dim fileArray() As Byte
Dim myArr() As Byte
tmpFileName = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name
myFileId = FreeFile
Open tmpFileName For Binary As #myFileId
MyFileLen = LOF(myFileId)
ReDim myArr(MyFileLen - 1)
Get myFileId, , myArr()
Close myFileId
Application.ScreenUpdating = False
i = 0
Do While i < MyFileLen
   If myArr(i) = &H52 Then  'Looking for RIFF
      If myArr(i + 1) = &H49 And myArr(i + 2) = &H46 And myArr(i + 3) = &H46 Then
         FileLen = CLng(&H1000000) * myArr(i + 7) + CLng(&H10000) * myArr(i + 6) + CLng(&H100) * myArr(i + 5) + myArr(i + 4)
         FileLen = FileLen + 8
         ReDim fileArray(FileLen - 1)
         For myIndex = 0 To FileLen - 1
            fileArray(myIndex) = myArr(i + myIndex)
         Next myIndex
         Exit Do
      Else
            i = i + 4
      End If
   Else
        i = i + 1
   End If
Loop
myFileId = FreeFile
tmpFileName = AudioFile
'tmpFileName = Left(tmpFileName, Len(tmpFileName) - 4) & ".wav"
Open tmpFileName For Binary As #myFileId
Put #myFileId, , fileArray
Close myFileId
'MsgBox "Saved the extracted file as [ " & tmpFileName & " ]"
End Sub

Abrir o arquivo wave salvo ou extrair o arquivo com a função anterior (substituia o acdc.wav pelo nome do seu arquivo):

Private Sub Workbook_Open()
Dim tmpPath As String
Sheet1.Activate
tmpPath = ThisWorkbook.Path
AudioFile = tmpPath & "\ACDC.wav"
'Show logo
Sheet1.Range("B2").Value = Sheet1.Range("Q99").Value
'File exists. Do not export the embedded object.
If Dir(AudioFile) <> "" Then Exit Sub
Call ExtractWAV
DoEvents
End Sub

Agora sim a função para "rodar" o video, que constitue nada mais nada menos que uma timer para exibir os frames convertidos no mesmo timing do video

Sub PlayVideo()
Dim i As Long
Dim Start, Delay
i = 100
Do While Sheet1.Cells(i, 17).Value <> ""
   Start = Timer                'Set start to internal timer
   Delay = Start + 0.083        'Set delay so frames change 12 per sec.
  
   'Display
   Do While Timer < Delay
      DoEvents
   Loop
   Sheet1.Range("B2").Value = Sheet1.Cells(i, 17).Value
   DoEvents
  
   If StopPlaying = True Then
      Exit Do
   End If
  
   Start = Timer                'and reset the timer
   Delay = Start + 0.083        'and the delay
   i = i + 1
Loop
'Stop audio
Call PlayBackStop
'Clear video
Sheet1.Range("B2").Value = ""
'Show logo
Sheet1.Range("B2").Value = Sheet1.Range("Q99").Value
'Move cursor
'Sheet1.Range("A1").Select
End Sub

para rodar precisamos de mais isto no planilha agora:

para dar o play (rodar o wav e chamar o playvideo

Private Sub btnPlay_Click()
  StopPlaying = False
  If Trim(AudioFile) = "" Then AudioFile = ThisWorkbook.Path & _
     "\ACDC.wav"
  Call PlayBackLoop
  DoEvents
  Call PlayVideo
End Sub

Para parar o video

Private Sub btnStop_Click()
  StopPlaying = True
End Sub

apenas para não ficar selecionado o range do video...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Left(Replace(Target.Address, "$", ""), 2) = "B2" Then
     Range("B22").Select
  End If
End Sub

E pronto!!! Video no excel!