Sub ExtractFlash()
    Dim tmpFileName As String,FileNumber As Integer
    Dim myFileId As Long
    Dim myArr() As Byte
    Dim i As Long
    Dim MyFileLen As Long, myIndex As Long
    Dim swfFileLen As Long
    Dim swfArr() As Byte
    tmpFileName = Application.GetOpenFilename("office File(*.doc;*.xls),*.doc;*.xls",_
                         , "Select Excel / Word File")
    If tmpFileName = "False" Then Exit Sub
    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) = &H46 Then
            If myArr(i + 1) = &H57 And myArr(i + 2) = &H53 Then
                swfFileLen = CLng(&H1000000) * myArr(i + 7)+CLng(&H10000)*myArr(i+6)+ _
                CLng(&H100) * myArr(i + 5) + myArr(i + 4)
                ReDim swfArr(swfFileLen - 1)
                For myIndex = 0 To swfFileLen - 1
                    swfArr(myIndex) = myArr(i + myIndex)
                Next myIndex
                Exit Do
            Else
                i = i + 3
            End If
        Else
            i = i + 1
        End If
    Loop
    myFileId = FreeFile
    tmpFileName = Left(tmpFileName, Len(tmpFileName) - 4) & ".swf"
    Open tmpFileName For Binary As #myFileId
    Put #myFileId, , swfArr
    Close myFileId
    MsgBox "SaveAs " & tmpFileName
End Sub

iv. Now run the code. (Press F5)
v. It’ll ask for the document to process, Select the previously saved doucment.
The basic logic behind this code is to
i. Open the file in binary mode
ii. Look for the embedded flash file in it. It’s done by searching for the signature of the SWF file within the binary data
iii. Extracting the data and storing it into a file with extension SWF.
That’s it…Your are done…! You get your Flash file extracted and saved in the same folder with the same name with .SWF extension.