إستخلاص أسماء صور من فهرس

[أبو أنس حاجب]

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

أساتذتي الأفاضل حفظكم الله

خواتم مباركة وتقبل الله منا ومنكم صالح الأعمال

المطلوب كود في حدث الـ workbook

يقوم بالعمل آلياً والتحديث المستمر بمجرد فتح الملف في أستخلاص أسماء الصور من الفهرس (الفولدر) المسمى MyImage ووضعها في العمود Z أبتداءاً من الخلية Z2 مع الأخذ بعين الأعتبار أن عدد الصور سيكون كثير جداً حتى يكون الكود مرن من هذه الناحية

ولكم جزيل الشكر والاحترام

أبو أنس ناصر حاجب

قاعدة بيانات صور.rar

[طارق محمود]

السلام عليكم

أخي الغالي / أبا أنس

جرب هذا الكود في حدث الملف

Private Sub Workbook_Open()

pth = ActiveWorkbook.Path & "\MyImage\"

Range("Z2:Z" & [Z60000].End(xlUp).Row).ClearContents

x = Dir(pth)

    Do While x <> ""

        i = i + 1

        Sheets(1).[Z1].Offset(i, 0).Value = Left(x, Len(x) - 4)

        x = Dir()

    Loop

End Sub

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل طارق محمود حفظك الله

جزاك الله كل خير على سرعة الرد

أرجو التأكد من السطر الأول فهو يشير لدي عند نسخة إلى وجود خطأ فيه.

أبو أنس

[طارق محمود]

السلام عليكم

أخي الحبيب

عندك حق

تم التعديل في نفس المشاركة

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل طارق محمود حفظك الله

بارك الله لك وبك وفيك

كل شئ تمام الآن

بلغك الله ليلة قدره

أبو أنس

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل طارق محمود حفظك الله

أستميحك عذراً في العودة لهذا الموضوع لأمرين:

الاول عبارة عن تساؤل .. هل أذا اردت ان يعمل الملف لدي في بيئة الأوفيس 2007 أن أحفظ الملف بهذه الصيغة Excel 2007 Macro-Enabled Workbook حيث أنني نقلت الملف إلى جهاز لاب تب فيه الويندوز 7 ولم يعمل الكود.

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

جزاك الله كل خير

أبو أنس

[طارق محمود]

السلام عليكم

الاول: تساؤل .. هل أذا اردت ان يعمل الملف لدي في بيئة الأوفيس 2007 أن أحفظ الملف بهذه الصيغة Excel 2007 Macro-Enabled Workbook

نعم ، كل ماعليك ان تحفظه بتلك الصيغة ذات الإمتداد xlsm

الثاني لاحظت أن الكود يقوم بداية بمسح جميع البيانات في العمود المذكور ثم يقوم بجلب أسماء الصور

هل جلب البيانات يعتمد على التسلسل في الموقع أو الأسم أو تاريخ أضافته إلى الفهرس

جلب البيانات يعتمد على الملفات الموجودة بالفعل في الموقع

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

تفضل المرفق وبه ماطلبت

قاعدة بيانات صور.rar

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل طارق محمود حفظك الله

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

ارفق لك الملف الأصلي كي تتضح الرؤية للمطلوب.

ارجو أن تفتح ملف الاكسيل قبلاً ثم تلاحظ الملاحظات التي توجد مقابل أسم أنس ثم أقفل الملف واحفظه

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

أرجو أن تكون وضحت الصورة

جزاك الله من الخير حتى ترضى وأكرم منزلك في الدارين.

أبو أنس

قاعدة بيانات للصور.rar

[عبدالله باقشير]

السلام عليكم

عيدكم مبارك وكل عام وانتم بخير

بعد اذن اخي الحبيب طارق حفظه الله

ائراءا للموضوع

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

مع تغيير بسيط في الكود

Option Explicit

'//////////////////////////////////////////////////////


Sub kh_AddNamePicture()

Dim MyObj, MyObjFol, Obj

Dim MySheet As Worksheet

Dim iPath As String, iName As String

Dim Last As Long, i As Long

'============================

On Error GoTo Err_kh_Files

'============================

iPath = ActiveWorkbook.Path & "\MyImage\"

Set MyObj = CreateObject("Scripting.FileSystemObject")

Set MyObjFol = MyObj.GetFolder(iPath)

'============================

Set MySheet = ThisWorkbook.Worksheets("Sheet1")

Last = MySheet.Cells(Rows.Count, "Z").End(xlUp).Row

'============================

For Each Obj In MyObjFol.Files

    If Not Dir(Obj.Path, vbDirectory) = "" Then

        iName = Left(Obj.Name, InStrRev(Obj.Name, ".") - 1)

        With MySheet

            If WorksheetFunction.CountIf(.Range("Z2").Resize(Last), iName) = 0 Then

                i = i + 1

                .Cells(Last + i, "Z").Value = iName

            End If

        End With

    End If

Next

'============================

Err_kh_Files:

If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear

Set MySheet = Nothing: Set MyObj = Nothing: Set MyObjFol = Nothing

End Sub

لعلكم تجدون فيه ضالتكم

ولتعم الفائدة

تقبلوا تحياتي وشكري

[طارق محمود]

السلام عليكم

أخي / أبا أنس

إذا حضر الماء ، بطل التيمم

أخي الحبيب وأستاذي /عبدالله

جزاك الله خيرا

عيد مبارك وكل عام وانتم بخير

اسال الله أن يتقبّل صيامنا وقيامنا وأن يعيد الشهر الكريم علينا اجمعين

[أبو أنس حاجب]

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

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

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

كل عام وأنتم في خير ونعمة وعافية ولاحرمكم الله من نعيم الدنيا والآخرة

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

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

الدعاء موصول لأستاذي وسيدي وحبيبي في الله طارق محمود حفظه الله

أبو أنس ناصر حاجب

تم تعديل أغسطس 18, 2012 بواسطه أبو أنس حاجب