Vba to inset an change picture

[KlausW]

Hi
I am using the first part of the code to copy names of pictures that I want to inset. The next code, inset pictures. The pictures name a standing from B2 and down.
I got 3 things that I want Excel to do.
First. When I run the VBA-code Excel inset pictures, the name of it stands in B2 and down, but it also put in allot of pictures that’s not pictures. Whit this text in, "The linked image cannot be displayed. The file may have been moved, renamed or deleted."
Secund. I should like to inset different kind of picture format, like *.jpg and *.png
Third. I should like to center the picture in the cell an reseize it to 13x16 cm.
Al help will be appreciated.
Klaus W

Sub Bilag_Rektangelafrundedehjørner1_Klik()

'Copy the data
Sheets("Stamdata").Range("p9:p16").Copy
Sheets("Bilag").Range("b2").PasteSpecial Paste:=xlPasteValues


Application.CutCopyMode = False
Call Rektangelafrundedehjørner3_Klik

End Sub

Sub Rektangelafrundedehjørner3_Klik()

Dim pictname As String
Dim pastehere As Range
Dim pasterow As Long
Dim x As Long
Dim lastrow As Long

lastrow = Worksheets("Bilag").Range("B1").CurrentRegion.Rows.Count
x = 2
For x = 2 To lastrow
Set pastehere = Cells(x, 1)
pasterow = pastehere.Row
Cells(pasterow, 1).Select 'This is where picture will be inserted

pictname = Cells(x, 2) 'This is the picture name
ActiveSheet.Pictures.Insert("C:\Users\k-wit\OneDrive\F-div\Rejseafregning\Bilag\" & pictname & ".png").Select 'Path to where pictures are stored

With Selection

.Left = Cells(pasterow, 2).Left + (Cells(pasterow, 3).Width - .Width / 1)
.Top = Cells(pasterow, 2).Top + (Cells(pasterow, 1).Height - .Height / 1.1)

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 370#
.ShapeRange.Width = 470#
.ShapeRange.Rotation = 0#
End With

Next


End Sub

 

[Colo]

Hi Klaus W,
Here is a sample code.

Sub Rektangelafrundedehjorner3_Klik()
    Const sPath As String = "C:\Users\k-wit\OneDrive\F-div\Rejseafregning\Bilag\" 'Path to where pictures are stored
    Const sPicSizeW As Single = 16 'CM
    Const sPicSizeH As Single = 13 'CM
    Dim sPictName As String, sExt As String
    Dim oShape As Object, sLeftPos As Single, sTopPos As Single
    Dim x As Long
    
    With Worksheets("Bilag")
        For x = 2 To .Range("B1").CurrentRegion.Rows.Count
            sPictName = sPath & Cells(x, 2).Value    'This is the picture name
            'Check if the file exists with extensions like PNG, JPG, JPEG
            If Dir(sPictName & ".png") <> "" Then sExt = ".png"
            If Dir(sPictName & ".jpg") <> "" Then sExt = ".jpg"
            If Dir(sPictName & ".jpeg") <> "" Then sExt = ".jpeg"
            If sExt = "" Then GoTo Skip
            sPictName = sPictName & sExt

            'This is the position where the picture will be inserted
            sLeftPos = Cells(x, 1).Left + (Cells(x, 1).Width - Application.CentimetersToPoints(sPicSizeW)) / 2
            sTopPos = Cells(x, 1).Top + (Cells(x, 1).Height - Application.CentimetersToPoints(sPicSizeH)) / 2

            Set oShape = .Shapes.AddPicture( _
                         Filename:=sPictName, _
                         LinkToFile:=False, _
                         SaveWithDocument:=True, _
                         Left:=sLeftPos, _
                         Top:=sTopPos, _
                         Width:=Application.Application.CentimetersToPoints(sPicSizeW), _
                         Height:=Application.Application.CentimetersToPoints(sPicSizeH))
Skip:
        Next
    End With
End Sub

 

[KlausW]

Hi Klaus W,
Here is a sample code.

Sub Rektangelafrundedehjorner3_Klik()
    Const sPath As String = "C:\Users\k-wit\OneDrive\F-div\Rejseafregning\Bilag\" 'Path to where pictures are stored
    Const sPicSizeW As Single = 16 'CM
    Const sPicSizeH As Single = 13 'CM
    Dim sPictName As String, sExt As String
    Dim oShape As Object, sLeftPos As Single, sTopPos As Single
    Dim x As Long
   
    With Worksheets("Bilag")
        For x = 2 To .Range("B1").CurrentRegion.Rows.Count
            sPictName = sPath & Cells(x, 2).Value    'This is the picture name
            'Check if the file exists with extensions like PNG, JPG, JPEG
            If Dir(sPictName & ".png") <> "" Then sExt = ".png"
            If Dir(sPictName & ".jpg") <> "" Then sExt = ".jpg"
            If Dir(sPictName & ".jpeg") <> "" Then sExt = ".jpeg"
            If sExt = "" Then GoTo Skip
            sPictName = sPictName & sExt

            'This is the position where the picture will be inserted
            sLeftPos = Cells(x, 1).Left + (Cells(x, 1).Width - Application.CentimetersToPoints(sPicSizeW)) / 2
            sTopPos = Cells(x, 1).Top + (Cells(x, 1).Height - Application.CentimetersToPoints(sPicSizeH)) / 2

            Set oShape = .Shapes.AddPicture( _
                         Filename:=sPictName, _
                         LinkToFile:=False, _
                         SaveWithDocument:=True, _
                         Left:=sLeftPos, _
                         Top:=sTopPos, _
                         Width:=Application.Application.CentimetersToPoints(sPicSizeW), _
                         Height:=Application.Application.CentimetersToPoints(sPicSizeH))
Skip:
        Next
    End With
End Sub

Hi Colo Thanks a lot, that's just the way it should be. Have a nice day and thanks again. Best regards Klaus W