topcat姍舞之間的極度凝聚

有人剛好收到Excel內涵Flash，可是不知道為何無法撥放

小喵在網路上找了一下剛好看到這個可以把Excel檔案中的Flash找出來另存的VBA

提供給大家參考

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", , "確定要分析的 Office 檔")
    
    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 "以" & tmpFileName & "名字保存"
    
End Sub