نجوم المشاركات

السلام عليكم ورحمة الله وبركاته جمعة مباركة دالة لاضافة صور الى نموذج معين من فولدر المطلوب فيها اسم الصورة واسم الشكل التلقائي الذي تريد اظهار الصورة فيه ملاحظة مهمة : عند تعيين الخلية اللي فيها اسم الصورة يجب ان يكون ملحوق باسم الورقة مثلا =kh_AddPicture(Sheet1!H2;"myimg1") كود الدالة : Option Explicit Option Compare Text '''اسم مجلد الصور Private Const kh_pic As String = "MyImeg" Function kh_AddPicture(MyRng As Range, iName As String) Dim MyFile As String On Error GoTo 1 MyRng.Worksheet.Shapes(iName).Fill.Solid MyFile = ThisWorkbook.Path & "\" & kh_pic & "\" MyFile = MyFile & "\" & CStr(MyRng) & ".jpg" If Not Dir(MyFile, vbDirectory) = vbNullString Then MyRng.Worksheet.Shapes(iName).Fill.UserPicture MyFile End If 1 kh_AddPicture = "" End Function هو طلب لاحدهم وجعلته هنا لتعم الفائدة المرفق اكسل 2003 اكسل 2007 دالة لاضافة صور الى نموذج معين من فولدر.rar =================================================== ملحوظة ارجوا من الذين حملوا المرفق هذا يغيروا كود الدالة الى الكود المعدل ادناه =================================================== تم تعديل الدالة لتشمل صيغ الصور التي تريدها كود الدالة الجديد Option Explicit Option Compare Text '============================================= '============================================= ' اسم مجلد الصور ' اذا كان مجلد الصور في نفس مجلد ملف الاكسل ' اكتب اسمه فقط ' والا اكتب المسار كاملا ' "D:\MyDocument\MyFunction\photo" Private Const kh_pic As String = "MyImeg" '============================================= ' امكانية تحرير اي نوع من الصور لديك ادناه Private Const MyTyp As String = ".jpg,.bmp,.gif,.png,.tif" '============================================= '============================================= Function kh_AddPicture(MyRng As Range, iName As String) Dim Tp Dim MyShap As Shape Dim MyFile As String, MyPath As String Dim ibo As Boolean '----------------------------------------- On Error Resume Next Set MyShap = MyRng.Worksheet.Shapes(iName) If iName = "" Or Err Then Err.Clear: GoTo 1 '----------------------------------------- MyShap.Fill.Solid If Not InStr(kh_pic, ":") Then MyPath = ThisWorkbook.Path MyFile = MyPath & "\" & kh_pic & "\" & CStr(MyRng) '----------------------------------------- For Each Tp In Split(MyTyp, ",") If Not Dir(MyFile & Trim(Tp), vbDirectory) = vbNullString Then MyShap.Fill.UserPicture MyFile & Trim(Tp) ibo = True Exit For End If Next '----------------------------------------- 1: Set MyShap = Nothing kh_AddPicture = ibo End Function المرفق اكسل 2003/2007 دالة لاضافة صور من مجلد الى شكل تلقائي.rar