حصرياً استخراج ملف فلاشي من داخل مصنف ليكون ملف منفصل بذاته

[ياسر خليل أبو البراء]

السلام عليكم ورحمة الله وبركاته

إخواني وأحبابي في الله

أحياناً تقابلنا في بعض المصنفات فلاشات تم إدراجها داخل الإكسيل .. ولذا فكرت في طريقة وبحثت كثيراً لكي أجد طريقة أستطيع بها استخراج الملف الفلاشي المدمج داخل المصنف ليكون الملف مستقل بذاته .. وذلك حتى أتمكن من إدراجه في مصنفات أخرى

في الملف المرفق ستجد مصنفين أحدهما باسم Watch ويحتوي على الملف الفلاشي المدرج والمطلوب استخراجه ، والمصنف الثاني يحتوي على الكود الذي يؤدي المهمة بنجاح إن شاء الله

تنفيذ الكود : عند تنفيذ الكود يظهر لك نافذة تحدد من خلالها مسار الملف الذي يحتوي الملف الفلاشي المدرج ، وهنا في المثال اسم الملف Watch ، والملف يحتوي على فلاش ساعة ...يمكن استخدامه في أي مصنف بعد استخراجه ..

المهم حدد مسار الملف والكود سيقوم بالمهمة ويقوم باستخراج الملف الفلاشي .. ليكون الملف منفضل بذاته عن المصنف ..

إليكم الكود المستخدم

Sub ExtractFlash()
    Dim tmpFileName As String
    Dim FileNumber As Integer
    Dim myFileId As Long
    Dim MyFileLen As Long
    Dim myIndex As Long
    Dim swfFileLen As Long
    Dim I As Long
    Dim swfArr() As Byte
    Dim myArr() As Byte

    tmpFileName = Application.GetOpenFilename("MS Office File (*.doc;*.xls), *.doc;*.xls", , "Open MS Office 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
    Application.ScreenUpdating = True
    
    MsgBox "Save The Extracted SWF Flash As [ " & tmpFileName & " ]"
End Sub

وأخيراً تقبلوا وافر تقديري واحترامي

حمل الملف من هنا

كان معكم أخوكم أبو البراء من منتدى أوفيسنا

[محمد حسن المحمد]

بسم الله والصلاة والسلام على رسول الله وعلى آله وصحبه ومن والاه أما بعد:

السلام عليكم ورحمة الله أخي الحبيب أبو البراء...أدعو الله تعالى أن يجعل عمرك مديداً وعملك صالحاً رشيداً..وأن يجعل لك من كل همّ فرجاً ومن كل ضيق مخرجاً...آمين

دعاء نرجو وجه الله تعالى به ...على أعمالكم المتجددة والرائعة ...تقبل أجمل وأرق وأعطر تحياتي وأمنياتي 

والسلام عليكم ورحمة الله وبركاته.

[ياسر خليل أبو البراء]

وعليكم السلام أبي الحبيب أبو يوسف

بارك الله فيك وجزيت خير الجزاء على ردك اللبق وكلماتك الرقيقة ومرورك العطر وشعوركم الطيب تجاهي وعلى تشجيعك الدائم لابن من أبنائك

تقبل وافر تقديري واحترامي

[توكل]

الأخ المبدع أبا البراء

جزاك الله خيراً جاري التدقيق في الكود لمحاولة فهمه بارك الله فيك أخي الكريم

[ياسر خليل أبو البراء]

أخي الكريم توكل

وجزيت خيراً بمثل ما دعوت لي وزيادة

مشكور على مرورك الطيب بالموضوع

تقبل تحياتي

[جلال الجمال_ابو أدهم]

جزاك الله خيرا على اعمالك الرائعه_تحياتى

[الصـقر]

جزاكم الله خيرا يا ابوالبراء

روعه بجد 

اسال الله تعالى ان يزيدك من علمه وفضله وحلمه

تقبل تحياتى

[ياسر خليل أبو البراء]

أخي العزيز جلال الجمال

بارك الله فيك وجزيت خيراً على مرورك العطر بالموضوع

أخي وحبيبي صقر المنتدى حسام عيسى

بارك الله فيك وجزيت خيراً على كلماتك الرائعة مثلك تماماً

مشكور على مرورك العطر بالموضوع ، وهذا غيض من فيض علمك أيها البطل المغوار

تقبلوا وفر تقديري واحترامي

[ابن بنها]

جزاك لله خيرا

[ياسر خليل أبو البراء]

وجزيت خيراً أخي العزيز ابن بنها بمثل ما دعوت لي وزيادة

تقبل وافر تقديري واحترامي