كيفية اضاف صورة الموظف عن طريق الكود

[جمعة محمد محمد]

السلام عليكم

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

والسلام عليكم جميعا 

تجربة.rar

[ahmedgenedy]

 استخدم ده والاحمر ده الباث باع الصور عندك على الجهاز

Function VLOOK_Pic1(PicName)
Dim CurrentCel As Range, Pic As Shape
PicName = PicName: MyPath = ThisWorkbook.Path & "\StaffPhotos\": 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): VLOOK_Pic1 = ""
        Exit For
    Else
        VLOOK_Pic1 = "áÇ ÊæÌÏ ÕæÑÉ"
    End If
Next
End Function
 

[جمعة محمد محمد]

 استخدم ده والاحمر ده الباث باع الصور عندك على الجهاز

Function VLOOK_Pic1(PicName)

Dim CurrentCel As Range, Pic As Shape

PicName = PicName: MyPath = ThisWorkbook.Path & "\StaffPhotos\": 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): VLOOK_Pic1 = ""

        Exit For

    Else

        VLOOK_Pic1 = "áÇ ÊæÌÏ ÕæÑÉ"

    End If

Next

End Function

 

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

[حمادة عمر]

السلام عليكم

 

جرب المرفق التالي

ان شاء الله به طلبك

ولكن يجب ان يكون ملف الصور باسم ( photo ) ويوجد بنفس الفولدر او المجلد الموجود به الملف

 

شاهد المرفق

 

تجربة.rar

 

[عبد الرحمن شفيق]

الاستاذ القدير / حمادة عمر

الاستاذ / احمد جندي

بارك الله لكم

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

[عبدالله فاروق ابو ريان]

السلام عليكم

 

جرب المرفق التالي

ان شاء الله به طلبك

ولكن يجب ان يكون ملف الصور باسم ( photo ) ويوجد بنفس الفولدر او المجلد الموجود به الملف

 

شاهد المرفق

 

الاستاذ الفاضل / حمادة عمر 

السلام عليكم

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

تم تعديل يناير 3, 2015 بواسطه bedonada

[سيف الدين حسام]

جزيت خيرا

خيركم من تعلم العلم وعلمه