اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

احضار محتويات فولدر خارجى الى البرنامج


الردود الموصى بها

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

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

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

والصورة التالية توضح المطلوب

m.salama.thumb.png.227cc127bd1650e6b0c39

m.salama.rar

رابط هذا التعليق
شارك

وعليكم السلام أخي محمد :-)

 

يا ريت توضح أكثر!!

 

جعفر

شو قصدك إحضارة لقاعدة البيانات؟

هل قصدك حفظه في قاعدة البيانات؟

و اذا جوابك كان نعم ، فالسؤال لماذا؟

 

جعفر

رابط هذا التعليق
شارك

يا هلا استاذنا جعفر 

معني او قصدي بكلمة احضار الي قاعدة البيانات هي:

مثلا لدي في فولدر ثلاث ملفات بصيغ مختلفة مثلا صورة باي امتداد وملف word و pdf

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

نعم اقصد حفظ بيانات ما داخل الفولدر في قاعدة البيانات.

الهدف من ذلك 

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

واذا كان هناك طريقة اوان فكرة افضل انا ارحب بها

شكرا لك

تم تعديل بواسطه محمد سلامة(soft.sample)
رابط هذا التعليق
شارك

حيا الله الاخوين محمد و جعفر

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

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

وهناك استفسارين:

1. هل ممكن اختصار مسار المجلد كامل في حقل واحد وفي النموذج الرئيسي وهنا سيحتوي المسار مسار المجلد واسمه بدلا من فصل المسار والاسم

2. هل ممكن كذلك الاكتفاء في النموذج الفرعي بمسار الملف كاملا محتويا على امتداده ! ام لابد من الفصل !

تحياتي  وارجو استمرار الاستاذ جعفر بالمشاركة لافادة اكثر

تم تعديل بواسطه رمهان
  • Like 1
رابط هذا التعليق
شارك

وعليكم السلام أخوي الكريمين محمد  ورمهان :-)

 

فهمي للموضوع هو:

- لديك مجلدات لكل كتاب أو وارد ، والكتاب الصادر أو الوارد قد يحتوي على مجموعة ملفات.

س:

ما إسم هذه المجلدات؟

أين توجد في الكمبيوتر؟

هل إسم المجلد له علاقة باي من حقول السجل؟

 

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

س:

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

هل ممكن استعمال هذه الطريقة ، أو أنك تريد الأسماء في الجدول لأنك تريد إضافة ملاحظات لكل ملف؟

س:

شرحت لك أعلاه طريقة فتح الملف ، سواء بطريقتي أو بطريقتك في النموذج الفرعي.

فلماذا تريد أن تحفظ الملف داخل قاعدة البيانات؟

حفظ الملفات داخل قاعدة البيانات غلط ، إلا في حدود جدا ضيقة ، وإلا فسيكبر حجم قاعدة بياناتك بطريقة مهولة ، وقد تصل إلى مرحلة العطب أو عدم إمكانية إضافة سجلات بها ، انا رأيت مثل هذه البرنامج :-(

 

جعفر

  • Like 1
رابط هذا التعليق
شارك

ياهلا باستاد رمهان واستاذ جعفر

اولا وقبل اي شئ يكفيني شرفا ان تعلقوا انتم الاثنين علي موضوعي

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

اما بشان قراءة ما بداخل المجلد فانا احتاج حقل الملاحظات. ولا اريد ان اعرضهم في مربع قائمةListbox 

اريد ان اعرضهم داخل نموذج فرعي بنفس صيغة الصورة بعاليه 

طبعا المرفقات موجوده داخل فولدر بالبرتشن D داخل مجلد البرنامج 

 

اما بالنسبة لسؤالين استاذي رمهان. 

1-اريد فصل اسم المجلد من المسار

2- اريد فصل اسم وصيغة الملف من مسارهم ايضا

وذلك لاسباب تتعلق بالتوسعة المستقبلية للبرنامج 

بارك الله فيكم واشكركم شكرا جزيلا

تم تعديل بواسطه محمد سلامة(soft.sample)
رابط هذا التعليق
شارك

اوك . تمام

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

فمثلا هل هناك احتمال حذف ملف يدويا مباشرة من الويندوز او اضافة ملف او حتى تعديل اسم ملف.

تحياتي

  • Like 1
رابط هذا التعليق
شارك

تحياتي استاذ رمهان

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

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

بارك الله فيك

رابط هذا التعليق
شارك

اعزائي

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

نحتاج الفكرة او الطريقة او السيناريو ومسألة التنفيذ سهلة !

نفكر وفكرو وعلينا وعليكم لا تبخلو ! شاركونا الافكار !

 

تحياتي

رابط هذا التعليق
شارك

يوجد مثال  للاخت زهرة ربما تستفيد منه

za-OpenAllFiles.rar

شكرا اخي نهر الفنون على المشاركة !

وسبحان الله هذه الاستاذة غائبة حاضرة في كل مكان باعمالها الخالدة !

 

مفيشجديد ياستاذه

صبرا ال ياسر !

كنت حاب نشوف افكار قبل ما انفذ ما لدي ! 

قريبا اخ محمد ارفع المشاركة ! واكيد الاستاذ جعفر مسافر !

تم تعديل بواسطه رمهان
رابط هذا التعليق
شارك

وعليكم السلام أخي محمد :smile:

أخي رمهان ، رحم الله والديك على السؤال عني :wink2:

 

السؤال ظاهرا سهل ، ولكنه ليس كذلك :blink:

 

اللي عملته هو:

1. تغيير اسم النموذج الى frm_wared ، والنموذج الفرعي الى sfrm_emp_wared ،

2. في النموذج الرئيسي ، اضغط على زر المجلد ، وتستطيع اختيار المجلد الذي به الملفات:

207.Clipboard05.thumb.jpg.d67fab2acdd956

.

3. اضفت حقل جديد في الجدول للنموذج الفرعي ، اسمه File_Check ، ونستفيد منه في تلوين وتعريف السجل ، وعملناه مخفي:

207.Clipboard00.thumb.jpg.b9b0c593ac654e

.

4. عملنا تنسيق شرطي لأحد الحقول (تستطيع ان تعمله لبقة الحقول ان احببت):

207.Clipboard01.thumb.jpg.016dd6b96afb7c

.

وهذان هما الشرطان فيه:

207.Clipboard02.thumb.jpg.961893c29e33a1

.

والالوان معناها:

اللون الابيض: هناك ملف في المجلد بنفس الاسم ،

اللون الاخضر: هذا السجل لا يوجد ملف بنفس اسمه ،

اللون الازرق: هذا الملف موجود في المجلد وغير موجود في السجلات،

.

5. وهذه نتيجة احد السجلات:

207.Clipboard03.thumb.jpg.969d570ce26619

.

6. وعندما تريد حذف السجل:

207.Clipboard04.thumb.jpg.f1b72f8f41c298

.

 

العمل على البرنامج اسهل من شرحه :smile:

وهذا هو الكود كاملا:

Option Compare Database

Private Sub cmd_Open_Folder_Click()
 
    Dim strFolderName As String
    Dim strMsg As String
    
    If Len(Me.pate & "") <> 0 Then
    
        Dim Msg, Style, Response
        Msg = "مسار الملف موجود ، هل تريد تغيير المسار" & vbCrLf & _
              "هل انت متاكد انك تريد الاستمرار في العملية" & vbCrLf & _
              "Do you want to continue ?"

        Style = vbYesNo + vbCritical + vbDefaultButton2
        Response = MsgBox(Msg, Style, Title, Help, Ctxt)
        If Response = vbYes Then

                    
            strMsg = "رجار اختيار المجلد" & vbCrLf & _
                     "What Folder you want to select?"
            strFolderName = BrowseFolder(strMsg)
            
            If Len(strFolderName & "") <> 0 Then
                Me.pate = strFolderName
                Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1)
            End If
    
        End If
    
    Else
    
            strMsg = "رجار اختيار المجلد" & vbCrLf & _
                     "What Folder you want to select?"
            strFolderName = BrowseFolder(strMsg)

            If Len(strFolderName & "") <> 0 Then
                Me.pate = strFolderName
                Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1)
            End If
            
    End If  'Len

    'now bring the files from the folder
    Call Make_File_Array
    
End Sub

Function Make_File_Array()
On Error GoTo err_Make_File_Array

'Folder info

    Dim File_Count As Integer
    Dim fdr As Variant
    Dim Files_Array() As Variant
    
    
    iPath_In = Me.pate
    iCondition = "*.*"
    
    'No Path, exit
    If Len(iPath_In & "") = 0 Then Exit Function
    
    'get the file count from the Forlder, and
    'place the files in an array
    fdr = Dir(iPath_In & "\" & iCondition)
    File_Count = 0
    Do While fdr <> ""
        File_Count = File_Count + 1
        
        ReDim Preserve Files_Array(File_Count)
        Files_Array(File_Count) = fdr
        
        fdr = Dir
    Loop
    

    
'got the folder file count=File_Count, and the files=Files_Array(i)
'SubForm Records

    Dim rst As DAO.Recordset
    
    Set rst = Me.sfrm_emp_wared.Form.RecordsetClone
    rst.MoveLast: rst.MoveFirst
    RC = rst.RecordCount
    
    
  '1. Make all Records, File_Check=1 (No File)
    For j = 1 To RC
        rst.Edit
            rst!File_Check = 1
        rst.Update
    
        rst.MoveNext
    Next j


  '2. Compare
    For i = 1 To UBound(Files_Array)    'File_Count
        iname_morfke = Files_Array(i)
        itayp = Mid(Files_Array(i), InStrRev(Files_Array(i), ".") + 1)
            
        rst.FindFirst "name_morfke='" & iname_morfke & "'"
                
            If rst.NoMatch Then
                'No Match
                rst.AddNew
                    rst!name_morfke = iname_morfke
                    rst!tayp = itayp
                    rst!File_Check = 2
                    rst!emp_id = Me.id_m
                rst.Update
                
            Else
                'Matching
                'but is it the same extension
                If rst!tayp = itayp Then
                    'Matching
                    rst.Edit
                        rst!File_Check = 0
                    rst.Update
                Else
                    'No Match
                    rst.AddNew
                        rst!name_morfke = iname_morfke
                        rst!tayp = itayp
                        rst!File_Check = 2
                        rst!emp_id = Me.id_m
                    rst.Update
                End If
            End If
        
    Next i
    
    rst.Requery

Exit Function

err_Make_File_Array:

    If Err.Number = 3021 Then
        'ignor, SubForm is empty
        Resume Next
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
End Function
Private Sub Form_Current()

    'now bring the files from the folder
    Call Make_File_Array
           
End Sub

 

 

جعفر

207.1.m.salama.accdb.zip

  • Like 1
رابط هذا التعليق
شارك

حياك الله اخوي جعفر داءما وابدا

بنظرة سريعة  ماقصرت والله ! دائما مبدع !

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

اجمل تحية

 

  • Like 1
رابط هذا التعليق
شارك

حيا الله أخوي رمهان :smile:

 

مقارنة ملفات المجلد ، باسماء الملفات في السجلات ، هو الذي اخذ الكثير من الوقت ، ليس المقارنة نفسها ، وانما ماذا افعل اذا كان هناك ملف بدون سجل ، او سجل بدون ملف :blink:

بالاضافة الى كيفية جعل البرنامج يشتغل بأقل تدخل من المستخدم :smile:

 

وهنا (وبعد الغداء :smile:) ساشرح البرنامج بطريقة مفصلة اكثر:

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

 

جعفر

  • Like 3
رابط هذا التعليق
شارك

الله الله الله 

والله العظيم استاذ جعفر منا عارف كيف اشكرك 

عمل مبدع ورائع جدا

تابعت الشرح وعجبني جدا

افكارك ماشاءالله

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

واقول لك 

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

بجد متشكر جدااااا استاذ جعفر

 

وتحياتي اخي وأستاذي رمهان والله ما قصرت . وانتظر مثالك

تم تعديل بواسطه محمد سلامة(soft.sample)
رابط هذا التعليق
شارك

بارك الله فيك استاذ جعفر 

تعديلات جميلة جدا وهى والحمد لله تفى بالغرض جدا

اريد فقط اخر تعديل

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

On Error Resume Next
Dim x As FileDialog
Set x = Application.FileDialog(msoFileDialogFilePicker)
x.AllowMultiSelect = True
If x.Show = -1 Then
For I = 1 To x.SelectedItems.Count
CurrentDb.Execute "insert into [tbl_emp_wared]([emp_id],[file_loc]) values(" & ID & ",'" & x.SelectedItems(I) & "')"
Next I
Me.sfrm_emp_wared.Requery
End If

فتم التعديل على المرفق الاخير من قبلك استاذ جعفر وادراج زر جديد باسم "إدراج مرفقات من الكمبيوتر"  (انظر الصورة التالية) وتم وضع خلف هذا الزر الكود المذكور باعلى ويعمل بكفاءة

فقط اريد التعديل على هذا الكود لكى يتواكب مع التغير الذى تم فى النموذج الفرعى

واريده عند النقر عليه يقوم بنسخ المرفقات الى المجلد المختار بالنموذج الرئيسي

هذا فقط ما اريده وهو اخر شئ

ولكم جزيل الشكر استاذ جعفر واستاذ رمهان

ملحوظة : هذا الكود يحتاج الى تسجيل الاداة التالية حتى يعمل بكفاءة "microsoft office 14.0 objekt labray" 

003.thumb.png.db8ba9d348b7c401e266ced0ef

وهذا هو المرفق بعد اضافة الكود المذكور

 .2.m.salama.rar

تحياتى لكم وشكرا جزيلا استاذ جعفر

فقط اريد التعديل على هذا الكود لكى يتواكب مع التغير الذى تم فى النموذج الفرع

 ما هو التغير الذى حدث على النموذج الفرعى

طبقا للكود السابق كان يقوم بادراج رابط الملفات كامل مثلا (D:\Archives\المرفقات\942.pdf)

اما بعد تعديل النموذج الفرعى اصبح يتم ادراج اسم المرفق وصيغته فقط

ارت فقط التوضيح

تم تعديل بواسطه محمد سلامة(soft.sample)
رابط هذا التعليق
شارك

مرحبا اعزائي

تفضل اخ محمد مع ملاحظة:

1. تم الغاء بعض الحقول حيث الاخر محسوب

2. هناك دالة وتنسيق شرطي تشيك فقط على صحة المسار

متمنيا ان اثرينا الموضوع مع الاستاذ جعفر وحصلة الفائدة للجميع وكتب الله اجر الجميع

Private Sub أمر12_Click()
FileDialog(msoFileDialogFolderPicker).InitialFileName = CurrentProject.Path
If FileDialog(msoFileDialogFolderPicker).Show = -1 Then pate = FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End Sub

Private Sub أمر12_LostFocus()
If pate.OldValue <> pate.Value Then
If MsgBox("تم تغيير المجلد .. وسيتم اضافة ملفات جديدة???", vbOKCancel) = vbOK Then
DoCmd.SetWarnings False
DoCmd.RunSQL "delete * from tbl_emp_wared where emp_id=" & id_m
xp = Dir(pate & "\")
Do While xp <> ""
DoCmd.RunSQL "insert into [tbl_emp_wared]([emp_id],[file_s]) values(" & id_m & ",'" & xp & "')"
xp = Dir
Loop
DoCmd.SetWarnings True
Me.tbl_emp_wared_نموذج_فرعي.Requery
Else
Undo
End If
End If
End Sub

تحياتي

m.salama.rar

رابط هذا التعليق
شارك

تفضل :smile:

والكود اصبح:

Option Compare Database

    Dim rst As DAO.Recordset
    
Private Sub cmd_Open_desktob_Click()
'On Error Resume Next
'Dim x As FileDialog
'Set x = Application.FileDialog(msoFileDialogFilePicker)
'x.AllowMultiSelect = True
'If x.Show = -1 Then
'For i = 1 To x.SelectedItems.Count
'CurrentDb.Execute "insert into [tbl_emp_wared]([emp_id],[file_loc]) values(" & ID & ",'" & x.SelectedItems(i) & "')"
'Next i
'Me.sfrm_emp_wared.Requery
'End If

    Dim strFileNames As Variant
  
    'check if the Dir exists
    If Dir(Me.pate, vbDirectory) = "" Then
        MsgBox "المسار" & vbCrLf & Me.pate & vbCrLf & _
               "غير موجود في الكمبيوتر" & vbCrLf & _
               "Sorry, this folder does not exist"
        Exit Sub
    End If

    
    'call the open dialog API
    ' set the Filter for the Multi File Dialog, so it only shows these files
    'strFilter = "Image Files " & _
             "(*.JPG,*.JPEG,*.JPE,*.GIF,*.BMP,*.DIB,*.TIF,*.TIFF,*.PNG,*.PCX,*.PCD,*.ICO,*.WMF,*.EMF,*.EPS,*.fpx)" & vbNullChar & _
              "*.JPG;*.JPEG;*.JPE;*.GIF;*.BMP;*.DIB;*.TIF;*.TIFF;*.PNG;*.PCX;*.PCD;*.ICO;*.WMF;*.EMF;*.EPS;*.fpx" & vbNullChar & vbNullChar
    strFilter = "All Files " & _
             "(*.*)" & vbNullChar & _
              "*.*" & vbNullChar & vbNullChar
    sFolder = "C:\"
    
    ' call the API for the Multi File Dialog
    strFileNames = apiBrowseFiles("Select a File, OR Multiple Files", sFolder, , strFilter)
    
    ' user didn't select any file, s/he proceed cancel
    If UBound(strFileNames) = 0 Then
        Exit Sub
    End If
    
    SelectedFiles = UBound(strFileNames) ' number of selected files
        
    ' take the 1st file name and extract the Folder name from it
    ' Don't Dim sFolder, it has been declared as Global variable
    ' so that the last folder visited will be opened again
    sFolder = strFileNames(1)
    Do While Right(sFolder, 1) <> "\"
      sFolder = Left(sFolder, Len(sFolder) - 1)
    Loop
    sFolder = Replace(sFolder, "\\", "\")


    Set rst = Me.sfrm_emp_wared.Form.RecordsetClone
    
    
    ' Add the selected items, and seperate them by a ; so that we use it as Row Source for
    ' list the files selected in the Listbox lstMultipleFiles
    For i = 1 To UBound(strFileNames)
    
        FileExt = Right(strFileNames(i), 3)
        File_Path_Name = Replace(strFileNames(i), "\\", "\")
        File_Name = Replace(File_Path_Name, sFolder, "")
        
        ' Copy the original file to Folder in the main Form
        FileCopy File_Path_Name, Me.pate & "\" & File_Name
    
                rst.AddNew
                    rst!name_morfke = File_Name
                    rst!tayp = FileExt
                    rst!File_Check = 2
                    rst!emp_id = Me.id_m
                rst.Update
    Next i

End Sub

Private Sub cmd_Open_Folder_Click()
 
    Dim strFolderName As String
    Dim strMsg As String
    
    If Len(Me.pate & "") <> 0 Then
    
        Dim Msg, Style, Response
        Msg = "مسار الملف موجود ، هل تريد تغيير المسار" & vbCrLf & _
              "هل انت متاكد انك تريد الاستمرار في العملية" & vbCrLf & _
              "Do you want to continue ?"

        Style = vbYesNo + vbCritical + vbDefaultButton2
        Response = MsgBox(Msg, Style, Title, Help, Ctxt)
        If Response = vbYes Then

                    
            strMsg = "رجار اختيار المجلد" & vbCrLf & _
                     "What Folder you want to select?"
            strFolderName = BrowseFolder(strMsg)
            
            If Len(strFolderName & "") <> 0 Then
                Me.pate = strFolderName
                Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1)
            End If
    
        End If
    
    Else
    
            strMsg = "رجار اختيار المجلد" & vbCrLf & _
                     "What Folder you want to select?"
            strFolderName = BrowseFolder(strMsg)

            If Len(strFolderName & "") <> 0 Then
                Me.pate = strFolderName
                Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1)
            End If
            
    End If  'Len

    'save this Record, to save the ID, so that the subForm can use it
    DoCmd.RunCommand acCmdSaveRecord
    
    'now bring the files from the folder
    Call Make_File_Array
    
End Sub

Function Make_File_Array()
On Error GoTo err_Make_File_Array

'Folder info

    Dim File_Count As Integer
    Dim fdr As Variant
    Dim Files_Array() As Variant
    
    
    iPath_In = Me.pate
    iCondition = "*.*"
    
    'No Path, exit
    If Len(iPath_In & "") = 0 Then Exit Function
    
    'get the file count from the Forlder, and
    'place the files in an array
    fdr = Dir(iPath_In & "\" & iCondition)
    File_Count = 0
    Do While fdr <> ""
        File_Count = File_Count + 1
        
        ReDim Preserve Files_Array(File_Count)
        Files_Array(File_Count) = fdr
        
        fdr = Dir
    Loop
    

    
'got the folder file count=File_Count, and the files=Files_Array(i)
'SubForm Records

    'Dim rst As DAO.Recordset
    
    Set rst = Me.sfrm_emp_wared.Form.RecordsetClone
    rst.MoveLast: rst.MoveFirst
    RC = rst.RecordCount
    
    
  '1. Make all Records, File_Check=1 (No File)
    For j = 1 To RC
        rst.Edit
            rst!File_Check = 1
        rst.Update
    
        rst.MoveNext
    Next j


  '2. Compare
    For i = 1 To UBound(Files_Array)    'File_Count
        iname_morfke = Files_Array(i)
        itayp = Mid(Files_Array(i), InStrRev(Files_Array(i), ".") + 1)
            
        rst.FindFirst "name_morfke='" & iname_morfke & "'"
                
            If rst.NoMatch Then
                'No Match
                rst.AddNew
                    rst!name_morfke = iname_morfke
                    rst!tayp = itayp
                    rst!File_Check = 2
                    rst!emp_id = Me.id_m
                rst.Update
                
            Else
                'Matching
                'but is it the same extension
                If rst!tayp = itayp Then
                    'Matching
                    rst.Edit
                        rst!File_Check = 0
                    rst.Update
                Else
                    'No Match
                    rst.AddNew
                        rst!name_morfke = iname_morfke
                        rst!tayp = itayp
                        rst!File_Check = 2
                        rst!emp_id = Me.id_m
                    rst.Update
                End If
            End If
        
    Next i
    
    rst.Requery

Exit Function

err_Make_File_Array:

    If Err.Number = 3021 Then
        'ignor, SubForm is empty
        Resume Next
        
    ElseIf Err.Number = 9 Then
        'ignor, SubForm is empty
        Exit Function
        
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
End Function
Private Sub Form_Current()

    'now bring the files from the folder
    Call Make_File_Array
           
End Sub

 

 

جعفر

207.2.m.salama.accdb.zip

  • Like 1
رابط هذا التعليق
شارك

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

اشكرك استاذى جعفر بالفعل كودك الاخير هو مطابى بضبط

والله ما اعرف كيف اشكرك

واشكر استاذى رمهان شكرا جزيلا واقول له بارك الله فيك ولك الاجر والثوب باذن الله

واسمحو لى ان اتقدم بتلك الهدية البسيطة جدا

55d66513bcb4e_1.thumb.png.037399d3d8933255d66528122af_2.thumb.png.316fc9ebb42f30

رابط هذا التعليق
شارك

  • 2 weeks later...
  • 3 months later...

السلام عليكم

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

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

بارك الله فيك

رابط هذا التعليق
شارك

وعليكم السلام أخي محمد :rol:

 

وهل تعتقد بأني لازلت اذكر ما عملته قبل 4 اشهر :blink:

 

رجاء اخبرني ما كنا نفعله ، وماذا تريد ان تفعل الان ، وبأمثله لوسمحت :rol:

 

 

جعفر

  • Like 1
رابط هذا التعليق
شارك

ههههههههه

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

تحياتي

رابط هذا التعليق
شارك

  • 11 months later...
في ٢٠‏/٨‏/٢٠١٥ at 22:43, jjafferr said:

تفضل :smile:

والكود اصبح:


Option Compare Database

    Dim rst As DAO.Recordset
    
Private Sub cmd_Open_desktob_Click()
'On Error Resume Next
'Dim x As FileDialog
'Set x = Application.FileDialog(msoFileDialogFilePicker)
'x.AllowMultiSelect = True
'If x.Show = -1 Then
'For i = 1 To x.SelectedItems.Count
'CurrentDb.Execute "insert into [tbl_emp_wared]([emp_id],[file_loc]) values(" & ID & ",'" & x.SelectedItems(i) & "')"
'Next i
'Me.sfrm_emp_wared.Requery
'End If

    Dim strFileNames As Variant
  
    'check if the Dir exists
    If Dir(Me.pate, vbDirectory) = "" Then
        MsgBox "المسار" & vbCrLf & Me.pate & vbCrLf & _
               "غير موجود في الكمبيوتر" & vbCrLf & _
               "Sorry, this folder does not exist"
        Exit Sub
    End If

    
    'call the open dialog API
    ' set the Filter for the Multi File Dialog, so it only shows these files
    'strFilter = "Image Files " & _
             "(*.JPG,*.JPEG,*.JPE,*.GIF,*.BMP,*.DIB,*.TIF,*.TIFF,*.PNG,*.PCX,*.PCD,*.ICO,*.WMF,*.EMF,*.EPS,*.fpx)" & vbNullChar & _
              "*.JPG;*.JPEG;*.JPE;*.GIF;*.BMP;*.DIB;*.TIF;*.TIFF;*.PNG;*.PCX;*.PCD;*.ICO;*.WMF;*.EMF;*.EPS;*.fpx" & vbNullChar & vbNullChar
    strFilter = "All Files " & _
             "(*.*)" & vbNullChar & _
              "*.*" & vbNullChar & vbNullChar
    sFolder = "C:\"
    
    ' call the API for the Multi File Dialog
    strFileNames = apiBrowseFiles("Select a File, OR Multiple Files", sFolder, , strFilter)
    
    ' user didn't select any file, s/he proceed cancel
    If UBound(strFileNames) = 0 Then
        Exit Sub
    End If
    
    SelectedFiles = UBound(strFileNames) ' number of selected files
        
    ' take the 1st file name and extract the Folder name from it
    ' Don't Dim sFolder, it has been declared as Global variable
    ' so that the last folder visited will be opened again
    sFolder = strFileNames(1)
    Do While Right(sFolder, 1) <> "\"
      sFolder = Left(sFolder, Len(sFolder) - 1)
    Loop
    sFolder = Replace(sFolder, "\\", "\")


    Set rst = Me.sfrm_emp_wared.Form.RecordsetClone
    
    
    ' Add the selected items, and seperate them by a ; so that we use it as Row Source for
    ' list the files selected in the Listbox lstMultipleFiles
    For i = 1 To UBound(strFileNames)
    
        FileExt = Right(strFileNames(i), 3)
        File_Path_Name = Replace(strFileNames(i), "\\", "\")
        File_Name = Replace(File_Path_Name, sFolder, "")
        
        ' Copy the original file to Folder in the main Form
        FileCopy File_Path_Name, Me.pate & "\" & File_Name
    
                rst.AddNew
                    rst!name_morfke = File_Name
                    rst!tayp = FileExt
                    rst!File_Check = 2
                    rst!emp_id = Me.id_m
                rst.Update
    Next i

End Sub

Private Sub cmd_Open_Folder_Click()
 
    Dim strFolderName As String
    Dim strMsg As String
    
    If Len(Me.pate & "") <> 0 Then
    
        Dim Msg, Style, Response
        Msg = "مسار الملف موجود ، هل تريد تغيير المسار" & vbCrLf & _
              "هل انت متاكد انك تريد الاستمرار في العملية" & vbCrLf & _
              "Do you want to continue ?"

        Style = vbYesNo + vbCritical + vbDefaultButton2
        Response = MsgBox(Msg, Style, Title, Help, Ctxt)
        If Response = vbYes Then

                    
            strMsg = "رجار اختيار المجلد" & vbCrLf & _
                     "What Folder you want to select?"
            strFolderName = BrowseFolder(strMsg)
            
            If Len(strFolderName & "") <> 0 Then
                Me.pate = strFolderName
                Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1)
            End If
    
        End If
    
    Else
    
            strMsg = "رجار اختيار المجلد" & vbCrLf & _
                     "What Folder you want to select?"
            strFolderName = BrowseFolder(strMsg)

            If Len(strFolderName & "") <> 0 Then
                Me.pate = strFolderName
                Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1)
            End If
            
    End If  'Len

    'save this Record, to save the ID, so that the subForm can use it
    DoCmd.RunCommand acCmdSaveRecord
    
    'now bring the files from the folder
    Call Make_File_Array
    
End Sub

Function Make_File_Array()
On Error GoTo err_Make_File_Array

'Folder info

    Dim File_Count As Integer
    Dim fdr As Variant
    Dim Files_Array() As Variant
    
    
    iPath_In = Me.pate
    iCondition = "*.*"
    
    'No Path, exit
    If Len(iPath_In & "") = 0 Then Exit Function
    
    'get the file count from the Forlder, and
    'place the files in an array
    fdr = Dir(iPath_In & "\" & iCondition)
    File_Count = 0
    Do While fdr <> ""
        File_Count = File_Count + 1
        
        ReDim Preserve Files_Array(File_Count)
        Files_Array(File_Count) = fdr
        
        fdr = Dir
    Loop
    

    
'got the folder file count=File_Count, and the files=Files_Array(i)
'SubForm Records

    'Dim rst As DAO.Recordset
    
    Set rst = Me.sfrm_emp_wared.Form.RecordsetClone
    rst.MoveLast: rst.MoveFirst
    RC = rst.RecordCount
    
    
  '1. Make all Records, File_Check=1 (No File)
    For j = 1 To RC
        rst.Edit
            rst!File_Check = 1
        rst.Update
    
        rst.MoveNext
    Next j


  '2. Compare
    For i = 1 To UBound(Files_Array)    'File_Count
        iname_morfke = Files_Array(i)
        itayp = Mid(Files_Array(i), InStrRev(Files_Array(i), ".") + 1)
            
        rst.FindFirst "name_morfke='" & iname_morfke & "'"
                
            If rst.NoMatch Then
                'No Match
                rst.AddNew
                    rst!name_morfke = iname_morfke
                    rst!tayp = itayp
                    rst!File_Check = 2
                    rst!emp_id = Me.id_m
                rst.Update
                
            Else
                'Matching
                'but is it the same extension
                If rst!tayp = itayp Then
                    'Matching
                    rst.Edit
                        rst!File_Check = 0
                    rst.Update
                Else
                    'No Match
                    rst.AddNew
                        rst!name_morfke = iname_morfke
                        rst!tayp = itayp
                        rst!File_Check = 2
                        rst!emp_id = Me.id_m
                    rst.Update
                End If
            End If
        
    Next i
    
    rst.Requery

Exit Function

err_Make_File_Array:

    If Err.Number = 3021 Then
        'ignor, SubForm is empty
        Resume Next
        
    ElseIf Err.Number = 9 Then
        'ignor, SubForm is empty
        Exit Function
        
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
End Function
Private Sub Form_Current()

    'now bring the files from the folder
    Call Make_File_Array
           
End Sub

 

 

جعفر

207.2.m.salama.accdb.zip

السلام عليكم استاذ جعفر. 

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

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

اريد  ان يعاد تسمياتها بالشكل التالي 

اذا كان.رقم المسلسل مثلا 1 

اذا المرفق ياخذ اسم At1-1 

At هي اختصار لاسم مرفق 

وال 1 هي رقم المسلسل في المثال بعاليه

وال 1 هي رقم المرفق المنسوخ في الفولدر

وهذا مثال للمرفقات الخاصة بالمسلسل 1 داخل الفولدر

 At1-1

At1-2

At1-3

وهكذا

واشكرك شكرا جزيلا علي كل نا وصلن اليه في هذا المثال.. بارك الله فيك 

 

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information