Help Centering Image VBA

Kristie390

New Member
Joined
Jul 23, 2018
Messages
24
Please help.
I currently am using the below to insert a picture but it is now going top left. I would like to have this resized to auto fit in the cell with the row height 125.
Can someone please help me here? I have researched a few places online and keep getting an error. VBA newbie here..




With Range(BCell)


Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)


.RowHeight = 125

myPict.Top = .Top
myPict.Left = .Left
myPict.Placement = xlMoveAndSize


myPict.Height = 115


End With
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
Please help.
I currently am using the below to insert a picture but it is now going top left. I would like to have this resized to auto fit in the cell with the row height 125.
Can someone please help me here? I have researched a few places online and keep getting an error. VBA newbie here..




With Range(BCell)


Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)


.RowHeight = 125

myPict.Top = .Top
myPict.Left = .Left
myPict.Placement = xlMoveAndSize


myPict.Height = 115


End With

any luck?
 
Upvote 0
Code:
  Dim myPic         As Picture
  Dim myRng         As Range
  
  Set myPic = ...
  Set myRng = ...

  myPic.Height = 115

  With myRng
    .RowHeight = 125
    myPic.Top = .Top + .Height / 2 - myPic.Height / 2
    myPic.Left = .Left + .Width / 2 - myPic.Width / 2
  End With
 
Upvote 0
and I am not soo concerned about the height of the picture, as long as it fits in the cell and is centered
 
Upvote 0
Assign the picture variable to the picture you wanted centered, and the range variable to the range you want it centered over.
 
Upvote 0
Assign the picture variable to the picture you wanted centered, and the range variable to the range you want it centered over.


Dim myPic As Picture
Dim myRng As Range

Set myPic = ActiveSheet.Pictures.Insert(PictureLoc)

Set myRng = BCell


myPic.Height = 115


With myRng
.RowHeight = 125
myPic.Top = .Top + .Height / 2 - myPic.Height / 2
myPic.Left = .Left + .Width / 2 - myPic.Width / 2
End With

I specified above but I am getting Compile Error : Type mismatch
 
Upvote 0
What is PictureLoc? What is Bcell?
 
Upvote 0
Here is a copy of the entire code. My sister helped me get this together so she added notes. I was trying to polish it up a bit..

The bold is the old code that I was trying to get updated to center in the cell.




Private Sub Worksheet_SelectionChange(ByVal Target As Range)


' *** initial code: https://www.youtube.com/watch?v=VUl3l9wB51M
' *** delete single picture instead of all: https://stackoverflow.com/questions/2320826/how-to-check-if-a-cell-has-a-picture
' *** understanding basic VBA: https://www.tutorialspoint.com/vba/vba_macro_comments.htm
' *** run a macro on open: https://analysistabs.com/excel-vba/run-macro-automatically-opening-workbook/


' *** anything we're referencing in VBA must be stored as a variable (Dim is short for Dimension)
' *** basic necessary variables
Dim Sh As Worksheet
Dim rw As Range


' *** RowCount keeps track of the row number/iteration we're on when looping the sheet
Dim RowCount As Integer


' *** picture object (to create and insert) and path to picture
Dim myPict As Picture
Dim PictureLoc As String


' *** the ACell has the SKU (or picture name) and the BCell is where we want to add the picture
Dim ACell As String
Dim BCell As String


' *** loop through pictures/shapes for row (to delete old ones)
Dim shp As Shape
Dim rangeToTest As Range
Dim c As Range
Dim shpList


' *** starting at 1 to avoid header
RowCount = 1


' *** store the variable so we know which "Sheet" or tab we're focusing on
Set Sh = ActiveSheet


' *** store all of the pictures on this sheet/tab (we will loop through them and delete old pictures for the current row)
Set shpList = ActiveSheet.Shapes


' *** check/loop/iterate all the rows for this sheet
For Each rw In Sh.Rows


' *** if this cell does not have a value, skip it
If Sh.Cells(rw.Row, 1).Value = "" Then
Exit For
End If

' *** update the RowCount each iteration
RowCount = RowCount + 1


' *** store the current cells we wish to work with
ACell = "A" + CStr(RowCount)
BCell = "B" + CStr(RowCount)

' *** get the A cell for the row we're on (dynamically)
'If Target.Address = Range("A" + RowCount).Address Then
If Target.Address = Range(ACell).Address Then

' *** store the cells for this row
Set rangeToTest = Selection

' *** check all the cells on this row and delete old picture(s)
For Each c In rangeToTest


' *** check all of the pictures (shapes) for this sheet/tab
For Each shp In shpList


' *** once we find shapes on the current row
If c.Address = shp.TopLeftCell.Address Then


' *** delete them as we're about to dynamically update a recent/newest picture
shp.Delete


End If


Next shp


Next c

' *** specify the photo path for this row, dynamically based on the SKU in cell A
'PictureLoc = "D:\Images\Bulova\98X109.jpg"
PictureLoc = "S:\Images\Casio" & Range(ACell).Value & ".jpg"

' *** we're adding the picture to the B cell
With Range(BCell)

' *** create a picture object from the path we've defined
Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)

' *** adjust the row height to the picture height
.RowHeight = 125

myPict.Top = .Top
myPict.Left = .Left
myPict.Placement = xlMoveAndSize

myPict.Height = 115

End With

End If


Next rw


' *** MsgBox below can be used for testing - to make sure this code is firing (it will show a pop up on click)
'MsgBox (RowCount)


End Sub
 
Upvote 0

Forum statistics

Threads
1,214,386
Messages
6,119,212
Members
448,874
Latest member
b1step2far

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top