none
Picture Insert Issue in Excel RRS feed

  • Question

  • Hello,

    I'm looking for some help. I have a Maco that I use to insert a picture into a selected cell.  The issue I'm having is the picture doesn't always put the picture inside the box, it's off centered. For example when I select O9 it doesn't fit the picture within that cell. 

    Any help would be greatly appreciated

    

    Sub Button5_Click()
    
    
        Dim myR As Range
        Dim shpPic As Shape
        Dim strName As String
        Dim strPicLoc As String
        Dim myScale As Double
        
        strPicLoc = Application.GetOpenFilename(FileFilter:="shpPic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
        Set myR = Application.InputBox("Click in the cell to hold the picture", Type:=8)
        strName = "shpPic"
        myR.EntireRow.RowHeight = 225
        myR.EntireColumn.ColumnWidth = 60
        
        'Insert the picture
        On Error Resume Next
        ActiveSheet.Shapes(strName & myR.Address).Delete
        On Error GoTo 0
        Set shpPic = ActiveSheet.Shapes.AddPicture(Filename:=strPicLoc, _
        linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=myR.Left, Top:=myR.Top, Width:=-1, Height:=-1)
        shpPic.Name = strName & myR.Address
       
        'New line to fix rotation of the picture
        If shpPic.Rotation <> 0 Then shpPic.IncrementRotation -shpPic.Rotation
        
        'Optional code to scale the picture to the width/height of the cell and center
        myScale = Application.Min(myR.Width / shpPic.Width, _
                                  myR.Height / shpPic.Height)
        If myR.Width / shpPic.Width > myR.Height / shpPic.Height Then
            shpPic.ScaleWidth myScale, msoFalse, msoScaleFromTopLeft
        Else
            shpPic.ScaleHeight myScale, msoFalse, msoScaleFromTopLeft
        End If
        'Optional code to center picture horizonatally and vertically
        If myR.Width > shpPic.Width Then shpPic.IncrementLeft (myR.Width - shpPic.Width) / 2
        If myR.Height > shpPic.Height Then shpPic.IncrementTop (myR.Height - shpPic.Height) / 2
    End Sub
    

    Thursday, January 5, 2017 1:36 PM

All replies

  • Function InsertPicture(ByVal FName As String, ByVal Where As Range, _
        Optional ByVal LinkToFile As Boolean = False, _
        Optional ByVal SaveWithDocument As Boolean = True, _
        Optional ByVal LockAspectRatio As Boolean = True) As Shape
      'Inserts the picture file FName as link or permanently into Where
      Dim s As Shape, SaveScreenUpdating, SaveCursor
      SaveCursor = Application.cursor
      SaveScreenUpdating = Application.ScreenUpdating
      Application.cursor = xlWait
      Application.ScreenUpdating = False
      With Where
        'Insert in original size
        Set s = Where.Parent.Shapes.AddPicture( _
          FName, LinkToFile, SaveWithDocument, .Left, .Top, -1, -1)
        'Keep the proportions?
        s.LockAspectRatio = LockAspectRatio
        'Scale it to fit the cell
        s.Width = .Width
        If s.Height > .Height Or Not LockAspectRatio Then s.Height = .Height
        'Move it to the middle of the cells
        If s.Width < Where.Width Then s.Left = Where.Left + (Where.Width - s.Width) / 2
        If s.Height < Where.Height Then s.Top = Where.Top + (Where.Height - s.Height) / 2
      End With
      Set InsertPicture = s
      Application.cursor = SaveCursor
      Application.ScreenUpdating = SaveScreenUpdating
    End Function
    Thursday, January 5, 2017 2:08 PM
  • Andreas,

    Sorry, I'm not good with Macro's.  How do I incorporate this into my original code?  I'm not sure what to include or remove.


    Thursday, January 5, 2017 2:51 PM
  • You don't need any code in the button anymore, just call the function with the arguments.

    Andreas.

    Sub Button5_Click()
        Dim myR As Range
        Dim shpPic As Shape
        Dim strPicLoc As String
        
        strPicLoc = Application.GetOpenFilename(FileFilter:="shpPic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
        Set myR = Application.InputBox("Click in the cell to hold the picture", Type:=8)
        Set shpPic = InsertPicture(strPicLoc, myR)
    End Sub

    Thursday, January 5, 2017 3:41 PM
  • Hi LCodd6,

    I try to refer the suggestion provided by Andreas Killer.

    I think that it is exactly working as per your requirement. it can fulfil your requirement.

    I got output below.

    if you think that it can solve your issue then mark the suggestion given by Andreas Killer as an answer.

    if you have any further question then let us know about that.

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, January 6, 2017 2:36 AM
    Moderator
  • Sorry,

    It doesn't seem to be working.

    Friday, January 6, 2017 12:17 PM
  • Sorry,

    It doesn't seem to be working.

    You can be sure that the code works, I test all my codes before I post them.

    If you need further help please upload your file (maybe with anonymous data) on an online file hoster like www.dropbox.com and post the download link here.

    A macro to anonymize data in selected cells can be downloaded here:
    https://dl.dropboxusercontent.com/u/35239054/modAnonymize.bas

    Andreas.

    Friday, January 6, 2017 1:34 PM
  • Tricky?  lol
    Saturday, January 7, 2017 11:02 AM
  • Tricky?  lol

    Seems to be... the file did not contain the code from above. Joking?
    Saturday, January 7, 2017 5:39 PM
  • Sorry, I uploaded the old file. sorry
    Saturday, January 7, 2017 5:40 PM
  • Sorry, I uploaded the old file. sorry

    You did not changed the uploaded file, I guess the issue is gone after you've copied the code from above into the file?

    Andreas.

    Sunday, January 8, 2017 4:35 PM
  • Hi LCodd6,

    we had find that you posted an another file by mistakenly.

    did the issue solved?

    I find that you did not give any reply to Andreas Killer 's last post.

    if your issue is solved then mark the suggestion given by Andreas Killer as an Answer and help us to close this thread.

    if you still have a problem then please update the status of this thread.

    so that we can know about that and try to give you suggestion.

    if you got the solution by yourself then please try to post it on this thread, in future it will help others.

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Monday, January 9, 2017 6:42 AM
    Moderator
  • Sorry,

    I have updated the correct file with the code suggested.

    https://www.dropbox.com/s/bumlfn66xzaxf8j/Report%20Bi-Weekly_11-4-16.xlsm?dl=0

     

    Monday, January 9, 2017 3:33 PM
  • I have updated the correct file with the code suggested.

    Alright, I see...

    Add this line at the top of the module
      Option Explicit
    then in the menu click Debug\Compile and you'll get an error. Do you see what's missing?

    Andreas.

    Monday, January 9, 2017 6:02 PM
  • I'm sorry I don't know much about Macro's.  I don't understand what you are saying. 

    What I assume your saying is to do this but I still get an error.

    Option Explicit
    Sub Button5_Click()
        Dim myR As Range
        Dim shpPic As Shape
        Dim strPicLoc As String
        
        strPicLoc = Application.GetOpenFilename(FileFilter:="shpPic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
        Set myR = Application.InputBox("Click in the cell to hold the picture", Type:=8)
        Set shpPic = InsertPicture(strPicLoc, myR)
    End Sub
    

    Monday, January 9, 2017 6:46 PM
  • Hi LCodd6,

    I try to look in to your workbook.

    I find below.

    your code is in "Module1". so why you named your sub as Button5_Click.

    There is no Button5. change it to any other name.

    or create a button on a sheet and paste this code on its click event.

    other thing , where is the InsertPicture() Function code.

    I did not find code for InsertPicture() Function anywhere in your workbook.

    you need to add this code and then try to call it.

    if the Function is not exist and you trying to call it and want it to work then how it will work.

    when you try to use the code from any suggestion then you need to make necessary changes to work with your environment.

    so please try to add the button click. then add the code for function and call it on button's click event.

    it will work.

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Tuesday, January 10, 2017 3:07 AM
    Moderator
  • I did not find code for InsertPicture() Function anywhere in your workbook.

    In addition, to be clear: You have to copy the Function InsertPicture from above into the same code module.

    Andreas.

    Tuesday, January 10, 2017 8:05 AM