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!

ACDC video Excel.xls

(3939k)

Josemar Machado,

14 de out. de 2012 15:47

v.1

Comments

Home

Navegação

Atividade recente no site

Video no Excel em ASCII