简体   繁体   中英

Insert image filepath into cell as hyperlink and image itself into comment

I'm trying to create an Excel macro that takes a picture or pictures as input. It then adds the image as a comment to the selected cell. I have this much complete.

What I want to do next is take the path of the picture and insert it as a hyperlink in the cell.
eg
Image - \\server\\share\\test\\image.jpg
Insert image as comment
Insert image path as text

Here is my code so far:

Sub ImageLinkComment()

Dim Pict() As Variant
Dim ImgFileFormat As String
Dim PictCell As Range
Dim lLoop As Long
Dim sShape As Picture

ActiveSheet.Protect False, False, False, False, False
ImgFileFormat = "All Picture Files(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bpm;*.gif;*.gfa;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.cgm;*.eps;*.pct;*.pict;*.wpg;*.pcd;*.pcx;*.cdr;*.fpx;*.mix), *.bmp"

 'Note you can load in any nearly file format
Pict = Application.GetOpenFilename(ImgFileFormat, MultiSelect:=True)
If Not IsArray(Pict) Then
    Debug.Print "No files selected."
    Exit Sub
End If

Set PictCell = Selection.Cells(1)
For lLoop = LBound(Pict) To UBound(Pict)

    PictCell.AddComment
    PictCell.Comment.Visible = False
    PictCell.Comment.Shape.Height = 215
    PictCell.Comment.Shape.Width = 195
    PictCell.Comment.Shape.Fill.UserPicture Pict(lLoop)

    Set PictCell = PictCell.Offset(1)
Next lLoop

End Sub

So, after some playing around I got this code to work for one image at a time. It's not the prettiest but it's functional. I assigned it to a button within my excel sheet, along with another button to clear the contents of a cell.

Sub InsertImagesAsComments()

Dim Pict
Dim ImgFileFormat As String
Dim PictCell As Range
Dim lLoop As Long
Dim sShape As Picture

ActiveSheet.Protect False, False, False, False, False
ImgFileFormat = "All Picture Files(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bpm;*.gif;*.gfa;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.cgm;*.eps;*.pct;*.pict;*.wpg;*.pcd;*.pcx;*.cdr;*.fpx;*.mix), *.bmp"

 'Note you can load in any nearly file format

Pict = Application.GetOpenFilename(ImgFileFormat, MultiSelect:=False)
If Pict = False Then Exit Sub

Set PictCell = Selection.Cells(1)

PictCell.AddComment
PictCell.Comment.Visible = False
PictCell.Comment.Shape.Height = 215
PictCell.Comment.Shape.Width = 195
PictCell.Comment.Shape.Fill.UserPicture Pict
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
    Pict, _
    TextToDisplay:= _
    Pict

End Sub

Purpose of this code is to fetch the images from the file path and place them as comment in the adjacent row.

Assummning there are 5 file path in A1 to A5, the code asks to select the range, and then it puts the image as comment in B1 to B5.

Hope it helps someone

Sub Filepath_to_Picture_As_Comments()

Dim cmt As Comment
Dim rng As Range
Dim Workrng As Range
Dim Height As Long
Dim Width As Long

On Error Resume Next

xTitleId = "Select range of File paths"
Set Workrng = Application.Selection
Set Workrng = Application.InputBox("File paths", xTitleId, Workrng.Address, Type:=8)

Height = Application.InputBox("Add text", "Height of comment", "400", Type:=2)
Width = Application.InputBox("Add text", "Width of comment", "500", Type:=2)

For Each rng In Workrng
  With rng.Offset(0, 1)
    Set cmt = rng.Comment
    If cmt Is Nothing Then
      Set cmt = .AddComment
    End If
    With cmt
      .Text Text:=""
      .Shape.Fill.UserPicture rng.Value
      .Visible = False
    End With
  End With
Next rng

For Each cmt In Application.ActiveSheet.Comments
    cmt.Shape.Width = Width
    cmt.Shape.Height = Height
Next cmt

End Sub

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM