كود عرض صورة الموظف حسب الرقم الوظيفي

[ياسين ( أبو وسام )]

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

اسعد الله مسائكم 

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

مرفق نموذج 

 

draft.rar

[علي الشيخ]

السلام عليكم

شوف أخي الفيديو التالي ان شاء الله يفيدك

 

 

واكيد الأخوة هنا عندهم طرق أفضل وأسهل وأكثر احترافيه

[ياسين ( أبو وسام )]

بارك الله فيك اخي علي الشيخ 

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

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

شكرا لك على ردك وننتظر المزيد من اخواني في المنتدى .

ولكم تحياتي

[ياسين ( أبو وسام )]

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

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

 

Function empphoto(PicName)
Dim CurrentCel As Range, Pic As Shape
PicName = PicName: MyPath = ThisWorkbook.Path & "\Picture\": PicName = MyPath & PicName: ChkPic = Array(".jpg", ".bmp", ".gif", ".png")
Set CurrentCel = Application.Caller
For Each Pic In ActiveSheet.Shapes
    If Pic.Type = msoLinkedPicture Then
        If Pic.Top >= CurrentCel.Top And Pic.Top < CurrentCel.Top + CurrentCel.Height Then
            Pic.Delete
            Exit For
        End If
    End If
Next
For X = LBound(ChkPic) To UBound(ChkPic)
    If Not Dir(PicName & ChkPic(X), vbDirectory) = vbNullString Then
        Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width, CurrentCel.Height): empphoto = ""
        Exit For
    Else
        empphoto = ""
    End If
Next
End Function

ارجو المساعدة..

 

 

 

 

[ياسين ( أبو وسام )]

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

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

 

Function empphoto(PicName)
Dim CurrentCel As Range, Pic As Shape
PicName = PicName: MyPath = ThisWorkbook.Path & "\Picture\": PicName = MyPath & PicName: ChkPic = Array(".jpg", ".bmp", ".gif", ".png")
Set CurrentCel = Application.Caller
For Each Pic In ActiveSheet.Shapes
    If Pic.Type = msoLinkedPicture Then
        If Pic.Top >= CurrentCel.Top And Pic.Top < CurrentCel.Top + CurrentCel.Height Then
            Pic.Delete
            Exit For
        End If
    End If
Next
For X = LBound(ChkPic) To UBound(ChkPic)
    If Not Dir(PicName & ChkPic(X), vbDirectory) = vbNullString Then
        Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width, CurrentCel.Height): empphoto = ""
        Exit For
    Else
        empphoto = ""
    End If
Next
End Function

ارجو المساعدة..

 

 

 

 

[ياسين ( أبو وسام )]

صورةتوضح عمل الكود 

 

 

 

 

مرفق نموذج اخر .

Draft.rar

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

الأخ الكريم ياسين أبو وسام

مشكور على هذا الملف الجميل الرائع

إليك الملف التالي بعد التعديل الكبيـــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــر الذي قمت به لعمل المطلوب (لو عرفت التعديل هتحتقرني والله )

جرب وأعلمني بالنتيجة

Insert Photo UDF Function Wesam.rar

[ياسين ( أبو وسام )]

الأخ الكريم ياسين أبو وسام

مشكور على هذا الملف الجميل الرائع

إليك الملف التالي بعد التعديل الكبيـــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــر الذي قمت به لعمل المطلوب (لو عرفت التعديل هتحتقرني والله )

جرب وأعلمني بالنتيجة

حي الله ابو البراء واخيرا اسعدني مرورك وكنت في انتظارك :) 

بس للاسف يا الغالي المرفق ما عما يتحمل ؟؟؟ 

تم تعديل مايو 19, 2015 بواسطه ياسين ( أبو وسام )

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

جرب مرة تانية

الملف المرفق يعمل وجربت تحميله ..ويعمل إن شاء المولى

[ياسين ( أبو وسام )]

بسم الله ماشاء الله عليك ( رائع انت يا أبو البراء ) تم تحميل المرفق ومراجعة الكود من والى النهاية والتعديل كان في :-

 

السابق :

 Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width, CurrentCel.Height ): empphoto = ""

بعد التعديل الكبير الذي استغرق الوقت الطويل والعناء وانا اشكرك على هذا المجهود الجبار :)

 Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width, CurrentCel.Height * 8): empphoto = ""
      

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

لم ينجح الكود في تحديد الصورة في الاطار المطلوب 

 

 

 

مرفق عينة

 

 

Insert Photo UDF Function Wesam.rar

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

جرب تغير في إحداثيات الارتفاع والعرض بما يناسبك

        Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width * 13, CurrentCel.Height * 19): empphoto = ""

وإنت غير براحتك في الأرقام إلى أن تجد أفضل ضبط للصورة

[ياسين ( أبو وسام )]

تمام اكتمل المطلوب .... ربي يوفقك ويعطيك الف عافية ما قصرت يا الغالي 

 

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

 

ولكم تحياتي 

[ياسين ( أبو وسام )]

استفسار اخير ولو غلبتك معي هل بالإمكان اضافة تعديل للكود بحيث يقوم بتحديد طول وعرض الصورة حسب الخلايا المدمجة اي بشكل اتوماتيك بدون ما اقوم بتعديك القيمة بشكل يدوي !!؟

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

الأخ الكريم أبو وسام

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

جرب السطر بهذا الشكل

Set CurrentCel = Application.Caller.MergeArea

يعني ببساطة ضيف هذا الجزء فقط

.MergeArea

بدون أن تعدل في الأرقام شوف الدنيا ماشية معاك إزاي

[ياسين ( أبو وسام )]

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

 

أخي الغالي أبو البراء 

 

 الكود يعمل بشكل ممتاز وهذا ما كنت اريده 

 

ما شاء الله عليك فعلا استاذ الله يجعل هذا العمل في ميزان حسناتك 

 

ولكم تحياتي 

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

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

أخي الكريم ياسين ..

الحمد لله أن تم المطلوب على خير ، ومشكور على تحديد أفضل إجابة ليظهر الموضوع مجاب

 

عايزين نستفيد درس بسيط . إن ممكن يكون الحل بسيط جداً بس محدش بياخد باله منه (شفت الموضوع الكبير الطويل العريض ده عشان كلمة واحدة MergeArea)

تقبل تحياتي