Extract Flash Game from Excel with VBA

Open new Excel file and insert new ActiveX Button control past following code in it's Click function.

Private Sub CommandButton1_Click()
    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