Stuck trying to resize image before inserting in comment

[Legacy 300089]

Hi,

I've been working on a macro to list files with hyperlinks from a selected folder and for images puts copy into a comment. Cobbled to together from various code snippets. However working with a large set of files I realised that images inserted into comments aren't compressed or resized based on the comment size.

So I'm looking for vba code to temporarily resize the image prior to inserting into the comment; ie before the .AddComment.Shape.Fill.UserPicture command.

Have spent hours trying to solve this with no luck. I think there are two potential solutions.

1) create a temporary Worksheet, add .Shapes, resize, delete worksheet (seems overkill and can't work out how to put a .Shape picutre into the .Comment)
2) create a temporary graphic file, resize, add via .UserPicture, delete (currently beyond my coding skills in vba excel)

Any other suggestions or help much appreciated!!!!

Full code with **** showing where resizing is needed:

Sub FolderFileNamesInColWithImgInComment()
' from GetFileNames macro from How to list files in a directory to worksheet in Excel?
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
Dim p As Shape ' temp picture container
' On Error GoTo ErrHandler

InitialFoldr$ = Application.ActiveWorkbook.Path '<<< mod to start in workbook folder
' InitialFoldr$ = "C:\" '<<< Startup folder to begin searching from

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$ & "\"
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
' mod to add images in comment, need to delete existing comment first
If Not (ActiveCell.Offset(xRow).Comment Is Nothing) Then ActiveCell.Offset(xRow).Comment.Delete
If FileIsImage(xDirect$ & xFname$) Then
With ActiveCell.Offset(xRow).AddComment
.Text xFname$
With .Shape

' ************* Bug to be fixed; need image resizing code here for large picture files inserted into comments

.Fill.UserPicture xDirect$ & xFname$
.ScaleHeight 3, msoFalse, msoScaleFromTopLeft
.ScaleWidth 3, msoFalse, msoScaleFromTopLeft
End With
End With
End If
xRow = xRow + 1
xFname$ = Dir

Loop
End If
End With
Exit Sub
ErrHandler:
MsgBox "A runtime error has occurred, please report the following:" _
& vbCrLf & vbCrLf _
& " Process : " & "FolderFileNamesInColWithImgInComment" _
& vbCrLf _
& " Error : " & Err & ": " & Error(Err), vbExclamation
Exit Sub
End Sub​

' function used in macro

Function FileIsImage(filename As String) As Boolean
' Excel VBA - If condition on image - Stack Overflow
' VBA changes to Pictures.Insert / Shape.AddPicture - Microsoft Community
' Test/Check if Shape Exists on Worksheet
Dim test As StdPicture
On Error GoTo ErrorHandler
Set test = LoadPicture(filename)
FileIsImage = True
Set test = Nothing ' 20140903 added to improve mem usage
Exit Function
ErrorHandler:
FileIsImage = False
Set test = Nothing ' 20140903 added to improve mem usage
On Error GoTo 0
End Function​

 

[mrmmickle1]

Have you had a look at this post:

POST ABOUT INSERTING PICTURES INTO COMMENTS

If you are having trouble re-sizing images you can do it like this:

[COLOR=#0000ff]With [/COLOR]ws.Pictures.Insert("C:\Your File Directory Here")
             .Height = 100
             .Width = 100
[COLOR=#0000ff]   End With[/COLOR]

 

[Andrew Poulsom]

For me in Excel 2010 a picture is automatically resized when inserted in a Comment. Doesn't that happen for you?

 

[Legacy 300089]

Hi,

Regarding 'picture automatically resized' yes on screen but I tested a few different .Scale Height & .ScaleWidth combinations and there is no change in the final excel file size. It appears that the original image is stored into the comment irrespective of scaling. It's ok for a couple of images, but you quickly get a mem overflow error with many images stored in comments.

Maybe there is a switch to compress (as with normally inserted images) but I haven't found it for images stored in comments.

Will try setting the comment with a fixed height/width and see if that works.

usage note: the code is used to create excel reports in which we take photos during inspections, then record comments/issues against each photo. Having the image in the comment is a nice feature on top of the hyperlink. Very useful when dealing with 100+ photos which may be taken over a couple of days.

Bonus is that when running the script starting on an Excel Table the table auto-expands - which means any setup data validation cells, etc, maintain their formatting - which is nice.

 

[Andrew Poulsom]

Compressing and Resizing are not the same thing. As far as I know there is no way to programmatically Compress a Picture in Excel.

 

[mrmmickle1]

akarich73,

I agree this is a nice feature. I did not know it existed until the post.

------> In regards to compressing your pictures. Why don't you compress them before you insert them into comments?

 

[Legacy 300089]

Could have compressed separately, but it didn't fit the optimal solution as we want the original pics hyperlinked.

Anyway, here is the solution. Full credit to the original creators of this code referenced in comments. I have tweaked to pass dir, file names and an optional scale factor; and return to the original active cell.

Tested on Excel 2010.

FileDelete function to remove temp file after scaling.

ps. Looks like this is implemented in Excel 2013 with Shapes.AddPicture2 method.

Sub test()
Call scalePicture("C:\SomeDir\", "SomePicture.jpg", "temp.jpg")
MsgBox "pause"
Call DeleteFile("C:\SomeDir\temp.jpg")
End Sub

Private Sub scalePicture(PictureDir As String, PictureFile As String, PictureFileOut As String, Optional PictureScale As Integer = 20)
     ' ref http://www.ozgrid.com/forum/showthread.php?t=145666
     ' ref for delete file http://stackoverflow.com/questions/67835/deleting-a-file-in-vba
    Dim chtDummyChart As Excel.ChartObject
    Dim strExportFilename As String
    Dim intImagePercent As Integer
    Dim sngScaleFactor As Single
    Dim tmpSheet As String ' temp values for resetting active cell back to original cell
    Dim tmpRange As String
        
    intImagePercent = PictureScale ' maximum value here of 100 - ie full-size default is 20
    sngScaleFactor = 100 / intImagePercent
     
    tmpSheet = ActiveSheet.Name
    tmpRange = ActiveCell.Address
     
    With ActiveSheet
        .Range("A1").Select
        .Pictures.Insert (PictureDir & PictureFile)
        .Pictures.Select
        .Pictures.Copy
         
         'By altering the value of the the width & height properties to smaller values -> rescales image!
         'remember to use the same intScaleFactor for both .Pictures(1).width and _
        .Pictures(1).height Or the image ratio will be distorted
         
        Set chtDummyChart = .ChartObjects.Add(0, 0, ((.Pictures(1).Width + 1) / sngScaleFactor), _
        ((.Pictures(1).Height + 1) / sngScaleFactor))
         
    End With
     
    strExportFilename = PictureDir & PictureFileOut
     
    With chtDummyChart
        .Chart.Paste
        .Chart.Export strExportFilename, "jpg"
        .Delete
    End With
     
    With ActiveSheet
        .Range("A1").Select
        .Pictures.Delete
    End With
     
    Worksheets(tmpSheet).Select
    Range(tmpRange).Select
     
    Set chtDummyChart = Nothing
       
   ' Unload Me
     
End Sub

Sub DeleteFile(ByVal FileToDelete As String)
   If FileExists(FileToDelete) Then
   SetAttr FileToDelete, vbNormal
      Kill FileToDelete
   End If
End Sub

' functions used in macros

Function FileExists(ByVal FileToTest As String) As Boolean
   FileExists = (Dir(FileToTest) <> "")
End Function

 

[mrmmickle1]

akarich73,

Thanks for sharing the solution. Glad you got your issue resolved.