Determine picture height in VBA

[obryan25]

I have a macro to insert a photo using a formula path on an excel spreadsheet.

The photo path is in worksheet "SubPhotos" cell "AC2".
"AMCPic" is the name of the range where the photo is pasted (its six cells... C10:E11... which have an outer border).
The picture is named "MyAMCPicture1" once it is inserted.
The "Dim i As Integer" was taken from another macros that cycled though multiple pics... however, this macro only uses one photo...

Once the picture is inserted I change the width to 446.4 to fit the width of columns C:E. Once the pictures width is set, I would like to determine what the inserted picture's height is in order to use that info to set the row height (there are actually two rows... 9 and 10) so that the picture sits just within the border of the "AMCPic" range.

The macro I am using follows. The areas set off with apostrophes are what I have tried to determine what the picture height is but I have not been successful. I think I can get the row height part to work but I can't accomplish this without figuring out what the picture height is.

Can someone please help me determine the picture width in pixels and add code to use that with my row height.


Sub InsertAMCPic()
'
' InsertAMCPic Macro
'

Dim PageNo
Dim RangePrint As Range
Dim photo As Picture 'Added per a help forum at xtremevbtalk.com
Dim PhotoCopy As Object 'added 120214 to run the Offset function for PhotoID
Dim PhotoNum As Object
Dim PhotoRefOne As Object
'Dim imgSize(1) As Integer
'Dim wia As Object
Application.ScreenUpdating = False
Sheets("SubPhotos").Select
RemSaleNum = Range("ad24") 'Counts down # of photos
RemDelNum = Range("ad24") 'Counts down # of photos for delete
Set PhotoCopy = Range("AC2") 'this field includes complete photo path and name
Sheets("Site").Select
Set PhotoRefOne = Range("AMCPic") 'this is range of cells where this photo is inserted.
Dim i As Integer
For i = 1 To RemSaleNum 'Do

'PIC 1
'Sheets("Site").Select.Range("AMCPic").ClearContents 'added as test 4/12/23
Sheets("SubPhotos").Select
Set PhotoCopy = PhotoCopy.Offset(1, 0) 'changed this from PhotoID to PhotoCopy 120214
PhotoID = PhotoCopy
Sheets("Site").Select
PhotoRefOne.Select 'selects range of cells where photo is inserted
Set photo = ActiveSheet.Pictures.Insert(PhotoID)
With photo
On Error Resume Next
ActiveSheet.Shapes.Range(Array("MyAMCPicture1")).Delete
On Error GoTo 0
'Pic.Name = "picture"

'.ShapeRange.LockAspectRatio = msoFalse
'.Width = 447
'.ShapeRange.LockAspectRatio = msoTrue
End With
photo.Name = "MyAMCPicture" & i
RemSaleNum = RemSaleNum - 2
Set PhotoRefOne = PhotoRefOne.Offset(15, 0)
ActiveSheet.Shapes.Range(Array("MyAMCPicture1")).Select
Selection.ShapeRange.Width = 446.4
'ActiveSheet.Shapes.Range(Array("MyAMCPicture1")).Select
'"MyAMCPicture1" = wia.Height
'Range("AMCPic").Select
'Selection.RowHeight = wia.Height


If RemSaleNum = 0 Then GoTo 350
Next i 'Loop Until RemSaleNum = 0
GoTo 400
100 TopCount = "1" 'Identifies the last photo page was one photo only
Counter = Counter + 1
110 Count = Counter * 15
Set RangePrint = Range(Cells(1, 1), Cells(Count, 5))
300 For i = 1 To RemDelNum
ActiveSheet.Shapes("MyAMCPicture" & i).Delete
Next i
350 ActiveSheet.Shapes.Range(Array("MyAMCPicture1")).Select
Selection.ShapeRange.IncrementLeft 1.5
Selection.ShapeRange.IncrementTop 1.5
400 Sheets("Site").Select
Range("C9").Select
'
End Sub

 

[NdNoviceHlp]

Hi obryan24 and Welcome to the Board! Maybe I'm not following along, but it seems like you just want to fit the pic to the named range. Something like this should work. HTH. Dave

Dim Photo As Object
Set Photo = ActiveSheet.Pictures.Insert(PhotoID)
With Photo
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = Range("AMCPic").Left
    .Top = Range("AMCPic").Top
    .Width = Range("AMCPic").Width
    .Height = Range("AMCPic").Height
    .Name = "MyAMCPicture" & i
End With

 

[obryan25]

Hi Dave, thank you for your response. I feel like my request is confusing but I couldn't figure out how to edit it... sorry!!!

The range AMCPic has a fixed width of 446.4, but I want the height of the range to be variable in order to keep the picture's original aspect ratio. Once the picture is inserted and sized to its width, I want to be able to adjust the row heights so that the border around MyAMCPicture1 (the picture) fits just outside the picture's borders.

I was thinking if I can figure out how to identify the height of the picture (once the width has been changed to 446.4), then I could use that height information to adjust the row heights.

I appreciate your time!

Kevin

 

[obryan25]

Hi obryan24 and Welcome to the Board! Maybe I'm not following along, but it seems like you just want to fit the pic to the named range. Something like this should work. HTH. Dave

Dim Photo As Object
Set Photo = ActiveSheet.Pictures.Insert(PhotoID)
With Photo
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = Range("AMCPic").Left
    .Top = Range("AMCPic").Top
    .Width = Range("AMCPic").Width
    .Height = Range("AMCPic").Height
    .Name = "MyAMCPicture" & i
End With

Hi Dave, obviously a newbie here. I tried to respond earlier but just made a new post so I am responding now.

Thank you for your response. I feel like my request is confusing but I couldn't figure out how to edit it... sorry!!!

The range AMCPic has a fixed width of 446.4, but I want the height of the range to be variable in order to keep the picture's original aspect ratio. Once the picture is inserted and sized to its width, I want to be able to adjust the row heights so that the border around MyAMCPicture1 (the picture) fits just outside the picture's borders.

I was thinking if I can figure out how to identify the height of the picture (once the width has been changed to 446.4), then I could use that height information to adjust the row heights.

I appreciate your time!

Kevin

 

[NdNoviceHlp]

I had it backwards. If you provide the width and lock the aspect ratio, won't that do it? Trial this. Dave

Dim Photo As Picture
Set Photo = ActiveSheet.Pictures.Insert(PhotoID)
With Range("AMCPic")
Photo.Top = .Top
Photo.Left = .Left
Photo.ShapeRange.LockAspectRatio = msoTrue
Photo.Placement = xlMoveAndSize
Photo.ShapeRange.Width = 446.4
End With

 

[NdNoviceHlp]

Missed the edit...again. After the "End With" you can trial this line of code. It will tell you the pic height which you can use to set the row height. Dave

MsgBox Photo.ShapeRange.Height

 

[jolivanes]

Would this not do?
Change references as required.
Picture name to be imported is in Cells(3, 13). Change as required.
New picture name after importing is in Cells(4, 13). Change as required

Sub Maybe()
Dim rat As Double, path As String
path = Cells(1, 13).Value & "\"    '<---- Change as required
With ActiveSheet.Shapes.AddPicture(path & Cells(3, 13).Value, False, True, Columns(3).Left, Rows("10").Top, -1, -1)
    .Name = Cells(4, 13).Value    '<---- Change as required
        .LockAspectRatio = msoFalse
            rat = .Width / (Columns(6).Left - Columns(3).Left)
            .Width = Columns(6).Left - Columns(3).Left
        .Height = .Height * rat
    Rows("10:11").RowHeight = .Height / 2
End With
End Sub

 

[jolivanes]

Or if you want you can set the lock aspect ratio to true

.LockAspectRatio = msoTrue

and leave the following out.

.Height = .Height * rat

 

[obryan25]

Thanks Dave (NdNoviceHlp) and Jolivanes!!! I used a little bit of both of your responses and a small bit of trial and error to make it work. The last two lines of the three lines shown below are what I ended up using to make the rows resize to match the picture height. Since there were two rows, the height was divided by two. The "+1" was added to give a little more space since the range where the picture is input is bounded by a double border and the picture was barely overlapping the border without this addition.

Selection.ShapeRange.Width = 446.4
photo.ShapeRange.Height = Selection.ShapeRange.Height
Range("AMCPic").RowHeight = Selection.ShapeRange.Height / 2 + 1

Greatly appreciate your helping! I spent hours scouring the internet for a solution and could not find one before I finally decided to post here. Big fan of you guys!!!

Kevin

 

[jolivanes]

Good to hear you have it working for you.
The reason I don't use width like you do (446.4) is because it is written in stone, a.k.a. hardcoded.
If I want a different width or an adjustment, I need to change it in the code.
Using the Column widths, all I need to do is change the width of one column. Same goes for rows.
But, to each his own.
Thanks for the update and good luck.