Solved

Aligning graphics top left in the target cell after rotation using VBA

Posted on 2013-11-12
13
690 Views
Last Modified: 2013-11-15
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

0
Comment
Question by:AndreasHermle
  • 7
  • 2
  • 2
  • +1
13 Comments
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 39643888
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
0
 

Author Comment

by:AndreasHermle
ID: 39644000
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
0
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 39644148
When you select one of the rotated images, does the top left of the selection appear over the top left of the cell?
0
Active Directory Webinar

We all know we need to protect and secure our privileges, but where to start? Join Experts Exchange and ManageEngine on Tuesday, April 11, 2017 10:00 AM PDT to learn how to track and secure privileged users in Active Directory.

 

Author Comment

by:AndreasHermle
ID: 39644217
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
0
 
LVL 85

Assisted Solution

by:Rory Archibald
Rory Archibald earned 250 total points
ID: 39644264
Try this:
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)
      With Image
         If .Height > Application.CentimetersToPoints(4) Then _
                  .ShapeRange.ScaleHeight Application.CentimetersToPoints(4) / .Height, msoCTrue

         If .Height > .Width Then
            With .ShapeRange
               .Rotation = 90
               .IncrementLeft .Height / 2 - .Width / 2
               .IncrementTop .Width / 2 - .Height / 2
            End With

         End If
      End With
   Next
End Sub

Open in new window

0
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 39644266
Can you upload a small sample for testing?
0
 
LVL 50

Expert Comment

by:Rgonzo1971
ID: 39644286
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
0
 

Author Comment

by:AndreasHermle
ID: 39645139
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
0
 

Author Comment

by:AndreasHermle
ID: 39645772
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
0
 

Author Comment

by:AndreasHermle
ID: 39650500
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
0
 
LVL 50

Accepted Solution

by:
Rgonzo1971 earned 250 total points
ID: 39650525
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
            Image.TopLeftCell.RowHeight = Image.Width
        Else
            If Image.Height > Application.CentimetersToPoints(4) Then
                Image.Height = Application.CentimetersToPoints(4)
                Image.TopLeftCell.RowHeight = Image.Height
            End If
        End If
    Next

End Sub

Open in new window

0
 

Author Comment

by:AndreasHermle
ID: 39650772
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
0
 

Author Closing Comment

by:AndreasHermle
ID: 39650977
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
0

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

830 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question