ithad2020

السادة الكرام بداية اشكر كل من ساهم في تطوير وزياده المعرفة لدينا بالاكسل بهذا الجروب العظيم ولذا فقد كان لدي مشكلة ووجدت حلها بحمد الله ولكن في احد المنتديات الاجنبية واحببت ان انقلها هنا للاستفادة الا وهي : كان لدي ملف يحتوي على عدد 200 موظف وكان كل اسم مربوط بارتباط تشعبي عند الضغط عليه تظهر صورة الموظف ولكن الادارة قامت بطلب ان تظهر جميع الصور بجانب الاسم دون الحاجة للضغط على ارتباط تشعبي وهو ما كان في البداية من الصعوبة ان اقوم بعمل ادراج لكل صورة والبحث عن كل اسم . ووجدت هذا الكود والذي يتم استخدامه بواسطة لغة VBA والطريقة كالتالى :- نقوم بالضغط على alt + f11 فيقوم بفتح شاشة VBA من قائمة insert نختار module فيقوم بفتح شاشة لكتابة الكود نقوم باخد الكود التالى نسخ ولصق بها '****************************** '* ConvertHLinksToCellPics * '* Programmer: Ron Coderre * '* Last Update: 06-Apr-2009 * '****************************** Sub ConvertHLinksToCellPics() Dim cCell As Range Dim rngSelection As Range Dim strHLink As String Dim cComment As Comment Dim strPicFileName As String Dim iNewHgt As Integer Dim iNewWidth As Integer For Each cCell In Selection If cCell.Hyperlinks.Count > 0 Then 'The cell contains a hyperlink With cCell 'Store the hyperlink target strHLink = .Hyperlinks(1).Address If strHLink <> "" Then 'Build a picture shape If InStrRev(strHLink, "/") > 0 Then strPicFileName = Mid(strHLink, InStrRev(strHLink, "/") + 1) Else strPicFileName = Mid(strHLink, InStrRev(strHLink, "\") + 1) End If strPicFileName = "pic_" & cCell.Row & cCell.Column InsertPicFromFile _ strFileLoc:=strHLink, _ rDestCells:=cCell, _ blnFitInDestHeight:=True, _ strPicName:=strPicFileName With ActiveSheet.Shapes(strPicFileName) .LockAspectRatio = msoFalse .Height = cCell.Height .Width = cCell.Width End With cCell.Hyperlinks.Delete End If End With End If Next cCell End Sub '****************************** '* InserPicFromFile * '* Programmer: Ron Coderre * '* Last Update: 20-SEP-2007 * '****************************** Sub InsertPicFromFile( _ strFileLoc As String, _ rDestCells As Range, _ blnFitInDestHeight As Boolean, _ strPicName As String) Dim oNewPic As Shape Dim shtWS As Worksheet Set shtWS = rDestCells.Parent On Error Resume Next 'Delete the named picture (if it already exists) shtWS.Shapes(strPicName).Delete On Error Resume Next With rDestCells 'Create the new picture '(arbitrarily sized as a square that is the height of the rDestCells) Set oNewPic = shtWS.Shapes.AddPicture( _ Filename:=strFileLoc, _ LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, _ Left:=.Left + 1, Top:=.Top + 1, Width:=.Height - 1, Height:=.Height - 1) 'Maintain original aspect ratio and set to full size oNewPic.LockAspectRatio = msoTrue oNewPic.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue oNewPic.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue If blnFitInDestHeight = True Then 'Resize the picture to fit in the destination cells oNewPic.Height = .Height - 1 End If 'Assign the desired name to the picture oNewPic.Name = strPicName End With 'rCellDest End Sub ومن ثم نقوم بالضغط على f5 لتفعيل الكود ومن ثم اغلاق الشاشة سنلاحظ انه تم اظهار جميع الصور بجانب اسماء العاملين دون الحاجة لادراجها منفرده . ولضبط حجم جميع الصور اختار اي صورة ومن ثم اضغط ctrl + a ستجد تم تحديد جميع الصور ومن ثم كليك يمين - خصائص الصورة وتعديل الطول والعرض فسيتم ظبطها لجميع الصور وفي حالة الرغبة بربط الصورة بالخلية ايضا اضغط على الصور كليك يمين ومن ثم خصائص الصورة ومن ثم خصائص وقم بتحديد خيار ربط الصورة بالخلية اتمنى اكون افدتكم والله الموفق .

من افضل المواضيع التي لبت كل طلباتي واحتياجاتي بجد ابدعتم ووفيتم بارك الله فيكم وجعله في ميزان حسناتكم واكثر من علمكم وافادتكم للاخرين جزاكم الله كل خير وسجلت عضويتي مخصوص لاتمكن من شكركم الشكر العظيم على هذا المجهود الجبار في الملف بارك الله فيكم ^_^