(تمت الاجابة) اظهار صورة الموظف على كارت عمل

[وليد المصرى 1]

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

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

اشكركم جميعا

BOOK 33.rar

[جمال الفار]

السلام عليكم اخى فى الله

تم عمل المطلوب جرب

واخبرنى بالنتيجة

ولا تنسانا من دعائك

وفقكم الله

اخيك جمال الفار

ELFAR.rar

[وليد المصرى 1]

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

الشيت مكون من 8 كروت اريد لكل كارت بيانات الموظف وصورتة بمجرد كتابة رقمة الوظيفى

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

[وليد المصرى 1]

Private Sub Worksheet_Change(ByVal Target As Range)

a = Cells(2, "H").Value

q = ActiveWorkbook.Path

em = q & "\" & "empty.JPG"

mm = q & "\" & a & ".JPG"

On Error Resume Next

Image1.Picture = LoadPicture(em)

Image1.Picture = LoadPicture(mm)

End Sub

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

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

اشكركم جميعا

حاولت ارفع الملف ولكن فشلت

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

هذا هو الكود الموجود داخل الملف

تم تعديل فبراير 1, 2012 بواسطه اا عبدالله المجرب اا

[وليد المصرى 1]

منتظر الرد

[وليد المصرى 1]

يا جماعة محتاج الملف ضرورى جزاكم الله خير

[وليد المصرى 1]

السلام عليكم

منتظر الرد

[وليد المصرى 1]

اخيرا الملف اترفع على المنتدى ارجو منكم القاء نظرة علية وهو به كود يعمل لخلية واحدة فقط وهى h2 وانا اريد ان يعمل لاكثر من 6 خلايا لجلب صور الموظفيين

ارجوكم ساعدونى جزاكم الله خير

1.rar

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

السلام عليكم

على السريع استخدم الكود التالي

Option Explicit

Option Compare Text

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

''''''''نطاق الرقم الوظيفي

Private Const MyRng As String = "H2,T2,H20,T20,H38,T38"

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



Private Sub Worksheet_Change(ByVal Target As Range)

Dim MyPicture As Object

Dim a As String, q As String, em As String, mm As String

On Error Resume Next

If Intersect(Target, Range(MyRng)) Is Nothing Then Exit Sub

q = ActiveWorkbook.Path

em = q & "\" & "empty.JPG"

a = Target.Value

mm = q & "\" & a & ".JPG"

Set MyPicture = kh_img(Target.Address)


If Not MyPicture Is Nothing Then

    MyPicture.Picture = LoadPicture(em)

    MyPicture.Picture = LoadPicture(mm)


End If

Set MyPicture = Nothing

On Error GoTo 0

End Sub


Private Function kh_img(Tg As String) As Object

Dim Col As Range

Dim r As Integer

Set kh_img = Nothing

For Each Col In Range(MyRng).Areas

    r = r + 1

    If Col.Address = Tg Then

    ''''''''اسماء عنصر الصورة مرتب مع النطاق

        Set kh_img = Choose(r, Me.Image1, Me.Image2, Me.Image3, Me.Image4, Me.Image5, Me.Image6)

        Exit For

    End If

Next

End Function

[وليد المصرى 1]

اخى عبدلله تقريبا الكود فى خطأ ارجوك التعديل

انا وضعتة ولكن لا يوجد نتيجة

اشكرك اخى عبدلله ومنتظر درك

هذة رسالة الخطأ حددتها بالون الاحمر

اذا امكن اخى عبدلله ترسلى نفس ملفى بالكود

Option ExplicitOption Compare Text'========================================''''''''نطاق الرقم الوظيفيPrivate Const MyRng As String = "H2,T2,H20,T20,H38,T38"'========================================Private Sub Worksheet_Change(ByVal Target As Range)Dim MyPicture As ObjectDim a As String, q As String, em As String, mm As StringOn Error%2

تم تعديل فبراير 2, 2012 بواسطه goodlife

[وليد المصرى 1]

السلام عليكم

على السريع استخدم الكود التالي

Option Explicit

Option Compare Text

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

''''''''نطاق الرقم الوظيفي

Private Const MyRng As String = "H2,T2,H20,T20,H38,T38"

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



Private Sub Worksheet_Change(ByVal Target As Range)

Dim MyPicture As Object

Dim a As String, q As String, em As String, mm As String

On Error Resume Next

If Intersect(Target, Range(MyRng)) Is Nothing Then Exit Sub

q = ActiveWorkbook.Path

em = q & "\" & "empty.JPG"

a = Target.Value

mm = q & "\" & a & ".JPG"

Set MyPicture = kh_img(Target.Address)


If Not MyPicture Is Nothing Then

	MyPicture.Picture = LoadPicture(em)

	MyPicture.Picture = LoadPicture(mm)


End If

Set MyPicture = Nothing

On Error GoTo 0

End Sub


[color=#ff0000]Private Function kh_img(Tg As String) As Object[/color]

Dim Col As Range

Dim r As Integer

Set kh_img = Nothing

For Each Col In Range(MyRng).Areas

	r = r + 1

	If Col.Address = Tg Then

	''''''''اسماء عنصر الصورة مرتب مع النطاق

		Set kh_img = Choose(r, Me.Image1, Me.I[color=#ff0000]mage2[/color], Me.Image3, Me.Image4, Me.Image5, Me.Image6)

		Exit For

	End If

Next

End Function

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

شاهد الرابط التالي

http://www.officena.net/ib/index.php?showtopic=40613

[وليد المصرى 1]

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

[محمد يحياوي]

اخي الكريم دالة الاستاذ خبور دالة رائعة و تفي بالغرض و زيادة و لكني عدلت على ملفك و بنفس الاكواد التي وضعتها لاثراء الموضوع فقط و هو الان يعمل

1.rar

[وليد المصرى 1]

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

اشكركم جميعا