Solved

Add a preview of a picture in a comment box in EXcel

Posted on 2013-06-24
5
464 Views
Last Modified: 2013-07-06
Ok, so I have a worksheet that is essentially a register of files, users upload files to a server location using this tool, the workbook keeps a log of the files and provides a hyperlink to them.

When a user uploads an image file I have the code then adding a comment box to that cell, set to hidden, and insert the image as the background of the comment so on hovering their mouse they get a preview of the picture.

.autosize doesn't work of course on the image, so I use code I get from a post by Peter Thornton on Microsoft forums, that places an image control on the sheet, then uses the height and width of that to resize the comment box, before then removing the image from the worksheet before anyone sees it ;-)

This all works great, until someone comes along with a high resolution picture and my preview doesn't even fit on the monitor.....

How do I set the maximum size of Pict1 below (Line 15) while keeping the aspect ratio locked?


If sFileExt = ".jpeg" Or sFileExt = ".jpg" Or sFileExt = ".bmp" Or sFileExt = ".gif" Or sFileExt = ".jpeg" Or sFileExt = ".jpeg" Or sFileExt = ".tiff" Or sFileExt = ".png" Or sFileExt = ".JPG" Or sFileExt = ".BMP" Or sFileExt = ".GIF" Or sFileExt = ".JPEG" Or sFileExt = ".TIFF" Or sFileExt = ".PNG" Then
Range("A" & lRow).Select
Workbooks(DDM).Sheets("WIP").Activate
    ActiveCell.AddComment
    ActiveCell.Comment.Visible = False
    ActiveCell.Comment.Text Text:="Preview:"
    ActiveCell.Comment.Shape.Fill.UserPicture sLink
    ActiveCell.Comment.Shape.ScaleHeight 3#, msoFalse, msoscaleformtopleft
    ActiveCell.Comment.Shape.ScaleWidth 2.4, msoFalse, msoscaleformtopleft

' Insert image control Pic to set Picture height and width
' Then remove the picture, but leave the control so it's dimensions
' can be used to size the image

Set Pict1 = ActiveSheet.Pictures.Insert(sLink)
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .ReadingOrder = xlContext
        .Orientation = xlHorizontal
    End With
    With ActiveCell.Comment.Shape
        .Height = Pict1.Height
        .Width = Pict1.Width
    End With


Pict1.Delete
Set Pict1 = Nothing

Else
End If

Open in new window

0
Comment
Question by:Conor_Newman
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 2
5 Comments
 
LVL 5

Accepted Solution

by:
Jason Schlueter earned 250 total points
ID: 39283087
Shape.ScaleHeight and ScaleWidth?

http://msdn.microsoft.com/en-us/library/office/ff822186(v=office.14).aspx
http://msdn.microsoft.com/en-us/library/office/ff840427(v=office.14).aspx

How about something like this.  I don't know if it'll even compile (I'm not near Excel right now).

Dim NewWidth as Integer
Dim NewHeight as Integer
Dim MaxWidth as Integer
Dim MaxHeight as Integer

MaxWidth = 640
MaxHeight = 480

If ((Pict1.Width * MaxHeight) / Pict1.Height) <= MaxWidth Then
	NewWidth = (MaxWidth * Pict1.Height) / Pict1.Width
	NewHeight = MaxHeight
Else
	NewWidth = MaxWidth
	NewHeight = (MaxHeight * Pict1.Width) / Pict1.Height
End If

With ActiveCell.Comment.Shape
	.Height = NewHeight
	.Width = NewWidth
End With

Open in new window

0
 
LVL 2

Author Comment

by:Conor_Newman
ID: 39289470
ok, it will compile.. the maths are wrong somewhere, as it end up being stretched width wise massively. lol

It works ok if the pictures are landscape, but if their orientation is portrait id stretches them crazy amounts on the width, way past the MaxWidth, ie: This pic in the screenshot has had it's width stretched to 1121
DSC00600.jpg
0
 
LVL 2

Assisted Solution

by:Conor_Newman
Conor_Newman earned 0 total points
ID: 39289531
Ok, this is a little cumbersome, but so far seems to be working,
Basically just a simple maths formula, if pict1 height or width is larger than the max allowed, divide both to get 1% of their size, dive that into the max width / height, and which ever is bigger, multiply each 1% value by that value, increasing both values up to that percentage of the whole.  Maintains the aspect ratio and forces it to comply with the max height / width.

Will mark this as resolved later once I've tested further!

If sFileExt = ".jpeg" Or sFileExt = ".jpg" Or sFileExt = ".bmp" Or sFileExt = ".gif" Or sFileExt = ".jpeg" Or sFileExt = ".jpeg" Or sFileExt = ".tiff" Or sFileExt = ".png" Or sFileExt = ".JPG" Or sFileExt = ".BMP" Or sFileExt = ".GIF" Or sFileExt = ".JPEG" Or sFileExt = ".TIFF" Or sFileExt = ".PNG" Then

Dim NewWidth As Integer
Dim NewHeight As Integer
Dim MaxWidth As Integer
Dim MaxHeight As Integer
Dim TempWidth As Integer
Dim TempHeight As Integer



Range("A" & lRow).Select
Workbooks(DDM).Sheets("WIP").Activate
    ActiveCell.AddComment
    ActiveCell.Comment.Visible = False
    ActiveCell.Comment.Text Text:="Preview:"
    ActiveCell.Comment.Shape.Fill.UserPicture sLink

' Insert Pic to set Control Picture height and width
' Then remove the picture, but leave the control so it's dimensions
' can be used to size the image

Set Pict1 = ActiveSheet.Pictures.Insert(sLink)

    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .ReadingOrder = xlContext
        .Orientation = xlHorizontal
    End With
    
    With ActiveCell.Comment.Shape
        '.Height = Pict1.Height
        '.Width = Pict1.Width
    End With
    
    MaxWidth = 640
    MaxHeight = 480

If Pict1.Width > MaxWidth Or Pict1.Height > MaxHeight Then
        NewWidth = (Pict1.Width / 100)
        NewHeight = (Pict1.Height / 100)
        TempWidth = (MaxWidth / NewWidth)
        TempHeight = (MaxHeight / NewHeight)
    If NewWidth > NewHeight Then
        NewWidth = NewWidth * TempWidth
        NewHeight = NewHeight * TempWidth
    Else
        NewWidth = NewWidth * TempHeight
        NewHeight = NewHeight * TempHeight
    End If

Else

NewWidth = Pict1.Width
NewHeight = Pict1.Height

End If


    With ActiveCell.Comment.Shape
        .Height = NewHeight
        .Width = NewWidth
    End With


Pict1.Delete
Set Pict1 = Nothing

Else
End If

Open in new window

0
 
LVL 5

Expert Comment

by:Jason Schlueter
ID: 39290558
Math!!

I'm glad you were able to get it working.
0
 
LVL 2

Author Closing Comment

by:Conor_Newman
ID: 39303680
JasonSchlueter's solution worked but only if the images were landscaped, if they were portrait orientation it stretched the width wider than the monitor in some cases.

I made a few small edits to his code to base the scaling on a percentage ratio, to maintain the aspect ratio while shrinking the image to fit with the limits set by the MaxWidth and MaxHeight integers.
0

Featured Post

Enroll in July's Course of the Month

July's Course of the Month is now available! Enroll to learn HTML5 and prepare for certification. It's free for Premium Members, Team Accounts, and Qualified Experts.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes how to import an Outlook PST file to Office 365 using a third party product to avoid Microsoft's Azure command line tool, saving you time.
I was prompted to write this article after the recent World-Wide Ransomware outbreak. For years now, System Administrators around the world have used the excuse of "Waiting a Bit" before applying Security Patch Updates. This type of reasoning to me …
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

617 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question