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

[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 ستجد تم تحديد جميع الصور 

ومن ثم كليك يمين - خصائص الصورة وتعديل الطول والعرض فسيتم ظبطها لجميع الصور 

وفي حالة الرغبة بربط الصورة بالخلية ايضا اضغط على الصور كليك يمين ومن ثم خصائص الصورة ومن ثم خصائص وقم بتحديد خيار ربط الصورة بالخلية 

اتمنى اكون افدتكم والله الموفق . 

[أبوعيد]

ممكن ترفق ملف كمثال على الفكرة ؟ يعني تضع فيه أن صور 

إرسال الملف سيجعل الفكرة مفهومة أكثر

 

تقبل تحياتي