VBA Excel: posizionamento, rotazione e ridimensionamento di un'immagine sul foglio

Cosa fare dell'immagine inserita sul foglio Excel?

Va posta sul foglio;
Quindi se l'altezza supera la larghezza va ruotata.
Eseguiamo questi passaggi...

Private Sub CommandButton1_Click()
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "C:\Users\Antonello\Desktop\Immagini Excel"


If fd.Show <> 0 Then ActiveSheet.Pictures.Insert(fd.SelectedItems(1)).Select


End Sub

Quello in rosso è il comando di posizionamento dell'immagine se la FileDialog ha individuato un file.

Bene.
Adesso misuriamo il rapporto fra larghezza e altezza.

Private Sub CommandButton1_Click()
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "C:\Users\Antonello\Desktop\Immagini Excel"


If fd.Show <> 0 Then ActiveSheet.Pictures.Insert(fd.SelectedItems(1)).Select

Dim Ratio As Double
Ratio = Selection.Width / Selection.Height
Debug.Print Ratio

End Sub

Ecco: dopo aver inserito l'immagine sul foglio dichiato la variabile Ratio e con essa misuro il rapporto fra larghezza e altezza dell'immagine stessa, quindi stampo il valore nella finestra immediata.

Ho caricato due foto orizzontali e una verticale e questi sono i valori datimi nella finestra immediata:

 1,78052550231839 
 1,78052550231839 
 0,561631944444444 

Adesso voglio vedere se con la rotazione cambiano altezza e larghezza:

Private Sub CommandButton1_Click()
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "C:\Users\Antonello\Desktop\Immagini Excel"


If fd.Show <> 0 Then ActiveSheet.Pictures.Insert(fd.SelectedItems(1)).Select

Dim Ratio As Double
Ratio = Selection.Width / Selection.Height
Debug.Print Ratio
If Ratio < 1 Then Selection.ShapeRange.IncrementRotation -90#
Ratio = Selection.Width / Selection.Height
Debug.Print "Nuovo rapporto " & Ratio
End Sub

Se l'immagine è più alta che larga, ossia se il rapporto larghezza/altezza è inferiore a 1, l'immagine viene ruotata a sinistra di 90 gradi, quindi si misura di nuovo il rapporto larghezza/altezza e lo si riscrive nella finestra immediata.
Ovviamente, esso è cambiato con la rotazione dell'immagine verticale, mentre con le prime due immagini che ho caricato, orizzontali, che non vengono ruotate, rimane invariato.

 1,78052550231839 
Nuovo rapporto 1,78052550231839
 1,78052550231839 
Nuovo rapporto 1,78052550231839
 0,561631944444444 
Nuovo rapporto 1,78052550231839

Adesso applico la formula per ridimensionare le immagini alle dimensioni volute. Basta moltiplicare Ratio (il rapporto larghezza/altezza) per la nuova altezza per ottenere la nuova larghezza.

Private Sub CommandButton1_Click()
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "C:\Users\Antonello\Desktop\Immagini Excel"


If fd.Show <> 0 Then ActiveSheet.Pictures.Insert(fd.SelectedItems(1)).Select

Dim Ratio As Double
Ratio = Selection.Width / Selection.Height

If Ratio < 1 Then Selection.ShapeRange.IncrementRotation -90#
Ratio = Selection.Width / Selection.Height

Selection.Height = 200
Selection.Width = Ratio * Selection.Height
End Sub

Ecco qui. Funziona.
Ho impostato una nuova altezza per l'immagine, quindi per ottenerne la nuova larghezza moltiplico questa per il rapporto larghezza/altezza.



Invece, se voglio tutte immagini verticali, basta dare il comando di ruotare l'immagine soltanto se il rapporto larghezza/altezza è superiore a 1:

Private Sub CommandButton1_Click()
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "C:\Users\Antonello\Desktop\Immagini Excel"


If fd.Show <> 0 Then ActiveSheet.Pictures.Insert(fd.SelectedItems(1)).Select

Dim Ratio As Double
Ratio = Selection.Width / Selection.Height

If Ratio > 1 Then Selection.ShapeRange.IncrementRotation -90#
Ratio = Selection.Width / Selection.Height

Selection.Height = 200
Selection.Width = Ratio * Selection.Height
End Sub

Ed ecco: