دالة تمكنك من وضع صورة داخل شكل تلقائي اتوماتيكيا

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

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

 

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

 

دالة  kh_ShowImage            
            
            
دالة تمكنك من وضع صورة داخل شكل تلقائي اتوماتيكيا            
يمكنك تغيير اسم او مسار مجلد الصور من داخل كود الدالة            
            
            
وسائط الدالة            
NameImag    اسم الصورة                افتراضي
ImagRng       خلية وضع الصورة        افتراضي
MyWidth       عرض الصورة             اختياري
MyHeight      طول الصورة               اختياري
            
            
ـ  اذا لم تحدد طول او عرض معين للصورة تاخذ الصورة عرض وطول            
الخلية الموضوعة فيها ImagRng            
            
ـ  اذا قمت بتحريك الصورة يدويا تفقد الصورة ارتباطها بالدالة            
وعند تحديث الدالة تقوم باضافة الصورة مرة اخرى في مكانها المحدد في الدالة            
 

 

كود الدالة:

Option Explicit
Option Compare Text
'=============================================
'          عرض صورة في الخليةِ
'       Showing an image in cell
'=============================================
'           اسم مجلد الصور
' اذا كان مجلد الصور في نفس مجلد ملف الاكسل
'           اكتب اسمه فقط
'        والا اكتب المسار كاملا
' "D:\MyDocument\MyFunction\photo"

Private Const kh_pic As String = "MyImeg"
'=============================================
'  امكانية تحرير اي نوع من الصور لديك ادناه
Private Const MyTyp As String = ".jpg,.bmp,.gif,.png,.tif"
'=============================================
'=============================================

Function kh_ShowImage(ByVal NameImag, ByVal ImagRng As Range, Optional ByVal MyWidth As Single, Optional ByVal MyHeight As Single)
Dim Tp
Dim shp As Shape
Dim ibo As Boolean
Dim MyTop As Single, MyLeft As Single
Dim MyFile As String, MyPath As String
'----------------------------------
On Error GoTo 1
'----------------------------------
MyTop = ImagRng.Top: MyLeft = ImagRng.Left
With ImagRng.Worksheet
    For Each shp In .Shapes
        If shp.Top = MyTop And shp.Left = MyLeft Then
            shp.Delete: Exit For
        End If
    Next shp
End With
'-----------------------------------
If IsEmpty(NameImag) Then GoTo 1
'-----------------------------------
If MyWidth = 0 Then MyWidth = ImagRng.Width
If MyHeight = 0 Then MyHeight = ImagRng.Height
'-----------------------------------
If Not InStr(kh_pic, ":") Then MyPath = ThisWorkbook.path & "\"
MyFile = MyPath & kh_pic & "\" & CStr(NameImag)
'-----------------------------------
For Each Tp In Split(MyTyp, ",")
    If Not Dir(MyFile & Trim(Tp), vbDirectory) = vbNullString Then
        With ImagRng.Worksheet.Shapes.AddShape(msoShapeRectangle, MyLeft, MyTop, MyWidth, MyHeight)
            .Fill.UserPicture MyFile & Trim(Tp)
        End With
        ibo = True
        Exit For
    End If
Next
1
kh_ShowImage = ibo
End Function

المرفق 2003-2010

دالة عرض صورة في خلية بطول وعرض اختياري.rar

 

[أبو حنــــين]

السلام عليكم

جزاك الله خيرا أخي الحبيب عبد الله على هذا العمل  المتقن كالعادة

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

[حمادة عمر]

السلام عليكم

الاستاذ القدير العلامة الخبير / عبدالله باقشير

بارك الله فيك

دمت لنا دائما بخير وسلام

وكل عام وانتم بخير بمناسبة هذه الايام العطرة

وبالطبع وبالتأكيد ان اسلوبك ابداعي وطريقتك من نوع خاص خبوريه خالصة

اكواد راائعة وافكار ممتازة ... ولا يوجد كلمات توصف ابداعاتك فأنت اكبر من اي كلمات يمكن ان تقال

فتقبل خالص تحياتي وشكري وتقديري لشخصكم الكريم

ومن الاكيد ان الوطن العربي يفخر بكل ثقة بوجودك فيه وانتماءك له

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

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

 

رمضـــان كـــريـــم

تم تعديل يونيو 25, 2013 بواسطه حمادة عمر

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

السلام عليكم

جزاك الله خيرا أخي الحبيب عبد الله على هذا العمل  المتقن كالعادة

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

 

نورت المنتدى اخي الحبيب ابو حنين

ونورت موضوعي بمروركم الكريم وكلماتكم الطيبة

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

 

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

 

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

[خالد الشاعر]

_{استاذى عبد الله باقشيير}

 

_{كل عام و انتم بخير}

 

_{ليس بجديد هذا الاتقان فى الماكرو}

 

_{جزاك الله كل خير}

 

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

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

السلام عليكم

الاستاذ القدير العلامة الخبير / عبدالله باقشير

بارك الله فيك

دمت لنا دائما بخير وسلام

وكل عام وانتم بخير بمناسبة هذه الايام العطرة

وبالطبع وبالتأكيد ان اسلوبك ابداعي وطريقتك من نوع خاص خبوريه خالصة

اكواد راائعة وافكار ممتازة ... ولا يوجد كلمات توصف ابداعاتك فنت اكبر من اي كلمات يمكن ان تقال

فتقبل خالص تحياتي وشكري وتقديري لشخصكم الكريم

ومن الاكيد ان الوطن العربي يفخر بكل ثقة بوجودك فيه وانتماءك له

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

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

 

رمضـــان كـــريـــم

 اخي الحبيب حمادة عمر...........حفظه الله

لا استطيع دائما ان اوفيك حقك بالرد على كلامكم الطيب

اكرمكم الله في الدنيا والآخرة

وجزاكم خيرا وبارك فيكم

 

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

 

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

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

_{استاذى عبد الله باقشيير}

 

_{كل عام و انتم بخير}

 

_{ليس بجديد هذا الاتقان فى الماكرو}

 

_{جزاك الله كل خير}

 

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

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

 

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

 

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

[شوقي ربيع]

السلام عليكم

الاستاد القدير عبد الله باقشير

زادك الله من علمه وادامك للمؤمنين مرجعا لكل تائه او مستفسرا في علم الاكسل

جزاك الله خيرا وكل عام وانت بالف خير ان شاء الله

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

السلام عليكم

الاستاد القدير عبد الله باقشير

زادك الله من علمه وادامك للمؤمنين مرجعا لكل تائه او مستفسرا في علم الاكسل

جزاك الله خيرا وكل عام وانت بالف خير ان شاء الله

 

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

 

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

 

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

[رجب جاويش]

أستاذى الحبيب / عبد الله باقشير

رائعة أخرى من روائعك

وكنز جديد من الكنوز الخبورية

سلمت يمينك

وحفظك الله معلما ومبدعا

تقبل أرق تحياتى وتقديرى

[saad abed]

السلام عليكم

الاستاد القدير عبد الله باقشير

زادك الله من علمه وادامك للمؤمنين مرجعا لكل تائه او مستفسرا في علم الاكسل

جزاك الله خيرا وكل عام وانت بالف خير ان شاء الله

اخى عبدالله باقشير

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

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

[خالد القدس]

السلام عليكم

العلامة أستاذ عبدالله باقشير

رائعة أخرى من معين روائعك الذي لا ينضب

جزاك الله خيرا ورزقك من حيث لا تحتسب

[مجدى يونس]

الاخ عبد الله

اضافة رائعة لاعمالك المتفوقه دائما

وكل عام وانت بخير بقرب شهر رمضان

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

أستاذى الحبيب / عبد الله باقشير

رائعة أخرى من روائعك

وكنز جديد من الكنوز الخبورية

سلمت يمينك

وحفظك الله معلما ومبدعا

تقبل أرق تحياتى وتقديرى

 

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

 

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

 

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

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

 

السلام عليكم

الاستاد القدير عبد الله باقشير

زادك الله من علمه وادامك للمؤمنين مرجعا لكل تائه او مستفسرا في علم الاكسل

جزاك الله خيرا وكل عام وانت بالف خير ان شاء الله

اخى عبدالله باقشير

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

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

 

 

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

 

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

 

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

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

السلام عليكم

العلامة أستاذ عبدالله باقشير

رائعة أخرى من معين روائعك الذي لا ينضب

جزاك الله خيرا ورزقك من حيث لا تحتسب

 

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

 

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

 

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

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

الاخ عبد الله

اضافة رائعة لاعمالك المتفوقه دائما

وكل عام وانت بخير بقرب شهر رمضان

 

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

 

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

 

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

[عادل ابوزيد]

استاذنا الفاضل عبد الله باقشير

انار الله قلبك وعقلك بنور العلم كما تنير عقولنا

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

استاذنا الفاضل عبد الله باقشير

انار الله قلبك وعقلك بنور العلم كما تنير عقولنا

 

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

 

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

 

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

[sarab1618]

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

[جمال عبد السميع]

أستاذى ( عبد الله بقشير )

شئ رائع ومثل يحتذى فى الأتقان والجمال

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

[أم عبد الله]

أستاذنا القدير العلاّمة / عبد الله باقشير

 

رائع جداً والأروع أن نتحكم في حجم الصورة . جزاك الله خيراً وزادك الله من فضله وعلمه. ورزقنا جميعاً الفردوس الأعلى من الجنة. أمين يا رب العالمين.كل عام وحضرتك بخير.

[ضاحي الغريب]

اخي الحبيب ومعلمنا القدير واستاذنا // عبدالله باقشير

دائما وابدا اعمالكم فيها الجديد والمفيد

وفيها مرجع متجدد للافكار والحيل وتطويعكم واظهاركم لجمال الاكسيل

بارك الله فيك وجزاك خيرا

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

تقبل تحياتي واحترامي

[حسن الحاوى]

السلام عليكم

الاستاذ القدير العلامة / عبدالله باقشير

بارك الله فيك

دمت لنا دائما بخير وسلام

مجهود عالى لا يصدر إلا من خبير

[مصطفى كمال متولى]