تشفير المرفقات المدرجة من الجهاز او الاسكنر عند حفظها خارج قاعدة البيانات

[ابو نزار]

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

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

بحث كثيرا في المنتدى ووجدت العديد من الامثلة والشروحات حول اضافة المرفقات من جهاز الكمبيوتر او من الاسكنر وحفظها في مجلد خارج قاعدة البيانات  وكنت اسئل هل هناك طريقة تمكننا من  تشفير المرفقات عند حفظها في مجلد خارج قاعدة البيانات بحيث لايتم فتحها او استعراضها الا من خلال شاشة البرنامج عبر تقرير او نموذج استعراض

بإنتظار ردكم الكريم ...

 

[ابوخليل]

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

هذه الوظيفة تشفر الصورة بنقرة ، وبالنقرة الثانية تفك التشفير

يمكنك ادراجها عند جلب الصور وكذلك عند عرضها

المهم ان تضعها في مكانها المناسب

Private Sub zer1_Click()
 EcryptDcryptImage ([CurrentProject].[Path] & "\image1" & ".jpg")
End Sub

Public Sub EcryptDcryptImage(sFileSpec As String)
    Dim iFle As Long
    Dim iByteCount As Long
    Dim i As Long
    Dim ii As Byte
      iFle = FreeFile
    Open sFileSpec For Binary As iFle
    iByteCount = LOF(iFle)
       For i = 1 To iByteCount
        Get iFle, i, ii
        ii = ii Xor &HFF
        Put iFle, i, ii
    Next i
      Close iFle
      If UCase$(Right$(sFileSpec, 1)) = "." Then
        Name sFileSpec As Left$(sFileSpec, Len(sFileSpec) - 1)
    Else
        Name sFileSpec As sFileSpec & "."
    End If
End Sub

 

[ابو نزار]

استاذي العزيز ابو خليل .. كم سرني مرورك الكريم .. شكرا لتجاوبك ... جاري تطبيق ذلك وسأوافيك بالنتيجة إن شاء الله .. خالص شكري وامتناني لك 

[أغيد]

 

تم تطبيق الكود السابق على المرفق كالأتي تم انشاء مودول واضافة الكود 

Public Sub EcryptDcryptImage(sFileSpec As String)
    Dim iFle As Long
    Dim iByteCount As Long
    Dim i As Long
    Dim ii As Byte
      iFle = FreeFile
    Open sFileSpec For Binary As iFle
    iByteCount = LOF(iFle)
       For i = 1 To iByteCount
        Get iFle, i, ii
        ii = ii Xor &HFF
        Put iFle, i, ii
    Next i
      Close iFle
      If UCase$(Right$(sFileSpec, 1)) = "." Then
        Name sFileSpec As Left$(sFileSpec, Len(sFileSpec) - 1)
    Else
        Name sFileSpec As sFileSpec & "."
    End If
End Sub

 بعد ذلك تم وضع الكود التالي تحت زر امر ادراج مرفقات 

EcryptDcryptImage ([CurrentProject].[Path] & "\image1" & ".jpg")

وتم ايضا اضافته في  في حدث عند النقر على مسار الصورة (اسم المرفق) 

عند التطبيق لوحظ الأتي : 

عند ادراج صوره او عدة صور او مرفقات اخرى (وورد - اكسل - pdf- فيديو) تنضاف للبرنامج ويتم تشفيرها لكن تاخذ وقت من في الدوران من  دقيقة الى 5 دقائق واكثر  وكذلك تاخذ وقت عند فتح التشفير من خلال  النقر على مسار المرفق واحياناً  ويستمر بالدوران ولايتم التوقف الا اذا قمت بعمل (ctrl+break)

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

 

 

test.accdb

[ابوخليل]

السبب هو كبر حجم الملفات

حيث تم اعداد الكود للتعامل مع الملفات والصور التي احجامها بالكيلوبايت ، فلا باس هنا ان يتعامل مع كامل حجم الملف

اما اذا كانت الملفات كبيرة فيلزم  تطبيق التشفير على جزء من الملف 

تجد ادناه انه تم تعديل الكود ليتناسب مع اي حجم حيث يتم التطبيق على جزء من الملف ، حسب ما يقتضيه الحال

لاحظ الرقم 5  فهو بيت القصيد

ايضا لاحظ اني جعلت وظيفته عامه ليتم مناداته من اي مكان في البرنامج لذا اجعله في وحدة نمطية عامة

Public Function EcryptDcryptImage(sFileSpec As String)
    Dim iFle As Long
    Dim iByteCount As Long
    Dim i As Long
    Dim ii As Byte
      iFle = FreeFile
    Open sFileSpec For Binary As iFle
    iByteCount = LOF(iFle)
       For i = 1 To Mid(iByteCount, 5)
        Get iFle, i, ii
        ii = ii Xor &HFF
        Put iFle, i, ii
    Next i
     Close iFle
End Function

 

[jjafferr]

السلام عليكم 🙂

 

اخوي ابو خليل ، هناك ملاحظة عن تشفيرك في اول مشاركة ، فلما يفتح البرنامج الصورة ، فتظهر بألوان تختلف عن الصورة الاصليه (مع العلم ان الصورة المحفوظه بعد التشفير الوانها صحيحة!!).

 

***** وهنا ملاحظات هامة :

1. بعض البرامج مثل الاكسل لا تنفتح بعد اعادة التشفير.
2. عند ارفاق الملف ، والذي يقوم الكود بتشفيره ، فإذا ذهبث للمجلد الذي فيه الصورة المشفرة ، ثم اردت فتح الصورة ، فستجد رسالة خطأ من الوندوز بأنه لا يمكن فتح الملف ، وهو المطلوب ،
3. الآن افتح الملف عن طريق النقر على اسم الملف من البرنامج ، فسينفتح الملف ، ورجاء غلق الملف ،
4. الآن اذهب الى الخطوة رقم 2 اعلاه ، فالمفاجأة بأنه يمكنك فتح الملف مباشرة من المجلد !! والسبب بأننا قمنا بفك تشفير الملف عن طريق الخطوة رقم 2 !!
5. الطريقة الصحيحة للتعامل مع الملف ، هو اخذ نسخة من الملف الى مجلد آخر ، فك التشفير ، ثم افتح الملف. يعني فك التشفير يكون للملف المؤقت دون المساس بالملف الاصل ،

هذا الكود في النموذج الفرعي يقوم بالعمل اعلاه :

Private Sub name_morfke_Click()

    Dim Source_File_Path As String, Destination_File_Path As String
    
    Source_File_Path = CurrentProject.Path & "\" & Me.name_morfke
    Destination_File_Path = Environ("Temp") & "\" & Me.name_morfke
    FileCopy Source_File_Path, Destination_File_Path
    
    Application.FollowHyperlink (Destination_File_Path)
    EcryptDcryptImage (Destination_File_Path)
End Sub

Private Sub Form_Close()
On Error Resume Next

    Dim Srst As DAO.Recordset
    Set Srst = Me.RecordsetClone
    Do Until Srst.EOF
        Kill Environ("Temp") & "\" & Srst!name_morfke
        Srst.MoveNext
    Loop
End Sub

 

جعفر

[ابوخليل]

شكرا استاذي الغالي على المداخلة

وفكرتك جميلة للحفاظ على الصورة الأصل محمية

ما رأيك لو يتم عكس العملية  ( اقصد التشفير بعد الفتح ) عند حدث الخروج من حقل اسم الملف ؟

 

[ابو نزار]

ماهذا الجمال ....ماهذه الروعة 

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

هذا المرفق بعد تطبيق التعديلات الأخيرة  ... مع وجود ملاحظة ظهور رسالة تفيد  عدم نسخ الملف الى المجلد المؤقت عند النقر على مسار المرفق  ارجوا الاطلاع ..test.accdbtest.accdb

[jjafferr]

24 دقائق مضت, ابوخليل said:

ما رأيك لو يتم عكس العملية  ( اقصد التشفير بعد الفتح ) عند حدث الخروج من حقل اسم الملف ؟

الخوف من اعادة تشفير الملف الذي تم تشفيره سابقا !!

وللعلم ، تقدر تجعل البرنامج يعمل التشفير بسرعة ، فقط استعمل 

For i = 1 To 2

بدلا عن
For i = 1 To Mid(iByteCount, 5)

.

ولكن مثل ما اخبرتك سابقا ، مافيه اشكال في تشفير وفك تشفير الصور ، ولكن لم يعمل مع ملف اكسل (ما جربت صيغ اخرى من الملفات).

 

13 دقائق مضت, ابو نزار said:

مع وجود ملاحظة ظهور رسالة تفيد  عدم نسخ الملف الى المجلد المؤقت عند النقر على مسار المرفق

ما هي رسالة الخطأ ؟

 

جعفر

[ابو نزار]

[ابو نزار]

هذه الرسالة التي تظهر عند النقر على رابط مسار المرفق  مع العلم اني جربت على صور وفيديو و pdf وملف وورد  وبوربونت  ويتم التشفير بطريقة ممتاز  باستثناء كما قلت الأكسل

[أغيد]

24 دقائق مضت, rockjone33 said:

لهذا ولا ذاك 

البيانات لا تمس..  ؟!  

لا اظن ان التشفير الا للاعلان في الويب او تسليم اقراص..  كافي اذا عطب الاكسس..  شرط عندك مساحة تخزين محسوبة لتأمين البيانات..  

سؤال اذا اعدة المرفقات المشفره الى قاعدة البيانات آخرى نفس الكود التشفير تفتح يفك التشفير..!؟  🙂

1- هي صحيح لو كانت عكسية سحب المرفقات في الملفات الى قاعدة البيانات B جداول الى (حقل المرفقات) والقاعدة  بكلمت سر..  افضل من التشفير والمساس باصل الملف او نسخه وبعد تشفير؟!! ..  🙂

او

2- البعض استخدم zip للتشفير اي استخراج الملفات الى Zip بكلمة سر ونسخه هذا الملف بملف النسخ تكون نسختين..  

فافضل رقم (1) لستخراج الكل وعرض السريع ووصل البيانات المطلوبه...  اما تسلم البيانات تكون مشفر نستخدم  على القليل Zip..  

والالية بسيطة لرقم(1) استخراج قبل اغلاق وانهاء يحذف ملف المرفقات واي ادراج لا نهائي بربط لقاعدة B بحفظ المرفقات بداخلها مع بيانات الاستدلال..  🙂

متوفر..  🙂

=======================================================

حاول تفهم المثال ..  وليس مثال..  

مثال ارفقة طربقتين وطريقة الاولى هي الصحيحه فقط اضافة حقل غير منظم عند التشغيل 0 عند السحب الاسم = الاسم +1 بشرط لعدد والكود لا يتعدى سحب كامل الجدول فقط كود ب8 سطور..  فجعلت المستخدم يكتب الارقام اذا حاب يزود العدد الى كامل الجدول!!! ..  لم يكن تظليل منى..  قرب راس السنه ..  🙂! 

 

 اشتي افهم...  لكن ماقدرت  .. يبدوا  لي الكلام  عن تشفير البيانات 

تم تعديل ديسمبر 18, 2022 بواسطه أغيد

[jjafferr]

1 ساعه مضت, ابو نزار said:

مع وجود ملاحظة ظهور رسالة تفيد  عدم نسخ الملف الى المجلد المؤقت

 

جرب هذا الكود بدلا عن السابق

Private Sub name_morfke_Click()


    Dim Source_File_Path As String, Destination_File_Path As String
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")

    Source_File_Path = CurrentProject.Path & "\" & Me.name_morfke
    'Destination_File_Path = Environ("Temp") & "\" & Me.name_morfke
    Destination_File_Path = fso.GetSpecialFolder(2) & "\" & Me.name_morfke
    FileCopy Source_File_Path, Destination_File_Path
    
    Application.FollowHyperlink (Destination_File_Path)
    EcryptDcryptImage (Destination_File_Path)
End Sub

Private Sub Form_Close()
On Error Resume Next

    Dim Srst As DAO.Recordset
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Set Srst = Me.RecordsetClone
    Do Until Srst.EOF
        'Kill Environ("Temp") & "\" & Srst!name_morfke
        Kill fso.GetSpecialFolder(2) & "\" & Srst!name_morfke
        Srst.MoveNext
    Loop
End Sub

.

يجب عليك استعمال الزر "ادراج مرفقات من الكمبيوتر" ، ثم بعد ذلك تقوم بمحاولة فتح الملف.

 

جعفر

[أغيد]

تظهر نفس الرسالة السابقة 

[ابو نزار]

[ابوخليل]

9 ساعات مضت, ابو نزار said:

تأكد من مكتباتك .. خاصة ما لون بالازرق

 

[أغيد]

نعم استاذي العزيز  ابو خليل موجود كما هو مبين في الصورة 

والمشكلة مازالت قائمة 

تم تعديل ديسمبر 19, 2022 بواسطه أغيد

[jjafferr]

لوسمحت تجرب هذا الكود بدلا عن السابق:

Private Sub name_morfke_Click()


    Dim Source_File_Path As String, Destination_File_Path As String
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")

    Source_File_Path = CurrentProject.Path & "\" & Me.name_morfke
    'Destination_File_Path = Environ("Temp") & "\" & Me.name_morfke
    Destination_File_Path = fso.GetSpecialFolder(2) & "\" & Me.name_morfke
    
    If Dir(Source_File_Path) = "" Then
        Debug.Print Source_File_Path & " > Not Found"
    Else
        Debug.Print Source_File_Path & " > Found"
    End If
    If Dir(Environ("Temp"), vbDirectory) <> "" Then
        Debug.Print Environ("Temp") & " > Found"
    End If
    If Dir(fso.GetSpecialFolder(2), vbDirectory) <> "" Then
        Debug.Print fso.GetSpecialFolder(2) & " > Found"
    End If

    'FileCopy Source_File_Path, Destination_File_Path
    fso.CopyFile Source_File_Path, Destination_File_Path, True
    
    Application.FollowHyperlink (Destination_File_Path)
    EcryptDcryptImage (Destination_File_Path)
End Sub

.

ثم الصق لنا النتيجة التي في اسفل نافذة الكود VBA ، كما في الصورة في الاسفل :

 

.

جعفر

[أغيد]

أستاذي ومعلمي العزيز @jjafferr 

سويت كما اوضحت لكن مازلت تظهر الرسالة السابقة بعدم وجود الملف  رغم اني طبقت على اصدار اوفيس 2010 و 2019 و 2013 ومازالت كما هو في الصورة وكذا على نظامين مختلفين ويندوز 7 ويندوز 10 ولست اعلم هل المشكلة من الاوفيس او النظام او من الكود

أرجوا ان لا اكون اثقلت عليك فكما هو واضح  ان التطبيق يعمل عندك .....لكن لا اعلم سبب ظهور المشكلة عندي 

test.accdb

تم تعديل ديسمبر 19, 2022 بواسطه أغيد
اضافة مرفق بعد التعديل

[jjafferr]

2 ساعات مضت, jjafferr said:

ثم الصق لنا النتيجة التي في اسفل نافذة الكود VBA ، كما في الصورة في الاسفل

وين البيانات او الصورة ؟

[Ahmed_J]

السلام عليكم اساتذتي الاعزاء

استاذ @jjafferr  اسمحلولي بالتجربة

انا قمت بتحميل الملف وعندي اوفيس 2010 ووندوز 7 - 32 بت

اولا/ قمت بعمل مجلد على سطح المكتب لحفظ الصور المشفرة

ثانيا /قمت بادراج صور من الكمبيوتر الى المجلد

ثالثا /عند النقر على المرفق في النموذج الفرعي تظهر رسالة الخطا كما في الصور

علما بان الصور تم نقلها الى المجلد  كما في الصورة الاولى

تحياتي

تم تعديل ديسمبر 19, 2022 بواسطه Ahmed_J

[أغيد]

16 دقائق مضت, jjafferr said:

وين البيانات او الصورة ؟

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

[jjafferr]

عفوا يا جماعة ، الخطأ مني 😪

 

استعملوا هذا السطر 

Source_File_Path = Me.Parent!pate & "\" & Me.name_morfke

.

يعني كودي في اول مشاركة يصبح بعد التعديل :

Private Sub name_morfke_Click()

    Dim Source_File_Path As String, Destination_File_Path As String
    
    Source_File_Path = me.parent!pate & "\" & Me.name_morfke
    Destination_File_Path = Environ("Temp") & "\" & Me.name_morfke
    FileCopy Source_File_Path, Destination_File_Path
    
    Application.FollowHyperlink (Destination_File_Path)
    EcryptDcryptImage (Destination_File_Path)
End Sub

Private Sub Form_Close()
On Error Resume Next

    Dim Srst As DAO.Recordset
    Set Srst = Me.RecordsetClone
    Do Until Srst.EOF
        Kill Environ("Temp") & "\" & Srst!name_morfke
        Srst.MoveNext
    Loop
End Sub

.

واليكم المرفق وبه التعديلات السابقة والاخيرة والجديدة 🙂

 

جعفر

Archiving_Encripted_Attachment.zip

[Ahmed_J]

تمام استاذي العزيز @jjafferr

البرتامج شغال  تسلم ايدك ياغالي

[أغيد]

مهما قلت لك شكرا لان افيك حقك ....ولا املك سوى ان ادعوى الله لك ان يزيدك علماً وينفعنا بعلمك وان يعطيك ما تتمناه وترجوه  وان يجزيك عنا خير الجزاء في الدنيا والاخرة ..  شكرا جزيلا من القلب