Stuck trying to resize image before inserting into comment

[akarich73]

Hi,

I've been working on a macro to list files with hyperlinks from a selected folder and with images puts a 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 [url]http://www.extendoffice.com/documents/excel/627-excel-list-files.html[/url]
  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
  ' http://stackoverflow.com/questions/9396441/excel-vba-if-condition-on-image
  ' http://answers.microsoft.com/en-us/office/forum/office_2010-customize/vba-changes-to-picturesinsert-shapeaddpicture/a14e60bc-a777-41f9-a4b3-d18a7a33beae
  ' http://www.ozgrid.com/forum/showthread.php?t=56556
  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

 

[NARAYANK991]

Hi ,

While you wait for a solution to your posted problem , I have seen that changing the scale factor changes the image size.

In the following 2 lines of code :

  .ScaleHeight 3, msoFalse, msoScaleFromTopLeft
  .ScaleWidth 3, msoFalse, msoScaleFromTopLeft

increasing the 3 increases the image size , reducing it reduces the image size.

Narayan

 

[akarich73]

Hi Narayan,

I thought so too, but I tested a few different .Scale combinations and there is no change in the 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.

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

usage note: the code is really used to create excel reports in which I 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 in my work.

 

[NARAYANK991]

Hi ,

I misunderstood your requirement ; scaling an image should never change the file size , since all the information is still retained within the file ; the only way to change the file size would be to compress it , or change its format , assuming its original format was a size-heavy format such as .bmp

I think what you want done is not directly possible ; if you think the Compress Pictures command does what you think it does , please go through these links :

http://www.excelbanter.com/showthread.php?t=67965

http://datapigtechnologies.com/blog...ess-xlsx-files-to-the-smallest-possible-size/

The second link has some suggestions in the comments section.

Narayan

 

[akarich73]

After much searching...there is a solution. Code below creates a scaled temp.jpg file that can then be inserted into the comment, with hyperlink to original image. Then temp.jpg is deleted and its done hopefully with no mem overflow or huge excel file issues.

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