دالة لإدراج صورة

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

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

إخواني الكرام

أثناء تجوالي عثرت على هذه الدالة ، تقوم الدالة بعمل إدراج للصورة

الدالة بالشكل التالي

Function INSERTPICTURE(ByVal PictureFullName As String, Optional ByVal PicWidth As Single = 200, _

													 Optional ByVal PicHeight As Single = 150)


Dim CellActive	 As Range

Dim picPicture	 As Object

Set CellActive = Application.Caller

For Each picPicture In CellActive.Parent.Pictures

	 If picPicture.TopLeftCell.Address = CellActive.Address Then

		 picPicture.Delete

		 Exit For

	 End If

Next

Set picPicture = CellActive.Parent.Pictures.Insert(PictureFullName)

With picPicture

	 .Left = CellActive.Left + 1

	 .Top = CellActive.Top + 1

	 .Width = PicWidth

	 .Height = PicHeight

End With

End Function

لتنفيذ الدالة :

قم بعمل مجلد مثلاً على البارتشن C وأعطه الاسم Pictures وضع صورة في هذا المجلد

في الخلية قم بكتابة المعادلة بالشكل التالي:

=INSERTPICTURE("C:\Pictures\Penguins.jpg")

كما أنه يمكن إضافة أبعاد للصورة (العرض والارتفاع) بهذا الشكل

=INSERTPICTURE("C:\Pictures\Penguins.jpg";200;800)

تم تعديل ديسمبر 14, 2012 بواسطه YasserKhalil

[ريان أحمد]

السلام عليكم

أخي قمت بالخطوات ولم تنجح

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

أخي الغالي

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

ثانيا قم بعمل مجلد على البارتسن C باسم Pictures

ثالثا ضع صورة داخل المجلد Pictures باسم Penguins متبوعاً بنقطة ثم امتداد الصورة التي نسختها

أخيراً اكتب المعادلة بهذا الشكل

 

 

 

=INSERTPICTURE("C:\Pictures\Penguins.jpg")

ثم اضغط إنتر

 

تفضل أخي الحبيب الملف التالي

قم بنسخ المجلد Pictures إلى البارتشن C

ثم في الخلية A1 اضغط دبل كليك

InsertPicture.rar

تم تعديل ديسمبر 14, 2012 بواسطه YasserKhalil

[ريان أحمد]

لم تنجح الطريقة

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

ما هي نسخة الأوفيس التي تعمل عليها؟؟؟

الدالة تعمل لدي بشكل جيد على أوفيس 2007

أرجو من السادة الذين لديهم أوفيس 2003 أن يفيدونا بالنتيجة

[الـعيدروس]

السلام عليكم

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

تقبل مروري

[ريان أحمد]

عندي أفيس 2003 وهي لا تعمل

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

مشكور على مرورك العطر أخي عباد (أبو نصار) ، والحمد لله إنك عرفتني دلوقتي (مش يوسف وإن كنت أحب اسم يوسف)

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

عندي أفيس 2003 وهي لا تعمل

جرب تنزل أوفيس 2007 وتشتغل عليه أكيد حتحس بفرق كبير

[احمدزمان]

السلام عليكم

كل التحية و التقدير اخي ياسر خليل

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

[أبو محمد عباس]

السلام عليكم

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

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

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

المعلم الكبير والأخ الغالي أحمد زمان

بارك الله فيك ومشكور على مرورك العطر (والله زمان)

الأخ عباس

وجزيت بمثله

الحمد لله الذي بنعمته تتم الصالحات

تم تعديل ديسمبر 14, 2012 بواسطه YasserKhalil

[ريان أحمد]

هل توجد طريقة لإكسل 2003 بهذه السهولة

[عبدالله المجرب]

السلام عليكم

الدالة تعمل بكفاءة 2007

==

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

Function INSERTPICTURE(ByVal PictureFullName As String, Optional ByVal PicWidth As Single = 200, _

																										 Optional ByVal PicHeight As Single = 150)

Dim CellActive   As Range

Dim picPicture   As Object

MyName = "C:\Pictures\": MyType = ".jpg"

Set CellActive = Application.Caller

For Each picPicture In CellActive.Parent.Pictures

		 If picPicture.TopLeftCell.Address = CellActive.Address Then

				 picPicture.Delete

				 Exit For

		 End If

Next

Set picPicture = CellActive.Parent.Pictures.Insert(MyName & PictureFullName & MyType)

With picPicture

		 .Left = CellActive.Left + 1

		 .Top = CellActive.Top + 1

		 .Width = PicWidth

		 .Height = PicHeight

End With

End Function

لتصبح الدالة هكذا

=INSERTPICTURE("Penguins")

[عبدالله المجرب]

وهذا التعديل ليتم اضافة نوع الصورة

Function INSERTPICTURE(ByVal PictureFullName As String, MyType As String, Optional ByVal PicWidth As Single = 200, _

																									 Optional ByVal PicHeight As Single = 150)

Dim CellActive   As Range

Dim picPicture   As Object

MyName = "C:\Pictures\"

Set CellActive = Application.Caller

For Each picPicture In CellActive.Parent.Pictures

		 If picPicture.TopLeftCell.Address = CellActive.Address Then

				 picPicture.Delete

				 Exit For

		 End If

Next

Set picPicture = CellActive.Parent.Pictures.Insert(MyName & PictureFullName & "." & MyType)

With picPicture

		 .Left = CellActive.Left + 1

		 .Top = CellActive.Top + 1

		 .Width = PicWidth

		 .Height = PicHeight

End With

End Function

لتصبح الدالة

=INSERTPICTURE("Penguins";"jpg")

[ريان أحمد]

السلام عليكم

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

هل يوجد كود في أفيس 2003 لهذا الإبداع

[عبدالله المجرب]

لم اجربها على 2003 لكن اظنها تعمل

ساقوم غداً ان شاء الله بتجربتها في كمبيوتر العمل لان نظامه 2003

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

بارك الله فيك معلمنا الكبير عبد الله المجرب

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

[ريان أحمد]

لم اجربها على 2003 لكن اظنها تعمل

ساقوم غداً ان شاء الله بتجربتها في كمبيوتر العمل لان نظامه 2003

أستاذي هل جربت الدالة

[عبدالله المجرب]

جربتها

الدالة لاتعمل على 2003

[ريان أحمد]

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

[احمد بهجت]

هل يمكن لي تنفيذ هذة الطريقة بإستخدام دالة vlookup

أو بمعني آخر أريد جلب صورة الموظف بالرقم الوظيفي

مع العلم أن ملف الصور أسمة (picture) في بارتشن © وصورة كل موظف مسماة بالرقم الوظيفي الخاص بة

 

مرفق لكم ملف الإكسيل

 

ولكم وافر التحية والتقدير

Desktop.rar

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

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

الأخ الحبيب أحمد بهجت افتح موضوع جديد لطلبك حتى يتسنى للجميع مساعدتك