Paul Douglass
asked on
Centre multiple imported images in cells
Hi
I am importing images into cells, and I need them to move from their default top left position to the centre of the cell.
They are all in the same column,
Hope someone can help!
Thanks
Paul
I am importing images into cells, and I need them to move from their default top left position to the centre of the cell.
They are all in the same column,
Hope someone can help!
Thanks
Paul
Paul,
You probably don't want to center all shapes on the worksheet because that collection includes cell comments, and data validation dropdowns in addition to shapes, pictures and other graphic objects.
The code snippet below assumes that you pasted pictures in the cells and want the center of each picture to be shifted to the center of its top left cell.
If you have a different type of image than msoPicture, you will need to get its type number (instead of msoPicture). To do so, select an image, then put the following in the Immediate Window and hit Enter:
?Selection.ShapeRange.Type
You should get a number like 13 instead of a named constant (msoPicture in the code snippet) in response. Either the number or the named constant (enum) may be used in the code.
You probably don't want to center all shapes on the worksheet because that collection includes cell comments, and data validation dropdowns in addition to shapes, pictures and other graphic objects.
The code snippet below assumes that you pasted pictures in the cells and want the center of each picture to be shifted to the center of its top left cell.
If you have a different type of image than msoPicture, you will need to get its type number (instead of msoPicture). To do so, select an image, then put the following in the Immediate Window and hit Enter:
?Selection.ShapeRange.Type
You should get a number like 13 instead of a named constant (msoPicture in the code snippet) in response. Either the number or the named constant (enum) may be used in the code.
Sub ShapeCenter()
Dim shp As Shape
Dim cel As Range
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then 'Choose the type that matches your images
Set cel = shp.TopLeftCell
shp.Top = (cel.Top + cel.Height / 2) - shp.Height / 2
shp.Left = (cel.Left + cel.Width / 2) - shp.Width / 2
End If
Next
End SubASKER
Hi Byundt
Thanks for your help, I have placed the code I currently use which has the moving of the image done by a recorded macro. It is just the images I am importing that I want to centre in their destination cell, and they are all in the same column. I tried your code, and they stayed top left, and when I tried to get the image type it returned a warning box with 'Reference isn't valid'.
Hope the below makes it clearer, it isn't pretty but I am still learning!
Paul
Thanks for your help, I have placed the code I currently use which has the moving of the image done by a recorded macro. It is just the images I am importing that I want to centre in their destination cell, and they are all in the same column. I tried your code, and they stayed top left, and when I tried to get the image type it returned a warning box with 'Reference isn't valid'.
Hope the below makes it clearer, it isn't pretty but I am still learning!
Paul
Sub Insert_Image()
Application.ScreenUpdating = False
Sheets("Summary").Select
Dim inputCell As String
Dim outputCell As String
Dim filePath As String
Dim imageHeight As Integer
Dim imageWidth As Integer
Dim stopRow As Integer
Dim X As Range
' Specify the location values
inputCell = "D" ' The column which has the image names
outputCell = "G" ' The column you want the picture to go into
imageHeight = 50 ' The width of the image you are inserting
imageWidth = 60 ' The width of the image you are inserting
stopRow = 1500 ' How many rows to look for so that the loop stops.
'filePath = "U:\SSL\Images\" ' The location on your desktop of the images.
' Specify when to stop the loop (this is needed as there are spaces between the cells ' so you need to tell excel when to finish and not look forever.
For Each X In Range(inputCell + "1", Range(inputCell & stopRow).End(xlUp))
' If the value of the cell is empty move on to the next one.
If X <> "" Then
With X.Offset(1, 0)
' Set the image output to be the outputcell specified above on the same row.
Range(outputCell & X.Row).Select
' Check to see if the image exists, if not move on and ignore
On Error Resume Next
If Dir(filePath + X) <> "" Then
' If the iamge exists insert the picture.
ActiveSheet.Pictures.Insert(filePath + X).Select
' Once the image is inserted, using the aspect ratio change the width to a specified value
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = imageWidth
Selection.ShapeRange.Height = imageHeight
On Error GoTo 0
End If
On Error Resume Next
End With
End If
NextX:
Next X
ActiveSheet.DrawingObjects.Select
Selection.PrintObject = msoFalse
Selection.PrintObject = msoTrue
Selection.Placement = xlMoveAndSize
Application.CommandBars("Format Object").Visible = False
Range("B3").Select
' ActiveSheet.Pictures.Select
Dim s As String
Dim pic As Picture
Dim Rng As Range
Set ws = ActiveWorkbook.Worksheets("Summary")
Set Rng = ws.Range("A5:Z5000")
'Sheets("summary").Select
'Dim shp As Shape
'For Each shp In ActiveSheet.Shapes
'If Not shp.Type = msoFormControl Then shp.Delete
'Next
For Each pic In ActiveSheet.Pictures
With pic
s = .TopLeftCell.Address & ":" & .BottomRightCell.Address
End With
If Not Intersect(Rng, ws.Range(s)) Is Nothing Then
pic.ShapeRange.IncrementTop 0.75
pic.ShapeRange.IncrementTop 0.75
pic.ShapeRange.IncrementTop 0.75
pic.ShapeRange.IncrementTop 0.75
pic.ShapeRange.IncrementTop 0.75
pic.ShapeRange.IncrementTop 0.75
pic.ShapeRange.IncrementTop 0.75
pic.ShapeRange.IncrementTop 0.75
pic.ShapeRange.IncrementTop 0.75
pic.ShapeRange.IncrementTop 0.75
pic.ShapeRange.IncrementLeft 0.75
pic.ShapeRange.IncrementLeft 0.75
pic.ShapeRange.IncrementLeft 0.75
pic.ShapeRange.IncrementLeft 0.75
pic.ShapeRange.IncrementLeft 0.75
pic.ShapeRange.IncrementLeft 0.75
pic.ShapeRange.IncrementLeft 0.75
pic.ShapeRange.IncrementLeft 0.75
pic.ShapeRange.IncrementLeft 0.75
pic.ShapeRange.IncrementLeft 0.75
End If
Next
On Error GoTo 0
Range("B2").Select
Range("F5").Select
Range("B2").Select
Application.ScreenUpdating = True
End Sub
Paul,
Had you posted a workbook with the images askew, I could have edited my code to work on them.
When you post code, please use Code Blocks. The icon for them is just to the right of the double quote icon on the Experts Exchange toolbar (looks like sheet of paper with top right corner folded over).
I copied your code into a blank workbook. deleted the excess blank lines, deleted the shape moving statements, indented the code so I could read it, and added four statements taken from my suggested sub. I then made sure the code would compile, added a Dim statement for variable ws, and posted the code below.
I don't think I introduced any errors, but did not test the code. Please try it at your end with the idea in mind that we may need to tweak not a few times so it works. If you get a runtime error, post a screenshot of the Debugger showing the problem. If it works, but not correctly, post a screenshot (or better yet the entire workbook) showing the error after the code has been run.
Had you posted a workbook with the images askew, I could have edited my code to work on them.
When you post code, please use Code Blocks. The icon for them is just to the right of the double quote icon on the Experts Exchange toolbar (looks like sheet of paper with top right corner folded over).
I copied your code into a blank workbook. deleted the excess blank lines, deleted the shape moving statements, indented the code so I could read it, and added four statements taken from my suggested sub. I then made sure the code would compile, added a Dim statement for variable ws, and posted the code below.
I don't think I introduced any errors, but did not test the code. Please try it at your end with the idea in mind that we may need to tweak not a few times so it works. If you get a runtime error, post a screenshot of the Debugger showing the problem. If it works, but not correctly, post a screenshot (or better yet the entire workbook) showing the error after the code has been run.
Sub Insert_Image()
Application.ScreenUpdating = False
Sheets("Summary").Select
Dim inputCell As String
Dim outputCell As String
Dim filePath As String
Dim imageHeight As Integer
Dim imageWidth As Integer
Dim stopRow As Integer
Dim X As Range
' Specify the location values
inputCell = "D" ' The column which has the image names
outputCell = "G" ' The column you want the picture to go into
imageHeight = 50 ' The width of the image you are inserting
imageWidth = 60 ' The width of the image you are inserting
stopRow = 1500 ' How many rows to look for so that the loop stops.
'filePath = "U:\SSL\Images\" ' The location on your desktop of the images.
' Specify when to stop the loop (this is needed as there are spaces between the cells ' so you need to tell excel when to finish and not look forever.
For Each X In Range(inputCell + "1", Range(inputCell & stopRow).End(xlUp))
' If the value of the cell is empty move on to the next one.
If X <> "" Then
With X.Offset(1, 0)
' Set the image output to be the outputcell specified above on the same row.
Range(outputCell & X.Row).Select
' Check to see if the image exists, if not move on and ignore
On Error Resume Next
If Dir(filePath + X) <> "" Then
' If the iamge exists insert the picture.
ActiveSheet.Pictures.Insert(filePath + X).Select
' Once the image is inserted, using the aspect ratio change the width to a specified value
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = imageWidth
Selection.ShapeRange.Height = imageHeight
On Error GoTo 0
End If
On Error Resume Next
End With
End If
NextX:
Next X
With ActiveSheet.DrawingObjects.Select
.PrintObject = msoTrue
.Placement = xlMoveAndSize
End With
Application.CommandBars("Format Object").Visible = False
Range("B3").Select
Dim pic As Picture
Dim Rng As Range
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Summary")
Set Rng = ws.Range("A5:Z5000")
Dim CellTopLeft As Range
For Each pic In ws.Pictures
With pic
Set CellTopLeft = .TopLeftCell
If Not Intersect(Rng, CellTopLeft) Is Nothing Then
.Top = (CellTopLeft.Top + CellTopLeft.Height / 2) - .Height / 2
.Left = (CellTopLeft.Left + CellTopLeft.Width / 2) - .Width / 2
End If
End With
Next
On Error GoTo 0
Range("B2").Select
End SubASKER
Hi Byundt
Once again thanks for helping, first post so taking on board your tips. The code ran ok, but this is where the images landed. I am trying to get them centred in column G,
Once again thanks for helping, first post so taking on board your tips. The code ran ok, but this is where the images landed. I am trying to get them centred in column G,
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Hi Brad
Almost there! The issue seems to be around the hidden columns / rows. When I have them all unhidden it works perfectly, however when I hide row 5 and column F (for formatting) the first image hangs between rows 4 & 5 and still between columns D & F.
Any further ideas?
Paul
Almost there! The issue seems to be around the hidden columns / rows. When I have them all unhidden it works perfectly, however when I hide row 5 and column F (for formatting) the first image hangs between rows 4 & 5 and still between columns D & F.
Any further ideas?
Paul
Paul,
I added a test for a hidden row in the code below. I also fixed a goof on my part in assigning the top left cell to a variable.
Brad
I added a test for a hidden row in the code below. I also fixed a goof on my part in assigning the top left cell to a variable.
Brad
Sub Insert_Image()
Application.ScreenUpdating = False
Sheets("Summary").Select
Dim inputCell As String
Dim outputCell As String
Dim filePath As String
Dim imageHeight As Integer
Dim imageWidth As Integer
Dim stopRow As Integer
Dim X As Range
' Specify the location values
inputCell = "D" ' The column which has the image names
outputCell = "G" ' The column you want the picture to go into
imageHeight = 50 ' The width of the image you are inserting
imageWidth = 60 ' The width of the image you are inserting
stopRow = 1500 ' How many rows to look for so that the loop stops.
'filePath = "U:\SSL\Images\" ' The location on your desktop of the images.
' Specify when to stop the loop (this is needed as there are spaces between the cells ' so you need to tell excel when to finish and not look forever.
For Each X In Range(inputCell + "1", Range(inputCell & stopRow).End(xlUp))
' If the value of the cell is empty move on to the next one.
If X <> "" And X.RowHeight <> 0 Then
' Set the image output to be the outputcell specified above on the same row.
Range(outputCell & X.Row).Select
' Check to see if the image exists, if not move on and ignore
On Error Resume Next
If Dir(filePath + X) <> "" Then
' If the iamge exists insert the picture.
With ActiveSheet.Pictures.Insert(filePath + X).Select
' Once the image is inserted, using the aspect ratio change the width to a specified value
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Width = imageWidth
.ShapeRange.Height = imageHeight
End With
End If
On Error GoTo 0
End If
NextX:
Next X
With ActiveSheet.DrawingObjects.Select
.PrintObject = msoTrue
.Placement = xlMoveAndSize
End With
Application.CommandBars("Format Object").Visible = False
Range("B3").Select
Dim pic As Picture
Dim Rng As Range
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Summary")
Set Rng = ws.Range("A5:Z5000")
Dim CellTopLeft As Range
For Each pic In ws.Pictures
With pic
Set CellTopLeft = .TopLeftCell
If CellTopLeft.Column <> 7 Then Set CellTopLeft = CellTopLeft.EntireRow.Cells(1, 7) '*****This statement added
If Not Intersect(Rng, CellTopLeft) Is Nothing Then
.Top = (CellTopLeft.Top + CellTopLeft.Height / 2) - .Height / 2
.Left = (CellTopLeft.Left + CellTopLeft.Width / 2) - .Width / 2
End If
End With
Next
On Error GoTo 0
Range("B2").Select
End SubASKER
Hi Brad
Thanks again, it bombed out on
With ActiveSheet.DrawingObjects
.PrintObject = msoTrue
With a run time error 424, object required
But I have adapted the change to the variable and that worked, so I think I can tinker around with it to make it work with my existing code and your additions.
Many thanks for your help!
Paul
Thanks again, it bombed out on
With ActiveSheet.DrawingObjects
.PrintObject = msoTrue
With a run time error 424, object required
But I have adapted the change to the variable and that worked, so I think I can tinker around with it to make it work with my existing code and your additions.
Many thanks for your help!
Paul
I deleted the block that was giving you trouble and moved its two meaningful statements inside the block that was placing the pictures.
Sub Insert_Image()
Application.ScreenUpdating = False
Sheets("Summary").Select
Dim inputCell As String
Dim outputCell As String
Dim filePath As String
Dim imageHeight As Integer
Dim imageWidth As Integer
Dim stopRow As Integer
Dim X As Range
' Specify the location values
inputCell = "D" ' The column which has the image names
outputCell = "G" ' The column you want the picture to go into
imageHeight = 50 ' The width of the image you are inserting
imageWidth = 60 ' The width of the image you are inserting
stopRow = 1500 ' How many rows to look for so that the loop stops.
'filePath = "U:\SSL\Images\" ' The location on your desktop of the images.
' Specify when to stop the loop (this is needed as there are spaces between the cells ' so you need to tell excel when to finish and not look forever.
For Each X In Range(inputCell + "1", Range(inputCell & stopRow).End(xlUp))
' If the value of the cell is empty move on to the next one.
If X <> "" And X.RowHeight <> 0 Then
' Set the image output to be the outputcell specified above on the same row.
Range(outputCell & X.Row).Select
' Check to see if the image exists, if not move on and ignore
On Error Resume Next
If Dir(filePath + X) <> "" Then
' If the iamge exists insert the picture.
With ActiveSheet.Pictures.Insert(filePath + X).Select
' Once the image is inserted, using the aspect ratio change the width to a specified value
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Width = imageWidth
.ShapeRange.Height = imageHeight
.PrintObject = msoTrue
.Placement = xlMoveAndSize
End With
End If
On Error GoTo 0
End If
NextX:
Next X
Application.CommandBars("Format Object").Visible = False
Range("B3").Select
Dim pic As Picture
Dim Rng As Range
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Summary")
Set Rng = ws.Range("A5:Z5000")
Dim CellTopLeft As Range
For Each pic In ws.Pictures
With pic
Set CellTopLeft = .TopLeftCell
If CellTopLeft.Column <> 7 Then Set CellTopLeft = CellTopLeft.EntireRow.Cells(1, 7) '*****This statement added
If Not Intersect(Rng, CellTopLeft) Is Nothing Then
.Top = (CellTopLeft.Top + CellTopLeft.Height / 2) - .Height / 2
.Left = (CellTopLeft.Left + CellTopLeft.Width / 2) - .Width / 2
End If
End With
Next
On Error GoTo 0
Range("B2").Select
End Sub
ASKER
Yes, in excel. Looking for a piece of vba code that will centre images I am importing into cells (through vba)
Hope you are able to help!
Paul