Macro for inserting pictures bug

[grigori28]

Hi guys,

I have the following macro which works as follows: once run, it reads the product codes (e.g. 12381-1231) in column B and inserts corresponding product pictures from another folder to the excel file. Now the problem is that even when I save the document and then send it to others, they can not see the pictures.

Does anyone have a clue what I am doing wrong? Here is the code:

Sub InsertPics()

Dim Rw&, PFAD$, Datei$, Bild As Shape

PFAD = "\\levi.com\ls\Regional\LSE\BRU\DATA\Merchandising\H2'18\6. VLP\PICTURES"
With ActiveSheet
For Rw = 2 To 100
Datei = .Range("B" & Rw) & ".jpg"
If Dir(PFAD & Datei) <> vbNullString Then
.Pictures.Insert (PFAD & Datei)
Set Bild = .Shapes(.Shapes.Count)
Bild.LockAspectRatio = msoFalse
Bild.Left = .Range("A" & Rw).Left
Bild.Top = .Range("A" & Rw).Top
Bild.Width = .Range("A" & Rw).Width
Bild.Height = .Range("A" & Rw).Height
End If
Next
End With
End Sub

 

[Domenic]

Use the AddPicture method of the Shapes object instead. As per Excel's help file...

[U][B]S​yntax[/B][/U]

expression[B].AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)[/B]


expression   A variable that represents a [B]Shapes[/B] object.

Maybe something like this...

Sub InsertPics()

    Dim LastRow&, Rw&, PFAD$, Datei$, Bild As Shape
    
    PFAD = "\\levi.com\ls\Regional\LSE\BRU\DATA\Merchandising\H2'18\6. VLP\PICTURES\" 'added backslash to path, but remove if it isn't needed
    
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For Rw = 2 To LastRow
            Datei = .Range("B" & Rw).Value & ".jpg"
            If Dir(PFAD & Datei) <> vbNullString Then
                Set Bild = .Shapes.AddPicture( _
                    Filename:=PFAD & Datei, _
                    LinkToFile:=msoFalse, _
                    SaveWithDocument:=msoTrue, _
                    Left:=.Range("A" & Rw).Left, _
                    Top:=.Range("A" & Rw).Top, _
                    Width:=.Range("A" & Rw).Width, _
                    Height:=.Range("A" & Rw).Height)
            End If
        Next
    End With
    
End Sub

Hope this helps!

 

[grigori28]

Hi Domenic,

thanks a lot for your help.

It works perfectly .

Best
Grigor