التعديل على كود يسمح باضافة ملفات غير الصور

[ًعبد من عباد الله]

الأخوة الكرام سلام الله على الجميع

بالمرفق عمل به وظيفة وكود لاختيار صورة من أي مكان على الحاسب والمهم فيه أنه ينقل الصورة لملف مرفق بقاعدة البيانات يسمى fileStores ويضاف مسار الصورة الجديد في نفس الوقت في سجل جدول بداخل قاعدة البيانات

بنفس الطريقة ونفس النتيجة أرغب بإنشاء او تعديل على الوظيفة والكود لإدراج بقية أنواع المواد الأخرى غير الصور من امتدادات الملفات المقروءه والمسموعة والمرئية مثل Wav or Mp4 or docx or pdf  مع عمل ملف خاص لأضافة وحفظ ملفات كل نوع من هذه المواد وليكن مثلا ثلاث ملفات مرفقة بمسار قاعدة البيانات حسب التصور التالى:-

مجلد Read للملفات المقروء ومجلد Listen للملفات المسموعة وملف Watch للملفات المرئية

وذلك لعمل مكتبة مفضلات أتمنى ان المطلوب يكون واضحا وشكرا لكل من أعان بعلم وتعامل بحلم

test move.rar

تم تعديل يوليو 30, 2017 بواسطه وائل أبو عبد الرحمن

[ًعبد من عباد الله]

للرفع

[Shivan Rekany]

في ٣٠‏/٧‏/٢٠١٧ at 16:05, وائل أبو عبد الرحمن said:

بالمرفق عمل به وظيفة وكود لاختيار صورة من أي مكان على الحاسب والمهم فيه أنه ينقل الصورة لملف مرفق بقاعدة البيانات يسمى fileStores ويضاف مسار الصورة الجديد في نفس الوقت في سجل جدول بداخل قاعدة البيانات

فقط عليك ان تحذف هذه من الكود

'If Not IsNull(PicFile) = True Then
'.InitialFileName = PicFile
'Else
'.InitialFileName = ""

'End If

 

في ٣٠‏/٧‏/٢٠١٧ at 16:05, وائل أبو عبد الرحمن said:

بنفس الطريقة ونفس النتيجة أرغب بإنشاء او تعديل على الوظيفة والكود لإدراج بقية أنواع المواد الأخرى غير الصور من امتدادات الملفات المقروءه والمسموعة والمرئية مثل Wav or Mp4 or docx or pdf  مع عمل ملف خاص لأضافة وحفظ ملفات كل نوع من هذه المواد وليكن مثلا ثلاث ملفات مرفقة بمسار قاعدة البيانات حسب التصور التالى:-

مجلد Read للملفات المقروء ومجلد Listen للملفات المسموعة وملف Watch للملفات المرئية

ولهذا اضفت هذه اسطر للكود

Dim newa As String
newa = Mid$(Trim(.SelectedItems(1)), InStrRev(Trim(.SelectedItems(1)), ".") + 1)
If newa = "jpg" Or newa = "png" Or newa = "ico" Or newa = "bmp" Or newa = "gif" Or newa = "tif" Or newa = "tga" Then
        FileCopy Trim(.SelectedItems(1)), CurrentProject.Path + "\fileStores\" & PicName("" & xPic & "")
    ElseIf newa = "mp3" Or newa = "wma" Or newa = "ape" Or newa = "amr" Or newa = "wav" Or newa = "mp4" Or newa = "avi" Then
        FileCopy Trim(.SelectedItems(1)), CurrentProject.Path + "\fileStores\watch\" & PicName("" & xPic & "")
    ElseIf newa = "txt" Or newa = "docx" Or newa = "doc" Or newa = "exlx" Then
        FileCopy Trim(.SelectedItems(1)), CurrentProject.Path + "\fileStores\doc\" & PicName("" & xPic & "")
End If

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

اليك المرفق بعد تعديل

 

test_move.rar

[ًعبد من عباد الله]

ماذا أقول علم غزير وعمل وفير ما شاء الله تبارك الله

يعجز اللسان عن موافاتكم حقكم على هذا الكرم البالغ فجزاكم الله خيرا 

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

[Shivan Rekany]

19 ساعات مضت, وائل أبو عبد الرحمن said:

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

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

[ًعبد من عباد الله]

أخى الفاضل Shivan Rekany 

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

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

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

عاجز بحق عن أداء ما تستحقونه من شكر شكر الله لكم وكان في عونكم كما كنتم في عوننا.

*** إن امكن مشكورا غير مأمور القيام بتحويل وظيفة عمل هذا الكود

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

تم تعديل أغسطس 1, 2017 بواسطه وائل أبو عبد الرحمن

[Shivan Rekany]

تريد نغيير اي كود الى اي
من صورة اعلى الى اسفل
او تغيير الكود صورة اسفل مثل للاعلى
 
 

[ًعبد من عباد الله]

نعم أخى العزيز

تعديل كود الصورة بالأعلى إلى هيئة كود الصورة بالأسفل مع الحفاظ على تأدية وظيفة الكود بعد التعديل للصورة بالأعلى أى (يقوم بإصافة مجموعة صور دفعة واحدة كما كان كود الصورة بالأعلى يفعل ذلك).

شكر لحسن وسرعة أستجابتك الكريمة والنبيلة

تم تعديل أغسطس 1, 2017 بواسطه وائل أبو عبد الرحمن

[ًعبد من عباد الله]

هلا أخى شيفان

أنتظر لتعديل حضرتك منذ الأمس وكان بودى أن أكون صاحب تسجيل الأعجاب رقم 1600 لكم ولكن خيرها في غيرها

أعانك الله وأتمنى أن أمورك تسير على تحب وترضى وإن لم أثقل عليك سأظل بالأنتظار 

[Shivan Rekany]

1 دقيقه مضت, وائل أبو عبد الرحمن said:

هلا أخى شيفان

أنتظر لتعديل حضرتك منذ الأمس وكان بودى أن أكون صاحب تسجيل الأعجاب رقم 1600 لكم ولكن خيرها في غيرها

أعانك الله وأتمنى أن أمورك تسير على تحب وترضى وإن لم أثقل عليك سأظل بالأنتظار 

عندنا تازية اي 

مات احد من اقرباءنا لذلك ليس لدي وقت لكي افتح لابتوبي حتى يوم السبت

الان انا عم استخدم موبايل

اعتذر منك ... انتظرني حتى يوم السبت او حتى اجد وقت كافي للتعديل

تقبل تحياتي

[ًعبد من عباد الله]

أخى العزيز 

كنت أشعر أن وراء غيابك أمر ما فالبقاء لله وحده ولله ما أخذ وله ما أعطى وكل شيء عنده بمقدار فلتصبر ولتحتسب 

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

[Shivan Rekany]

في ٢‏/٨‏/٢٠١٧ at 22:55, وائل أبو عبد الرحمن said:

أنتظر لتعديل حضرتك منذ الأمس

اتفضل اخي 
انا استخدمت هذه الاكواد للنموذج

Option Compare Database
Dim Sec As Integer
 Public Function PicName(FullPic_Name As String)
   Dim Pic_ExtensionPosition As Integer
   Pic_ExtensionPosition = InStr(1, FullPic_Name, ".") + 3
   PicName = Mid(FullPic_Name, 1, Pic_ExtensionPosition)
      End Function

Private Sub AddPictures_Click()
On Error Resume Next
Dim x As FileDialog
Dim mynam As String
Dim Mesar As String
Set x = Application.FileDialog(msoFileDialogFilePicker)
x.AllowMultiSelect = True
If x.Show = -1 Then
For i = 1 To x.SelectedItems.Count
    mynam = Mid$(Trim(x.SelectedItems(i)), InStrRev(Trim(x.SelectedItems(i)), "\") + 1)
Dim newa As String
newa = Mid$(Trim(x.SelectedItems(i)), InStrRev(Trim(x.SelectedItems(i)), ".") + 1)
If newa = "jpg" Or newa = "png" Or newa = "ico" Or newa = "bmp" Or newa = "gif" Or newa = "tif" Or newa = "tga" Then
        FileCopy Trim(x.SelectedItems(i)), CurrentProject.Path + "\fileStores\" & ("" & mynam & "")
        Me.PicFile = "\fileStores\" & ("" & mynam & "")
        Me.imgPicture.Picture = CurrentProject.Path + "\fileStores\" & ("" & mynam & "")
    ElseIf newa = "mp3" Or newa = "wma" Or newa = "ape" Or newa = "amr" Or newa = "wav" Or newa = "mp4" Or newa = "avi" Then
        FileCopy Trim(x.SelectedItems(1)), CurrentProject.Path + "\fileStores\watch\" & PicName("" & mynam & "")
        Me.PicFile = "\fileStores\watch\" & ("" & mynam & "")
        Me.imgPicture.Picture = CurrentProject.Path + "\fileStores\watch\" & ("" & mynam & "")
    ElseIf newa = "txt" Or newa = "docx" Or newa = "doc" Or newa = "exlx" Then
        FileCopy Trim(x.SelectedItems(1)), CurrentProject.Path + "\fileStores\doc\" & ("" & mynam & "")
        Me.PicFile = "\fileStores\doc\" & ("" & mynam & "")
        Me.imgPicture.Picture = CurrentProject.Path + "\fileStores\doc\" & ("" & mynam & "")
End If
DoCmd.GoToRecord , , acNext
Next i
Me.imgPicture.Requery
End If
 Set x = Nothing
End Sub
Private Sub AutoChange_Click()
    Me.StopAndResume.Visible = True
    Me.StopAndResume.Caption = "Stop"
    Me.TimerInterval = 1000
    DoCmd.GoToRecord , , acFirst
End Sub

Private Sub Command21_Click()
On Error Resume Next
    Dim MyPict As String
        DoCmd.SetWarnings False
            MyPict = CurrentProject.Path & Me.PicFile
        Kill (MyPict)
            DoCmd.RunCommand acCmdSelectRecord
            DoCmd.RunCommand acCmdDeleteRecord
            Me.Requery
        DoCmd.SetWarnings True
    MsgBox "تم الحذف"
End Sub
Private Sub Command22_Click()
On Error Resume Next
        Dim MyPict As String
            DoCmd.SetWarnings False
                MyPict = (CurrentProject.Path & "\" & "fileStores\*.*")
            Kill (MyPict)
                DoCmd.RunCommand acCmdSelectAllRecords
                DoCmd.RunCommand acCmdDeleteRecord
                Me.Requery
            DoCmd.SetWarnings True
    MsgBox "تم الحذف"
End Sub

Private Sub Form_Current()
On Error Resume Next
Dim newa As String
newa = Mid$(Trim(Me.PicFile), InStrRev(Trim(Me.PicFile), ".") + 1)
If newa = "jpg" Or newa = "png" Or newa = "ico" Or newa = "bmp" Or newa = "gif" Or newa = "tif" Or newa = "tga" Then
    If Len(Me.PicFile & "") <> 0 Then Me.imgPicture.Picture = CurrentProject.Path + Me.PicFile Else Me.imgPicture.Picture = ""
        Else
    Me.imgPicture.Picture = ""
End If
End Sub

Private Sub Form_Timer()
    Sec = Sec + 1
If Sec >= 3 And Me.CurrentRecord <> Me.RecordsetClone.RecordCount Then
    DoCmd.GoToRecord , , acNext
    Sec = 0
    ElseIf Sec >= 3 And Me.CurrentRecord = Me.RecordsetClone.RecordCount Then
    MsgBox "وصلنا الى اخر صورة .. سيتم اغلاق النموذج"
    DoCmd.Close acForm, Me.Name
End If
End Sub

Private Sub StopAndResume_Click()
    If Me.StopAndResume.Caption = "Stop" Then
            Me.TimerInterval = 0
            Me.StopAndResume.Caption = "Resume"
            Exit Sub
        ElseIf Me.StopAndResume.Caption = "Resume" Then
            Me.TimerInterval = 1000
            Me.StopAndResume.Caption = "Stop"
            Exit Sub
    End If
End Sub

واليك القاعدة بعد تعديل واسف على التأخير

 

pic.rar

[jjafferr]

أخي وائل

 

رجاء الالتزام بقوانين المنتدى ، كما نحن نلتزم به ،

وقد كتبت لي على الخاص بأني حذفت احد مشاركاتك ، ولكني لم افعل ، والمشرفون الآخرون تصرفوا بها لأنها مشاركة في غير محلها ، عيناً كما هي مشاركتك هذه ،

اما الآن ، فانا الذي تصرفت مع مشاركتك الاخير ، والخارجة عن اطار هذا الموضوع ، مشاركة في غير محلها.

 

.

 

جعفر

[ًعبد من عباد الله]

أستاذ جعفر جزاك الله خير

ذكرت لى أمورا على الخاص واحترمت وجهة نظرك فيها رغم بعض اختلافى معها ولقد وضحت بالمشاركة التى قمت أنت بحذفها ان سببها هو تذكيرى للرجل بوعده لى بالانتظار حين عودته بسلامة الله للتفاعل بالمنتدى لإنجاز الأمر وليس إلحاحا عليه بتنفيذ الأمر من البداية كما تنص القواعد

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

عموما نحن معكم ملتزمون بالقواعد ونسعد بتواجدنا بينكم بهذا المنتدى.

تم تعديل أغسطس 5, 2017 بواسطه وائل أبو عبد الرحمن