Adding Hyperlinks to pictures in Excel !

MAlhash

New Member
Joined
Mar 26, 2023
Messages
41
Office Version
  1. 365
Platform
  1. Windows
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:


VBA 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!
 

Attachments

  • attach.png
    attach.png
    112.9 KB · Views: 9

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
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.

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


VBA Code:
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
 
Upvote 0
so far, i was able to attach the first photo with the first hyperlink path

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,214
Messages
6,170,772
Members
452,353
Latest member
strainu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top