Macro to popup pictures not working in 2007

[johnjohns]

I have written a macro to pop up an image (jpg) at the top of the excel sheet as per the content of the cell.
For example if the cell content is abcd xyz the picture abcd.jpg will popup. It is working perfectly in excel 2003 and in 2007 the picture size is irregular - too small to very large. Can somebody help. Following is the code in 2003

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   Dim PicWd As Single
   Dim PicHt As Single
   Dim PicLt As Single
   Dim PicTp As Single
   Dim RowWidth As Integer
   Dim SizeOfFont As Integer
   Dim Position As Integer
   Dim TheDirectory1 As String
   Dim TheDirectory2 As String
   Dim StrPicFile
   On Error Resume Next
   If ActiveCell.Column <= 12 And Not IsEmpty(ActiveCell) Then
      ActiveSheet.Shapes("Mypicture").Delete
      TheDirectory01 = "X:\reports\AllPhotosW09\"
      TheDirectory02 = "Y:\reports\AllPhotosW09\"
      Application.ScreenUpdating = False
      Position = InStr(1, Trim(ActiveCell.Value), " ")
      If Position = 0 Then Position = InStr(1, Trim(ActiveCell.Value), "-")
      If Position = 0 Then Position = InStr(1, Trim(ActiveCell.Value), "/")
      If Not Position = 0 Then
           BuyerCode = Left(Trim(ActiveCell.Value), Position - 1)
       Else
           BuyerCode = Trim(ActiveCell.Value)
      End If
      StrPicFile = TheDirectory01 & Trim(BuyerCode) & ".jpg"
      If Not (Dir(StrPicFile) > "") Then
         StrPicFile = TheDirectory02 & Trim(BuyerCode) & ".jpg"
      End If
      If (Dir(StrPicFile) > "") And ActiveSheet.Name = "Style" Then
              ActiveSheet.Pictures.Insert(StrPicFile).Select
              Selection.ShapeRange.ScaleWidth 1#, msoFalse, msoScaleFromTopLeft
              Selection.ShapeRange.ScaleHeight 1#, msoFalse, msoScaleFromTopLeft
              Selection.Name = "Mypicture"
              HeightRatio = 200 / Selection.Height
              Selection.Left = Cells(1, 2).Left
              Selection.Top = Cells(1, 2).Top
              Selection.Width = Selection.Width * HeightRatio
              Selection.Height = Selection.Height * HeightRatio
              ActiveCell.Select
      End If
      ActiveSheet.Calculate
   End If
End Sub

[johnjohns]

Hello

Just renewing my standing request in my previous thread. The excel 2003 macro I have written for poping up pictures is not working (properly) in 2007 version

https://www.excelforum.com/showthread.php?t=695528

[johnjohns]

I would appreciate even if somebody confirms that it is not a possible thing and suggests me an alternate solution (like using forms and displaying the photos). As we are mostly using 2007 excel, this has become an urgent requirement and any solution is highly appreciated.

best regards

johnjohns

[Andy Pope]

No need to start a new thread you can simply bump the existing one.

Try the following, I have assumed you did not want the aspect ratio locked.

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   Dim PicWd As Single
   Dim PicHt As Single
   Dim PicLt As Single
   Dim PicTp As Single
   Dim RowWidth As Integer
   Dim SizeOfFont As Integer
   Dim Position As Integer
   Dim TheDirectory1 As String
   Dim TheDirectory2 As String
   Dim StrPicFile
   
   On Error Resume Next
   If ActiveCell.Column <= 12 And Not IsEmpty(ActiveCell) Then
      ActiveSheet.Shapes("Mypicture").Delete
      TheDirectory01 = "C:\temp\"
      TheDirectory02 = "Y:\reports\AllPhotosW09\"
  '    Application.ScreenUpdating = False
      Position = InStr(1, Trim(ActiveCell.Value), " ")
      If Position = 0 Then Position = InStr(1, Trim(ActiveCell.Value), "-")
      If Position = 0 Then Position = InStr(1, Trim(ActiveCell.Value), "/")
      If Not Position = 0 Then
           BuyerCode = Left(Trim(ActiveCell.Value), Position - 1)
       Else
           BuyerCode = Trim(ActiveCell.Value)
      End If
      StrPicFile = TheDirectory01 & Trim(BuyerCode) & ".jpg"
      If Not (Dir(StrPicFile) > "") Then
         StrPicFile = TheDirectory02 & Trim(BuyerCode) & ".jpg"
      End If
      On Error GoTo 0
      If (Dir(StrPicFile) > "") And ActiveSheet.Name = "Style" Then
        Sh.Pictures.Insert (StrPicFile)
        With Sh.Shapes(Sh.Shapes.Count)
          .LockAspectRatio = False
          .ScaleWidth 1#, msoFalse, msoScaleFromTopLeft
          .ScaleHeight 1#, msoFalse, msoScaleFromTopLeft
          .Name = "Mypicture"
          heightratio = 200 / .Height
          .Left = Cells(1, 2).Left
          .Top = Cells(1, 2).Top
          .Width = .Width * heightratio
          .Height = .Height * heightratio
        End With
      End If
      ActiveSheet.Calculate
   End If
End Sub

[johnjohns]

Hi Andy Pope

Perfect. It works. Thanks a million!! Beleive me, I was trying a solution for this for the last one year!! And we had to keep excel 2003 in around a 40 PC's only for this picture popup. In fact you helped all of us. Thank you

best regards

johnjohns

[tnieves]

I'm having a similar problem. This macro was created using Excel 2003 and populated a report with pictures in column B based on the style numbers listed in column A. It used to work perfectly before, but now when I run it all of the pictures populate into the same cell. Can anyone help me figure out how to make sure it populates each row in the range instead?

Here is the code:

Sub InsertPhoto()

Dim i As Integer
Dim all_std As Integer
all_std = ActiveSheet.UsedRange.Rows.Count
On Error GoTo Close_Error
Dim x As Integer
x = 2

For i = x To all_std + 1
  
    Cells(i, 2).Select
    ActiveSheet.Pictures.Insert( _
        "S:\COMMON-IBD\IBD-SHARED\Merchandising\APAC STYLE IMAGES\" & Cells(i, 1) & ".jpg").Select
    Selection.ShapeRange.IncrementLeft 150
    Selection.ShapeRange.IncrementTop 20#
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.Height = 55
    Selection.ShapeRange.Width = 55
    Selection.ShapeRange.Rotation = 0#

x = x + 1


Next i

Close_Error:

i = x
Resume Next
End Sub

[jeffreybrown]

Welcome to the Forum, unfortunately:

Your post does not comply with Rule 2 of our Forum RULES. Don't post a question in the thread of another member -- start your own thread. If you feel it's particularly relevant, provide a link to the other thread. It makes sense to have a new thread for your question because a thread with numerous replies can be off putting & difficult to pick out relevant replies.

Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code. Posting code without them makes your code hard to read and difficult to be copied for testing. Highlight your code and click the # at the top of your post window. For more information about these and other tags, found here