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
Monday, June 28, 2010
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.
Subscribe to:
Post Comments (Atom)
No comments:
Post a Comment
Your feedback is always appreciated. I will try to reply to your queries as soon as time allows.Please don't spam,spam comments will be deleted upon reviews.