Inserting pictures w/ filter, w/out using comments

[zera]

I'm trying to create a spreadsheet that uses filters and contains images. The floating images don't work properly when the filter is on. I've tried inserting the picture as a comment, but it is really slow because there are going to be approximately 8000 pictures when sheet is finished. Is there a way to anchor the pictures so that they are within or locked onto a cell?
Any help would be greatly appreciated.

Thanks,
Zera

 

[BrianB]

An interesting exercise. I wonder if a file containing 8000 pictures would be usable, let alone stable. Once the filename is available there are ways of showing individual pictures - eg. doubleclick row to open a userform ... which gets the file etc. Anyway, here is something to play with.

There is a macro to get file names included.

The problem with using Autofilter is solved (?) by fitting the picture to a cell and formatting it to move & size with the cell. Can then experiment with row height too.

'=============================================================================
'- PICTURES TO COMMENTS & PICTURES TO CELLS
'- This is meant mainly as an experiment
'- An error is generated if a *Comment* already exists - so I delete existing ones first
'- No error with adding pictures (they cover existing) but delete existing too.
'=============================================================================
'- This macro assumes a simple table with headings in Row 1
'- All picture files in the same folder. Picture file names in column A.
'-                 (There is a macro at the bottom to get the file names)
'- Column B : Makes a Comment. Inserts picture.
'- Column C : Inserts picture and re-sizes it to fit the cell.
'-----------------------------------------------------------------------------
'- Brian Baulsom September 2009
'=============================================================================
Sub PICTURES_TO_COMMENTS()
    Dim PictureFolder As String
    Dim MyPictureFile As String
    Dim MyCell As Range
    Dim MyComment As Comment
    Dim ToRow As Long
    Dim LastRow As Long
    Dim ws As Worksheet
    '-------------------------------------------------------------------------
    Set ws = ActiveSheet
    LastRow = ws.Range("A65536").End(xlUp).Row
    PictureFolder = "F:\Test\Pictures\"
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    '=========================================================================
    '- ** CLEAR COMMENTS **
    For Each c In ws.Comments: c.Delete: Next
    '=========================================================================
    '- ** CLEAR PICTURES ** (error if none there)
    On Error Resume Next
    ws.Pictures.ShapeRange.Delete
    On Error GoTo 0
    '=========================================================================
    With ws
        '- MAIN LOOP
        For ToRow = 2 To LastRow
            Application.StatusBar = "  Processing " & ToRow & "\" & LastRow
            MyPictureFile = PictureFolder & Cells(ToRow, 1).Value
            Set MyCell = .Cells(ToRow, 2) ' cell for comment
            '=================================================================
            '- ADD COMMENT
            '=================================================================
            MyCell.AddComment
            Set MyComment = MyCell.Comment
            With MyComment
                .Shape.Fill.UserPicture MyPictureFile
                .Visible = False
            End With
            '=================================================================
            '- PICTURE TO CELL
            '- NB : it is possible to have several pictures in a cell
            '- (no error is generated)  (only 1 will be visible)
            '=================================================================
            .Pictures.Insert(MyPictureFile).Select
            '-----------------------------------------------------------------
            '- FORMAT THE PICTURE TO FIT THE CELL
            With MyCell.Offset(0, 1)
                Selection.Top = .Top
                Selection.Left = .Left
                Selection.Width = .Width
                Selection.Height = .Height
                'Selection.ShapeRange.PictureFormat.Brightness = 0.5 ' various formats available
                Selection.Placement = xlMoveAndSize ' move and size with cells
                Selection.PrintObject = True
                '-
                .Select   ' change focus (selection) from picture to cell
            End With
        Next
        '--------------------------------------------------------------------
    End With
    '------------------------------------------------------------------------
    '- FINISH
    Application.Goto ws.Range("A1"), Scroll:=True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox ("Done")
    Application.StatusBar = False
End Sub
'=============================================================================
 
'=============================================================================
'- GET PICTURE FILE NAMES FROM FOLDER TO SHEET
'=============================================================================
Sub GET_PICTURE_NAMES()
    Dim MyFolder As String
    Dim MyFile As String
    Dim ToRow As Long
    '-------------------------------------------------------------------------
    MyFolder = "F:\Test\Pictures\"
    MyFile = Dir(MyFolder & "*.*")   ' all files
    ToRow = 2
    '-------------------------------------------------------------------------
    '- LOOP through files in folder
    Do While MyFile <> ""
        Cells(ToRow, 1).Value = MyFile  ' name to sheet
        ToRow = ToRow + 1
        MyFile = Dir    ' Get next file
    Loop
    '--------------------------------------------------------------------------
End Sub
'==============================================================================

 

[zera]

I'm recieving runtime error1004 at the line below "end with". Any help would be appreciated.

Sub test()
'
' test Macro
' Macro recorded 12/15/2009 by user
'
' Keyboard Shortcut: Ctrl+q
'****************************************************************************************************************
'Macro will be relative to starting cell and will move down 1 cell after each cycle til there is no cell contents
'Ideally the cell contents text will be inserted into the directory specifying user picture in place of XXXX and if there is no picture found it will continue to the next sequence.
'Currently this is not set to operate
'****************************************************************************************************************
ActiveCell.AddComment
ActiveCell.Comment.Visible = False
ActiveCell.Comment.Text Text:=""
With Selection.Font
.Name = "Tahoma"
.FontStyle = "Bold"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.BackColor.SchemeColor = 80
Selection.ShapeRange.Fill.UserPicture _
"C:\Documents and Settings\user\My Documents\My Pictures\XXXX.jpg"
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 55.5
Selection.ShapeRange.Width = 360#
ActiveCell.Offset(1, 0).Range("A1").Select
End Sub

 

[zera]

Just to update, I just noticed the title of this thread. Originally looking to NOT use comments, but I'm currently looking to change to using comments, since sized and moved with cell causes the images to stack ontop of one another.

Sorry for the confusion

 

[zera]

This is what I currently have, it inserts the comments and proceeds to the next cell. Unfortunately, the comment doesn't contain a picture. I don't recieve an error message either. Any help would be appreciated. Just wondering, do I need to and in for the file extension? Default for pic comment is "all files" under the extension so it shouldn't be needed correct?

********************************************************

Sub InsertComment()
Dim rngList As Range
Dim c As Range
Dim cmt As Comment
Dim strPic As String

On Error Resume Next
Set rngList = Range("A1785:A1884")
strPic = "C:\thomasn\Profile Book\Drawing Images\8200\"
For Each c In rngList
With c.Offset(0, 0)
Set cmt = c.Comment
If cmt Is Nothing Then
Set cmt = .AddComment
End If
With cmt
.Text Text:=""
.Shape.Fill.UserPicture strPic & c.Value
.Visible = False
End With
End With
Next c
End Sub