Avatar of Andreas Hermle
Andreas HermleFlag for Germany asked on

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


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

Open in new window

Microsoft Excel

Avatar of undefined
Last Comment
Andreas Hermle

8/22/2022 - Mon
Saqib Husain

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.Insert(c.Value2)
    Imtop=image.top
    Imleft=image.left
   
        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
     image.top=Imtop
     image.left=Imleft
Next
End Sub
ASKER
Andreas Hermle

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.IncrementLeft Image.ShapeRange.Height / 2 - Image.ShapeRange.Width / 2
           Image.ShapeRange.IncrementTop Image.ShapeRange.Width / 2 - Image.ShapeRange.Height / 2

Regards, Andreas
Rory Archibald

When you select one of the rotated images, does the top left of the selection appear over the top left of the cell?
Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!
James Murphy
ASKER
Andreas Hermle

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
SOLUTION
Rory Archibald

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
See how we're fighting big data
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
Saqib Husain

Can you upload a small sample for testing?
Rgonzo1971

Hi,

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 

Open in new window

Regards
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
ASKER
Andreas Hermle

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
ASKER
Andreas Hermle

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
ASKER
Andreas Hermle

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
Your help has saved me hundreds of hours of internet surfing.
fblack61
ASKER CERTIFIED SOLUTION
Log in to continue reading
Log In
Sign up - Free for 7 days
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
ASKER
Andreas Hermle

Hi Rgonzo,

I have tested it on around 50 Excel Records, works great so far. I will do some more testing and then let you know. Thank you very much for your superb help.

Regards, Andreas
ASKER
Andreas Hermle

Thank you very much for your great and professional support.

I really appreciate it. I am so glad I can turn to this forum for real professional help.

Regards, Andreas