Centering image (horizontally) in Range

Hello,

Excuse me if I'm asking a simple question, but I'm a bit of a noob when it comes to VBA. As a matter of fact I live on Copy and Paste and sometimes I actually understand what I've copied and I'm able to adjust it to my needs. In this manner I have made an excel file that imports pictures from my harddisk into a named Range. I have tried many other sites for an answer. I have however not been able to center the images horizontally (width of different images varies) in that Range.

I would be very gratefull if someone could help me with this.

Below is the code I have copied and adjusted:

Private Sub Worksheet_Change(ByVal Target As Range)
   Application.ScreenUpdating = False
    If Target.Address = ("$B$3") Then
    Range("B4") = ""
    Range("B5") = ""
    Range("B6") = ""
    End If
    
    If Target.Address = ("$B$4") Then
    Range("B5") = ""
    Range("B6") = ""
    End If
    
    If Target.Address = ("$B$5") Then
    Range("B6") = ""
    End If
    
    If Not Intersect(Target, Range("rngDisplayName1")) Is Nothing Then
         InsertPicFromFile1 _
            strFileLoc:=Range("rngFileLocation1").Value, _
            rDestCells1:=Range("rngPicDisplayCells1"), _
            blnFitInDestHeight:=True, _
            strPicName:="MyDVPic1"
    End If
    
    If Not Intersect(Target, Range("rngDisplayName2")) Is Nothing Then
         InsertPicFromFile2 _
            strFileLoc:=Range("rngFileLocation2").Value, _
            rDestCells2:=Range("rngPicDisplayCells2"), _
            blnFitInDestHeight:=True, _
            strPicName:="MyDVPic2"
    End If
    
    If Not Intersect(Target, Range("rngDisplayName3")) Is Nothing Then
         InsertPicFromFile3 _
            strFileLoc:=Range("rngFileLocation3").Value, _
            rDestCells3:=Range("rngPicDisplayCells3"), _
            blnFitInDestHeight:=True, _
            strPicName:="MyDVPic3"
    End If
   Application.ScreenUpdating = True
End Sub




Sub InsertPicFromFile1( _
   strFileLoc As String, _
   rDestCells1 As Range, _
   blnFitInDestHeight As Boolean, _
   strPicName As String)

   Dim oNewPic As Shape
   Dim shtWS As Worksheet

   Set shtWS = rDestCells1.Parent

   On Error Resume Next
   'Delete the named picture (if it already exists)
   shtWS.Shapes(strPicName).Delete
   
   On Error Resume Next
   With rDestCells1
      'Create the new picture
      '(arbitrarily sized as a square that is the height of the rDestCells)
      Set oNewPic = shtWS.Shapes.AddPicture( _
         Filename:=strFileLoc, _
         LinkToFile:=msoFalse, _
         SaveWithDocument:=msoTrue, _
         Left:=.Left + 1, Top:=.Top + 1, Width:=.Height - 1, Height:=.Height - 1)
      
      'Maintain original aspect ratio and set to full size
      oNewPic.LockAspectRatio = msoTrue
      oNewPic.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
      oNewPic.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
      
      If blnFitInDestHeight = True Then
         'Resize the picture to fit in the destination cells
         oNewPic.Height = .Height - 1
      End If
      
      'Assign the desired name to the picture
      oNewPic.Name = strPicName
   End With 'rCellDest
End Sub

Sub InsertPicFromFile2( _
   strFileLoc As String, _
   rDestCells2 As Range, _
   blnFitInDestHeight As Boolean, _
   strPicName As String)

   Dim oNewPic As Shape
   Dim shtWS As Worksheet

   Set shtWS = rDestCells2.Parent

   On Error Resume Next
   'Delete the named picture (if it already exists)
   shtWS.Shapes(strPicName).Delete
   
   On Error Resume Next
   With rDestCells2
      'Create the new picture
      '(arbitrarily sized as a square that is the height of the rDestCells)
      Set oNewPic = shtWS.Shapes.AddPicture( _
         Filename:=strFileLoc, _
         LinkToFile:=msoFalse, _
         SaveWithDocument:=msoTrue, _
         Left:=.Left + 1, Top:=.Top + 1, Width:=.Height - 1, Height:=.Height - 1)
      
      'Maintain original aspect ratio and set to full size
      oNewPic.LockAspectRatio = msoTrue
      oNewPic.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
      oNewPic.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
      
      If blnFitInDestHeight = True Then
         'Resize the picture to fit in the destination cells
         oNewPic.Height = .Height - 1
      End If
      
      'Assign the desired name to the picture
      oNewPic.Name = strPicName
   End With 'rCellDest
End Sub


Sub InsertPicFromFile3( _
   strFileLoc As String, _
   rDestCells3 As Range, _
   blnFitInDestHeight As Boolean, _
   strPicName As String)

   Dim oNewPic As Shape
   Dim shtWS As Worksheet

   Set shtWS = rDestCells3.Parent

   On Error Resume Next
   'Delete the named picture (if it already exists)
   shtWS.Shapes(strPicName).Delete
   
   On Error Resume Next
   With rDestCells3
      'Create the new picture
      '(arbitrarily sized as a square that is the height of the rDestCells)
      Set oNewPic = shtWS.Shapes.AddPicture( _
         Filename:=strFileLoc, _
         LinkToFile:=msoFalse, _
         SaveWithDocument:=msoTrue, _
         Left:=.Left + 1, Top:=.Top + 1, Width:=.Height - 1, Height:=.Height - 1)
      
      'Maintain original aspect ratio and set to full size
      oNewPic.LockAspectRatio = msoTrue
      oNewPic.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
      oNewPic.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
      
      If blnFitInDestHeight = True Then
         'Resize the picture to fit in the destination cells
         oNewPic.Height = .Height - 1
      End If
      
      'Assign the desired name to the picture
      oNewPic.Name = strPicName
   End With 'rCellDest
End Sub

Thanks in advance...

Originally Posted by shg

Why do you have three InsertPicFromFile subs?

Because I have three different pictures in three different places in the document. In the end it will be over 20 because it's going to be a fitness training program.

Originally Posted by shg

Do you want the picture fitted to the height of the destination range and centered horizontally?

Yes!

Originally Posted by shg

Whay are you doing this?

Left:=.Left + 1, Top:=.Top + 1, Width:=.Height - 1, Height:=.Height - 1

This part I copied from another excel document, but I don't know how to adjust it to center the picture...

Thanks shg for your effort, but including this code introduces a whole bunch of error codes that I'm not able to eliminate....