Add Comment Picture: Maintain Perspective Ratio

[YellowLabPro]

I am compiling .jpg images to be viewed in Excel. I am using the .AddComment.Shape to perform this task. The problem I am facing is I have two different size images; one being 1100x647 the other being 647x874.

The first on is an image, a photoshop file converted to a .jpg format and the other is PDF, converted to a .jpg. The PDF is a typical 8.5x11 document setup. This is causing the issue.

Here is my code:
[VBA]
For Each file In Folder.Files
If (LCase(Right(file, 4)) = LCase(fileType)) Then
With ws.Cells(iCurrentRow, iColumn)
.Value = file.Name
.AddComment.Shape.Fill.UserPicture file.path
.Comment.Shape.Width = 1100
.Comment.Shape.Height = 647

iCurrentRow = iCurrentRow + 1
End With
[/VBA]

What I was thinking might work is rather than setting a hard value, is to use a percentage. But this is not allowed:
[VBA]
.Comment.Shape.Width = 100%
.Comment.Shape.Height = 100%
[/VBA]

If there is a workaround, this would be best. If not I am pondering changing the PDF to have a background of the same size. But this is going to be a chore. I have about 4000 images w/ 1000 of them being PDF. So it would take considerable time to alter the PDF image.

Thanks for having a look,

Doug

[Bob Phillips]

Doug,

I am not sure I fully understand, but does this help at all

[vba]

.Comment.Shape.Height = .Comment.Shape.Height /.Comment.Shape.Width * 1100
[/vba]

[YellowLabPro]

Bob,
Thanks for having a look. I am not sure that will work, but may be on the right path.
I have two different dimension files one is wider and the other is taller, so if I have a constant value, e.g. 1100(w) x 647(h) then the taller file is distorted. So I was mulling the idea over of having the file be evaluated and = 100% of itself rather than having a fixed number.
The other file's native file dimension is 479(w) x 647(h).

Thanks again for sifting through my cryptic explanations....

[Bob Phillips]

I think that was what I thought, and what I tried to address.

I worked on the basis that your wanted an 1100 width, and I determined the height from that, thereby maintaining the ratio. What I did was determine the (new) height by taking the (old) height, divide it by the (old) width and multiply by 1100.

Having spelt it out, I realise I made a mistake, I need to get the width before it is changed, so try this revision

[vba]

For Each file In Folder.Files
If (LCase(Right(file, 4)) = LCase(FileType)) Then
With ws.Cells(iCurrentRow, iColumn)
.Value = file.Name
.AddComment.Shape.Fill.UserPicture file.Path
With .Comment.Shape
.Height = .Width / 1100
.Width = 1100
End With

iCurrentRow = iCurrentRow + 1
End With
[/vba]

[mdmackillop]

Hi Doug,
Great to see you back again!
I made up an Excel photo handler here; doesn't use Comments, but any use?
Regards
Malcolm

[Carl A]

You can get the image Height and Width by using by setting a reference to:

Microsoft Windows Image Acquistion Library v2.0

dll can be obtained here at Microsoft Download Center

http://tinyurl.com/3pc836

There are probably other ways to get the information, but this is how I did it.
I also use this dll to resize a directory of pictures and make thumbs out of them.
The download comes with a help file.

There is an issue of resizing when I try to resize your smaller pic size to the larger size I only get 862x647 the same can be said of the reverse. This is probably due to it maintaining the aspect ratio.

Beats the heck out of doing manually

Something like this you may have to tweak it:
[vba]Dim jpgImg As ImageFile
Set jpgImg = CreateObject("WIA.ImageFile")

For Each file In Folder.Files
If (LCase(Right(file, 4)) = LCase(FileType)) Then
For Each file In Folder.Files
If (LCase(Right(file, 4)) = LCase(FileType)) Then

With ws.Cells(iCurrentRow, iColumn)
jpgImg.LoadFile file.Name
.Value = file.Name
.AddComment.Shape.Fill.UserPicture file.Path
.Comment.Shape.Width = jpgImg.Width
.Comment.Shape.Height = jpgImg.Height

iCurrentRow = iCurrentRow + 1
End With
[/vba]

[YellowLabPro]

Good Morning Carl,Before I jump in w/ both feet, I am putting a couple toes in...I would like to re-cap w/ you what is required, okay?

1) Download DLL to resize, correct?

Q) Where will the DLL need to be saved?

**) Thought: It appears that I have 3 different original file sizes, if the DLL can handle this, fine, if not- then I could sort them and resize through a batch automation utilizing photoshop.If I don't respond right away, it will be due to me working through it- thanks for your help on this.Doug

[Carl A]

From the Readme.txt

To install the Windows Image Acquisition Library v2.0,
copy the contents of this compressed file to a directory on your hard drive.

Copy the wiaaut.chm and wiaaut.chi files to your Help directory (usually located at C:\Windows\Help)

Copy the wiaaut.dll file to your System32 directory (usually located at C:\Windows\System32)

From a Command Prompt in the System32 directory run the following command:

RegSvr32 WIAAut.dll

As a added note if you have vb6 then you have extra controls available once you set a reference to the library in components .

Here is some sample code to resize your 800x600 jpg in the folder indicated.

[vba]Sub ResizePic()
Dim Img As ImageFile
Dim IP As ImageProcess
Dim sFName As String
Dim i As Integer

On Error GoTo AutoError
'Get Dir
sFName = Dir("C:\WINDOWS\Web\Wallpaper\")

Set Img = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
'Set i to one
i = 1
Do While Len(sFName) > 0
If Right(sFName, 3) = "jpg" Then 'Adjust to suit
'Load File
Img.LoadFile "C:\WINDOWS\Web\Wallpaper\" & sFName & ""
'Resize
IP.Filters.Add IP.FilterInfos("Scale").FilterID
IP.Filters(i).Properties("MaximumWidth") = 150 'Will resize to 133
IP.Filters(i).Properties("MaximumHeight") = 100 'Will resize to 100
'Apply changes
Set Img = IP.Apply(Img)
'Save File
Img.SaveFile "C:\WINDOWS\Web\Wallpaper\" & "Thumb" & sFName & ""
'increment IP.Filters
i = i + 1
End If
'Next File
sFName = Dir
Loop
Set Img = Nothing
Set IP = Nothing
Exit Sub
AutoError:
'Automation Error if Files are not found or saved file exist
If Err.Number = -2147024816 Then
MsgBox "File Already Exist", vbOKOnly
Resume Next
Else
MsgBox Err.Number & " " & Err.Description
End If

End Sub
[/vba] Also you can change the format of the image file see help for details.

Before I jump in w/ both feet, I am putting a couple toes in

Full body immersion is required.

Enjoy!

update wrong error code