Vba - insert photo with varying sizes

[melodramatic]

I have a macro that I wrote (thanks to MrExcel help) 6 years ago - and it was worked like a dream. UNTIL the group I work with decided we're not using cameras anymore - all the guys have cell phones, so they can take all of the project photos that way, and then upload them to our project folders.

The biggest problem with that is that, while the cameras were all the same and took the same size photos, cell phones not only have different sizes, but different size ratios. I have one guy whose cell phone pics are very close to our old camera sizes, while one of our new guys has HORRID photos that are very tall and very thin. Needless to say, my hard-coded size measurements are not working.

The changes I'm needing to put in are to set the pic to LockAspectRatio, and then have it go to 456 wide (or 456 high if the photos rotates 270 degrees). When I played with this, I commented out the 340 measurement, hoping the 456 would set the aspect precendent, but nope. Every time I ran it, I ended up with the 456 being a certain percentage of original, and the lower number (even though I hoped it would pick up the same % ratio) being several percentage points less.

One thing that I've noticed is that the original photo height/width is 26.8" and 15.08". So, one possibility might be that it's pulling it in at a size that won't work on my paper. BUT, doesn't that get handled by me putting it initially at 5% for both height and width? I'm confused in a major way here.

Appreciate any help you can give me.

For ListRow = 5 To LastRow

    Sheets("jpgList").Select
   
    If Range("C" & ListRow) = "Y" Then 'Photo is marked to print
       
        PhotoFile = PhotosFolder & "\" & Range("B" & ListRow) 'Col B is Photo Filename
        PhotoOrient = Range("D" & ListRow)
               
        Sheets("PhotoArray").Select

            Rows(ArrayRow & ":" & ArrayRow).Select
                Selection.RowHeight = 342
            Range("A" & ArrayRow).Select
                    
                ActiveSheet.Pictures.Insert(PhotoFile).Select
                    Selection.ShapeRange.Line.Visible = msoFalse
                    Selection.ShapeRange.LockAspectRatio = msoTrue 'we'll set at 5%, so that turning the photo won't go over margins
                    Selection.ShapeRange.ScaleHeight 0.05, msoTrue, msoScaleFromTopLeft
                    Selection.ShapeRange.ScaleWidth 0.05, msoTrue, msoScaleFromTopLeft
                   
                    If Selection.Width > Selection.Height Then
                        With Selection.ShapeRange
                            .Rotation = 0
                            '.Height = 340  COMMENTED OUT
                            .Width = 456
                            .Top = Range("A" & ArrayRow).Top - 1.5
                            .Left = Range("A" & ArrayRow).Left
                        End With
                    Else
                        With Selection.ShapeRange
                            .Rotation = 270
                            .Height = 456
                            '.Width = 340 COMMENTED OUT
                            .Top = Range("A" & ArrayRow).Top - 52
                            .Left = Range("A" & ArrayRow).Left
                        End With
                    End If
                   
                Selection.ShapeRange.IncrementTop 3
       
        ArrayRow = ArrayRow + 1
        Rows(ArrayRow & ":" & ArrayRow).Select
            Selection.RowHeight = 28.5
        Range("B" & ArrayRow).Select
            ActiveCell.Value = PhotoNum
        Range("A" & ArrayRow).Select
            ActiveCell.Formula = "=VLOOKUP(B" & ArrayRow & ",Table1,6,FALSE)"
        ArrayRow = ArrayRow + 1
        PhotoNum = PhotoNum + 1
           
    End If
       
Next ListRow

 

[Micron]

I think you want to actually change the sizes and orientation of the image itself rather than the object (Shape) that contains it or the height of the row it's in. For that I suggest researching WIA (Windows Image Acquisition). I used it to rotate, flip and re-size images for a project but when I dropped my laptop I crunched the drive and lost everything on the disk so I have no code to share. Some day I'll have to get around to starting over.

You could also batch resize with Adobe Photoshop.