Aligning graphics top left in the target cell after rotation using VBA
Dear Experts:
Below macro, courtesy of Rgonzo1971, batch inserts pictures in Column D. The network paths of these pictures are located in Column C.
The macro works just fine and I was able to tweak it a little bit ...
... i.e. I also integrated an image rotation action for certain images.
The trouble is that the images get rotated around its centers and afterwards the graphics are not aligned top left anymore as are the other pictures.
Has anybody a solution to this problem?
Help is much appreciated. Thank you very much in advance.
Regards, Andreas
Below macro, courtesy of Rgonzo1971, batch inserts pictures in Column D. The network paths of these pictures are located in Column C.
The macro works just fine and I was able to tweak it a little bit ...
... i.e. I also integrated an image rotation action for certain images.
The trouble is that the images get rotated around its centers and afterwards the graphics are not aligned top left anymore as are the other pictures.
Has anybody a solution to this problem?
Help is much appreciated. Thank you very much in advance.
Regards, Andreas
Sub InsertPictures()
'
' by Rgonzo, EE
'
Dim c As Range
Dim Image As Picture
'
For Each c In Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
c.Offset(0, 1).Activate
Set Image = ActiveSheet.Pictures.Insert(c.Value2)
If Image.Height > Image.Width Then
Image.ShapeRange.Rotation = 90
If Image.Height > Application.CentimetersToPoints(4) Then
Image.Height = Application.CentimetersToPoints(4)
End If
End If
Next
End Sub
Try this modification
Sub InsertPictures()
'
' by Rgonzo, EE
'
Dim c As Range
Dim Image As Picture
'
For Each c In Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
c.Offset(0, 1).Activate
Set Image = ActiveSheet.Pictures.Inser
Imtop=image.top
Imleft=image.left
If Image.Height > Image.Width Then
Image.ShapeRange.Rotation = 90
If Image.Height > Application.CentimetersToP
Image.Height = Application.CentimetersToP
End If
End If
image.top=Imtop
image.left=Imleft
Next
End Sub
Sub InsertPictures()
'
' by Rgonzo, EE
'
Dim c As Range
Dim Image As Picture
'
For Each c In Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
c.Offset(0, 1).Activate
Set Image = ActiveSheet.Pictures.Inser
Imtop=image.top
Imleft=image.left
If Image.Height > Image.Width Then
Image.ShapeRange.Rotation = 90
If Image.Height > Application.CentimetersToP
Image.Height = Application.CentimetersToP
End If
End If
image.top=Imtop
image.left=Imleft
Next
End Sub
Hi Rgonzo,
thank you very much for your quick and professional help.
Although this looks very logical to me, it actually does not do anything.
Any idea why ?
A quick search on the internet on a similar subject produced a code snippet that -at least- repositioned the graphics to various degrees to the right (still with the top alignment)
Image.ShapeRange.Increment
Image.ShapeRange.Increment
Regards, Andreas
thank you very much for your quick and professional help.
Although this looks very logical to me, it actually does not do anything.
Any idea why ?
A quick search on the internet on a similar subject produced a code snippet that -at least- repositioned the graphics to various degrees to the right (still with the top alignment)
Image.ShapeRange.Increment
Image.ShapeRange.Increment
Regards, Andreas
When you select one of the rotated images, does the top left of the selection appear over the top left of the cell?
Hi rorya:
Thank you very much for your quick help:
Assuming running the following macro ID: 39643888
the ones that get rotated are not top aligned anymore but almost centered vertically.
The Horizontal Position is as follows: part of the image (to varying degrees) reach into Column C with most of picture being located in Column D.
See graphic.
![Position_Graphic_Macro]()
Regards, Andreas
Thank you very much for your quick help:
Assuming running the following macro ID: 39643888
the ones that get rotated are not top aligned anymore but almost centered vertically.
The Horizontal Position is as follows: part of the image (to varying degrees) reach into Column C with most of picture being located in Column D.
See graphic.
Regards, Andreas
This one is on us!
(Get your first solution completely free - no credit card required)
UNLOCK SOLUTION
Hi,
pls try
pls try
Sub InsertPictures()
'
' by Rgonzo, EE
'
Dim c As Range
Dim Image As Picture
'
For Each c In Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
c.Offset(0, 1).Activate
Set Image = ActiveSheet.Pictures.Insert(c.Value2)
If Image.Height > Image.Width Then
If Image.Width > Application.CentimetersToPoints(4) Then
Image.Width = Application.CentimetersToPoints(4)
End If
Image.ShapeRange.Rotation = 90
Image.ShapeRange.IncrementTop -(Image.Height - Image.Width) / 2
Image.ShapeRange.IncrementLeft (Image.Height - Image.Width) / 2
Else
If Image.Height > Application.CentimetersToPoints(4) Then
Image.Height = Application.CentimetersToPoints(4)
End If
End If
Next
End Sub
I will not have time to do thorough testing right away.
I will do some testing tomorrow.
Thank you very much for your overwhelming and professional support.
Regards, Andreas
I will do some testing tomorrow.
Thank you very much for your overwhelming and professional support.
Regards, Andreas
Dear both,
thank you very much for your great and professional support. Both codes work just fine.
I am truly impressed with your coding abilities.
I hope you two find it fair if I split the points.
300 go to Rory since he was a bit quicker to answer and
200 go to Rgonzo since he provided the base parts of this code.
Again, thank you very much for your great help.
Regards, Andreas
thank you very much for your great and professional support. Both codes work just fine.
I am truly impressed with your coding abilities.
I hope you two find it fair if I split the points.
300 go to Rory since he was a bit quicker to answer and
200 go to Rgonzo since he provided the base parts of this code.
Again, thank you very much for your great help.
Regards, Andreas
Dear Rgonzo and rorya:
I was gonna award points when I realized there is another requirement that needs to be considered:
Is it possible to adjust the rows so that they match the size of the graphics in Column D. As you know the size of the graphics can vary wildly from 1 to 4 cm.
I could also post this question as a new post.
Regards, Andreas
I was gonna award points when I realized there is another requirement that needs to be considered:
Is it possible to adjust the rows so that they match the size of the graphics in Column D. As you know the size of the graphics can vary wildly from 1 to 4 cm.
I could also post this question as a new post.
Regards, Andreas
This one is on us!
(Get your first solution completely free - no credit card required)
UNLOCK SOLUTION
Join our community and discover your potential
Experts Exchange is the only place where you can interact directly with leading experts in the technology field. Become a member today and access the collective knowledge of thousands of technology experts.
*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.