Adding Hyperlinks to pictures in Excel !

[MAlhash]

Hello everyone!

I am trying to insert hyperlinks for the photo, which is resemble attachment, but I was not success.
I have two kind of photos which will appears regarding a condition. I will be clearer. If the user attached the document, which would return the value "1" a picture which is name (ATTACH) will appear and if there is no attachment the picture with (UNATTACH) name will appear. All this work for me perfectly. my issue now is that I want to add the hyperlink to this picture "ATTACH", so when I click the picture, the document will open for me. I have arranged the hyperlinks path in a different cell. is it possible to merge the pictures with hyperlinks.

Here is the modified code:

Dim c As Range
Dim picname As String, aCell As String

Application.ScreenUpdating = False

For Each c In Range("AM95:AM98, AM104:AM107, AM113:AM117, AM123:AM126, AM132:AM135") ' its reading if there is attachment it will return 1.
aCell = c.Address(0, 0)
Select Case True
Case IsEmpty(c.Value)
MsgBox "No value in cell: " & aCell
Exit Sub
Case Not IsNumeric(c.Value)
MsgBox "Value is not numeric in cell: " & aCell
Exit Sub
Case c.Value < 1#
picname = "C:\Users\MAlhashlamoun\Pictures\UNATTACH" & ".png"

Case c.Value2 >= 1#
picname = "C:\Users\MAlhashlamoun\Pictures\ATTACH" & ".png"

End Select

If Dir(picname) = "" Then
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
End If

'Before inserting the new picture, delete the old one.
On Error Resume Next
ActiveSheet.Pictures("name_" & aCell).Delete
On Error GoTo 0

ActiveSheet.Pictures.Insert(picname).Select
With Selection
.Name = "name_" & aCell 'Name the image with any name.
.Left = Range("R" & c.Row).Left
.Top = Range("R" & c.Row).Top
.ShapeRange.IncrementLeft 26
.ShapeRange.IncrementTop 5
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 20#
.ShapeRange.Width = 20#
.ShapeRange.Rotation = 0#
End With
Next
Application.ScreenUpdating = True
End Sub

the hyper link path is showing in this way in the cells:

C:\Users\MAlhashlamoun\Desktop\New Microsoft Excel Worksheet.xlsx

C:\Users\MAlhashlamoun\Downloads\task-checklist.xlsx

C:\Users\MAlhashlamoun\Desktop\TO-DO-LIST-Latest .xlsm

C:\Users\MAlhashlamoun\Downloads\task-checklist.xlsx

C:\Users\MAlhashlamoun\Downloads\You_Exec_-_2023_Calender_Free.xlsx

C:\Users\MAlhashlamoun\Downloads\You_Exec_-_Issue_Tracker_Free.xlsx

C:\Users\MAlhashlamoun\Desktop\TO-DO-LIST-Latest .xlsm

C:\Users\MAlhashlamoun\Downloads\project-task-list-template.xlsx

Please help me when I press on the attachment picture it should open for me the attachment directly.

Thank you!

 

[MAlhash]

Hello!

I have tried my best to add the hyperlinks to pictures put I was not success.

I have add this line, but i was not success.

With ActiveSheet
    .Hyperlinks.Add Anchor:=.Shapes(pcname.Name), Address:="", SubAddress:="ADULT EMERGENCY!AG87:AG100"
    End With

Sub Oval28_Click()
    

  Dim c As Range
  Dim picname As String, aCell As String
 
  Application.ScreenUpdating = False
 
  For Each c In Range("AM95:AM98, AM104:AM107, AM113:AM117, AM123:AM126, AM132:AM135")
    aCell = c.Address(0, 0)
    Select Case True
      Case IsEmpty(c.Value)
        MsgBox "No value in cell: " & aCell
        Exit Sub
      Case Not IsNumeric(c.Value)
        MsgBox "Value is not numeric in cell: " & aCell
        Exit Sub
      Case c.Value < 1#
        picname = "C:\Users\MAlhashlamoun\Pictures\UNATTACH" & ".png"
        
      Case c.Value2 >= 1#
        picname = "C:\Users\MAlhashlamoun\Pictures\ATTACH" & ".png"
        
    End Select
   
    If Dir(picname) = "" Then
      MsgBox "Unable to Find Photo" 'Shows message box if picture not found
      Exit Sub
    End If
   
    'Before inserting the new picture, delete the old one.
    On Error Resume Next
      ActiveSheet.Pictures("name_" & aCell).Delete
    On Error GoTo 0
   
    ActiveSheet.Pictures.Insert(picname).Select
    With Selection
      .Name = "name_" & aCell                  'Name the image with any name.
      .Left = Range("R" & c.Row).Left
      .Top = Range("R" & c.Row).Top
      .ShapeRange.IncrementLeft 26
      .ShapeRange.IncrementTop 5
      .ShapeRange.LockAspectRatio = msoFalse
      .ShapeRange.Height = 20#
      .ShapeRange.Width = 20#
      .ShapeRange.Rotation = 0#
    End With
    With ActiveSheet
    .Hyperlinks.Add Anchor:=.Shapes(pcname.Name), Address:="", SubAddress:="ADULT EMERGENCY!AG87:AG100" ' An error object required ???
    End With
    
  Next
  Application.ScreenUpdating = True

please I need help.

Thank you

 

[MAlhash]

so far, i was able to attach the first photo with the first hyperlink path

Sub HYPERLINK_Click()
Dim shp As Shape
Dim sht As Worksheet
Dim ShapeName As String
Dim LinkAddress As String
Dim LinkDescription As String


Dim WB_P As Variant
Set WB_P = Worksheets("ADULT EMERGENCY").Range("AP95")


ShapeName = "name_AM95"

LinkDescription = "OPEN ATTACHMENT"

'Loop Through each worksheet in Workbook
  For Each sht In ActiveWorkbook.Worksheets
    'Look for specified shape
      On Error Resume Next
        Set shp = sht.Shapes(ShapeName)
      On Error GoTo 0
    'If specified shape is found, add hyperlink
      If Not shp Is Nothing And Range("O95").Text = "COMPLETED" Then
        sht.Hyperlinks.Add _
          Anchor:=shp, _
          Address:=WB_P, _
          ScreenTip:=LinkDescription
         
      End If
   
    'Reset shp variable
      Set shp = Nothing
  Next sht
End Sub

how can I make them as a range? meaning, :"AP95"AP98" for hyperlinke and pictures ranges from R95:R98

thank you