Help Centering Image VBA

[Kristie390]

Please help.
I currently am using the below to insert a picture but it is now going top left. I would like to have this resized to auto fit in the cell with the row height 125.
Can someone please help me here? I have researched a few places online and keep getting an error. VBA newbie here..




With Range(BCell)


Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)


.RowHeight = 125

myPict.Top = .Top
myPict.Left = .Left
myPict.Placement = xlMoveAndSize


myPict.Height = 115


End With

 

[shg]

Sub Kristie()
  ' inserts the picture files listed in col A into the workbook,
  ' and sizes and centers in col B

  Const sPath       As String = "S:\Images\Casio"
  'Const sPath       As String = "C:\Users\shg\Pictures\shg"
  Dim cell          As Range
  Dim sFile         As String
  Dim oPic          As Picture

  For Each cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    sFile = sPath & cell.Text & ".jpg"
    If Len(Dir(sFile)) Then
      Set oPic = ActiveSheet.Pictures.Insert(sFile)
      oPic.ShapeRange.LockAspectRatio = msoTrue

      With cell.Offset(, 1)
        If oPic.Height > .Height Then oPic.Height = .Height
        If oPic.Width > .Width Then oPic.Width = .Width
        
        oPic.Top = .Top + .Height / 2 - oPic.Height / 2
        oPic.Left = .Left + .Width / 2 - oPic.Width / 2
      End With
    Else
      cell.Select
      MsgBox sFile & " not found"
    End If
  Next cell
End Sub

The code doesn't scale the picture up if it fills neither dimension.

 

[Kristie390]

This looks fantastic! Thank you very much!

 

[shg]

You're welcome.

 

[Kristie390]

Sorry to be a pest here... but the issue we run into is that if we send this sheet outside of our organization- obviously the links wont work. Is there a way to embed these as they are inserted so that they are inserted as pictures that can be seen without the need to link to the server drive?

 

[Kristie390]

Sorry to bring this back up again, but is there a way to ask it to search for other formats besides just .jpg? So I would need .png , .gif or .bmp but preferably search for .jpg first.
Is that possible?

Sub Kristie()
  ' inserts the picture files listed in col A into the workbook,
  ' and sizes and centers in col B

  Const sPath       As String = "S:\Images\Casio"
  'Const sPath       As String = "C:\Users\shg\Pictures\shg"
  Dim cell          As Range
  Dim sFile         As String
  Dim oPic          As Picture

  For Each cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    sFile = sPath & cell.Text & ".jpg"
    If Len(Dir(sFile)) Then
      Set oPic = ActiveSheet.Pictures.Insert(sFile)
      oPic.ShapeRange.LockAspectRatio = msoTrue

      With cell.Offset(, 1)
        If oPic.Height > .Height Then oPic.Height = .Height
        If oPic.Width > .Width Then oPic.Width = .Width
        
        oPic.Top = .Top + .Height / 2 - oPic.Height / 2
        oPic.Left = .Left + .Width / 2 - oPic.Width / 2
      End With
    Else
      cell.Select
      MsgBox sFile & " not found"
    End If
  Next cell
End Sub

The code doesn't scale the picture up if it fills neither dimension.

 

[Yongle]

I think this should work for you

Replace this line

sFile = sPath & cell.Text & ".jpg"

with

sfile = AddExt(sPath & cell.Text)

and add this function in the same module as the sub

Private Function AddExt(aPath)
    Dim ext As String
    Select Case True
        Case Len(Dir(aPath & ".jpg")):      ext = ".jpg"
        Case Len(Dir(aPath & ".png")):      ext = ".png"
        Case Len(Dir(aPath & ".gif")):      ext = ".gif"
        Case Else:                          ext = ".bmp"
    End Select
    AddExt = aPath & ext
End Function

 

[Kristie390]

Thank you.
I added the path and tried to place the function in a few different places but I cant get it to work. Where would the best location to place?
After what?

I think this should work for you

Replace this line

sFile = sPath & cell.Text & ".jpg"

with

sfile = AddExt(sPath & cell.Text)

and add this function in the same module as the sub

Private Function AddExt(aPath)
    Dim ext As String
    Select Case True
        Case Len(Dir(aPath & ".jpg")):      ext = ".jpg"
        Case Len(Dir(aPath & ".png")):      ext = ".png"
        Case Len(Dir(aPath & ".gif")):      ext = ".gif"
        Case Else:                          ext = ".bmp"
    End Select
    AddExt = aPath & ext
End Function

 

[Yongle]

I added the path and tried to place the function in a few different places but I cant get it to work. Where would the best location to place?

- the new line will only work where stated previously
- simply replace the one line with the other
- the function must be placed in the same module as the code which is making use of it
- place it AFTER End Sub - it is a new procedure
- Private (before Function) makes it only available to procedures in that module

I tested the function at the time and it worked for me
I vaguely remember looking at your code wondering where the final "path separator" was (ie the one before the file name)
- but assumed that your posted code took account of it somehow

However, there is a problem with a few characters "disappearing" when uploaded to the forum - it's a security related issue. One of the problem characters happens to be the path separator (but only sometimes )


Hopefully putting the function in the correct place sorts your problem. But if not ...

There must be a path separator immediately before the filename

Do the following...

Test the strings generated by the function as follows

below this line

sfile = AddExt(sPath & cell.Text)

insert these 2 lines (on a temporary basis)

MsgBox sFile
Exit Sub

Does message box string for sFile contain a path separator immediately before the filename?
Is cell.Text is simply the filename ?

 

[Kristie390]

Ok, thank you for your reply. Here is what I did and here is what I got

 

[Yongle]

Where did you place the function? VBA cannot see it

Try this which should work
- paste the function into a standard module and remove the word Private