Vba to inset an change picture

KlausW

Active Member
Joined
Sep 9, 2020
Messages
453
Office Version
  1. 2016
Platform
  1. Windows
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

VBA Code:
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

VBA Code:
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
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Hi Klaus W,
Here is a sample code.
VBA 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
 
Upvote 0
Solution
Hi Klaus W,
Here is a sample code.
VBA 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
 
Upvote 0

Forum statistics

Threads
1,223,939
Messages
6,175,533
Members
452,652
Latest member
eduedu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top