'=============================================================================
'- 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
'==============================================================================