Results 1 to 7 of 7
  1. #1
    New Lounger
    Join Date
    Dec 2009
    Location
    s.a
    Posts
    3
    Thanks
    2
    Thanked 0 Times in 0 Posts

    Add picture to comment

    I got the following code from Hansv a long while back to insert pictures as comments for selected cell. I have tried to modify it to make it work without user intervention. ie-- I have a list of items in say column A and a folder eg c:\pictures which has a list of matching pictures with similar names in addition to extension .tif or .jpg or .bmp -match at least first 6 letters or numbers is required. I just want to select the items in column A into which I require comments with pictures and then run the macro.
    Many thanx
    Smbs



    Sub AddPictures()
    Dim i As Long
    Dim cmt As Comment
    Dim oCell As Range
    Dim varFile As Variant
    For i = ActiveSheet.Comments.Count To 1 Step -1
    Set cmt = ActiveSheet.Comments(i)
    If Not Intersect(cmt.Parent, Selection) Is Nothing Then
    cmt.Delete
    End If
    Next i
    For Each oCell In Selection.Cells
    varFile = Application.GetOpenFilename("Images,*.bmp;*.gif;*. jpg;*.png")
    If varFile = False Then
    ' skip this cell
    Else
    With oCell.AddComment
    .Visible = False
    .Shape.Fill.UserPicture PictureFile:=varFile
    End With
    End If
    Next oCell
    Set cmt = Nothing
    Set oCell = Nothing
    End Sub

  2. #2
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,820
    Thanks
    133
    Thanked 481 Times in 458 Posts
    Hi

    I amended the code to 'fetch' the name of the picture file from the adjacent column.
    The picture is added as a comment to the corresponding cell on the left.
    The adjacent column, containing the full path and filename for the picture, can be hidden if required.

    Code:
    Sub AddPictures()
    
    Dim i As Long
    Dim cmt As Comment
    Dim oCell As Range
    Dim varFile As Variant
    
    'First, remove any existing comments from selected range..
    For i = ActiveSheet.Comments.Count To 1 Step -1
    Set cmt = ActiveSheet.Comments(i)
    If Not Intersect(cmt.Parent, Selection) Is Nothing Then
    cmt.Delete
    End If
    Next i
    
    For Each oCell In Selection.Cells       'loop through all cells in selected range
    varFile = oCell.Offset(0, 1)            'fetch filename from adjacent cell
    If Dir(varFile) = "" Then               'filename is missing
    ' skip this cell
    Else                                    'otherwise..
    With oCell.AddComment
    .Visible = False
    .Shape.Fill.UserPicture PictureFile:=varFile
    End With
    End If
    Next oCell                              'process next cell in selected range
    
    Set cmt = Nothing
    Set oCell = Nothing
    End Sub
    zeddy

  3. #3
    New Lounger
    Join Date
    Dec 2009
    Location
    s.a
    Posts
    3
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Quote Originally Posted by zeddy View Post
    Hi

    I amended the code to 'fetch' the name of the picture file from the adjacent column.
    The picture is added as a comment to the corresponding cell on the left.
    The adjacent column, containing the full path and filename for the picture, can be hidden if required.

    Code:
    Sub AddPictures()
    
    Dim i As Long
    Dim cmt As Comment
    Dim oCell As Range
    Dim varFile As Variant
    
    'First, remove any existing comments from selected range..
    For i = ActiveSheet.Comments.Count To 1 Step -1
    Set cmt = ActiveSheet.Comments(i)
    If Not Intersect(cmt.Parent, Selection) Is Nothing Then
    cmt.Delete
    End If
    Next i
    
    For Each oCell In Selection.Cells       'loop through all cells in selected range
    varFile = oCell.Offset(0, 1)            'fetch filename from adjacent cell
    If Dir(varFile) = "" Then               'filename is missing
    ' skip this cell
    Else                                    'otherwise..
    With oCell.AddComment
    .Visible = False
    .Shape.Fill.UserPicture PictureFile:=varFile
    End With
    End If
    Next oCell                              'process next cell in selected range
    
    Set cmt = Nothing
    Set oCell = Nothing
    End Sub
    zeddy
    Hi there
    Many thanx for your quick solution-- it certainly makes it easier than the original code however I would still have to paste the exact path and name of each picture file into the spreadsheet---I would prefer only having to supply the macro with the folder name where the pictures can be found. Some sort of lookup table maybe?
    Anyway many thanx your solution really helps
    Smbs

  4. #4
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,820
    Thanks
    133
    Thanked 481 Times in 458 Posts
    Hi Smbs

    ..I'll post a proper solution for you tomorrow - It's happy hour here, and I have an appointment with destiny.

    zeddy

  5. The Following User Says Thank You to zeddy For This Useful Post:

    smbs1 (2013-06-26)

  6. #5
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,631
    Thanks
    115
    Thanked 645 Times in 589 Posts
    Smbs,

    Here is another take on what you want to do. This will take the values that are in the selected cells of column A and look for an image file with the same name with an extension of either .jpg, .bmp, .tif. It will then place the image in the comment for that cell. Note: The path must have the trailing backslash (\) if you should need to change it.

    comment.jpg

    HTH,
    Maud

    Code:
    Sub PicsInComments()
    Dim cell As Range
    Dim path As String
    
    path = "C:\Pictures\"
    
    For Each cell In Selection.Cells
        If Not (cell.Comment Is Nothing) Then cell.Comment.Delete
        If Dir(path & "\" & cell.Value & ".jpg") <> "" Then cell.AddComment.Shape.Fill.UserPicture PictureFile:=path & cell.Value & ".jpg"
        If Dir(path & "\" & cell.Value & ".bmp") <> "" Then cell.AddComment.Shape.Fill.UserPicture PictureFile:=path & cell.Value & ".bmp"
        If Dir(path & "\" & cell.Value & ".tif") <> "" Then cell.AddComment.Shape.Fill.UserPicture PictureFile:=path & cell.Value & ".tif"
    Next cell
    End Sub
    Last edited by Maudibe; 2013-06-26 at 01:04.

  7. The Following User Says Thank You to Maudibe For This Useful Post:

    smbs1 (2013-06-26)

  8. #6
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,820
    Thanks
    133
    Thanked 481 Times in 458 Posts
    Hi

    Maudibe's solution can be easily adapted to include other picture file formats e.g. .gif and .png files.

    My version below will take the first 6 characters of each cell entry, then searches for any matching file in the specified picture folder. My solution assumes that all the files in the specified folder are picture files, so doesn't bother checking the file suffix.

    Code:
    Sub refreshPicsInComments()
    
    Dim c As Range
    Dim cmt As Comment
    Dim zFolder As String
        
    zFolder = "c:\pictures\"                '<-define folder containing picture files
    
    On Error Resume Next                    'ignore any empty cells, without comments etc
    
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    For Each c In Selection.Cells           'loop through all selected cells
    Set cmt = c.Comment                     'define shortcut
    cmt.Delete                              'remove any existing comment
    If c.Value <> "" Then                   'cell contains an item description
    'take first 6 chars of cell entry for matching picture file..
    zPrefix = Left(c.Value, 6) & "*.*"      'e.g. "abc123*.*" ;6=matches first 6 chars
    zFetch = zFolder & zPrefix              'e.g. "c:\pictures\abc123*.*"
    zFile = Dir(zFetch)                     'e.g. "abc123456aaa.jpg"; .bmp; .png; .gif
    If zFile <> "" Then                     'file exists in picture folder
    With c.AddComment                       'define shortcut
    .Visible = False
    .Shape.Fill.UserPicture PictureFile:=zFolder & zFile
    End With
    End If
    End If
    Next c                                  'process next cell in selected range
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    On Error GoTo 0                         'reset error trap
    
    End Sub
    zeddy

  9. #7
    New Lounger
    Join Date
    Dec 2009
    Location
    s.a
    Posts
    3
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Thanx Maud and Zeddy for your coding --I certainly learnt a lot from these examples!!!
    Smbs

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •