Indsætte billeder som bliver gemt med Excel fil - VBA

Jeg tror, at jeg fandt en løsning.

Der skal så vidt jeg kan se, arbejdes i Shape og ikke Picture

Således skulle Dim være Shape istedet for Picture

Derefter fandt jeg denne kode på en anden amerikansk hjemmeside:

Application.Goto reference:=Range(Z.Offset(-1, -8), Z.Offset(4, -5))
myPictP = strPath & strFileName
Set PicRange = Range(Z.Offset(-1, -8), Z.Offset(4, -5))
Set Shp = ActiveSheet.Shapes.AddPicture(Filename:=myPictP, LinkToFile:=False, SaveWithDocument:=True, Left:=PicRange.Left, Top:=PicRange.Top, Width:=PicRange.Width, Height:=PicRange.Height)
Shp.Placement = xlMoveAndSize
Shp.ControlFormat.PrintObject = True

Billederne bliver sat fint ind og tilpasset de flette celler i den specificeret range.
Filen med billeder bliver også noget større ;-)

Denne har jeg vist selv svaret p.....

Hej Hjald8 - jeg tror jeg har samme problem som du havde.

Desværre er jeg ikke stærk i at indsætte en del af en kode - så på trods af flere forsøg er det ikke lykkedes mig at få din kode til at fungere.

Har du mulighed for at formidle den fulde kode - naturligvis anonymiseret i nødvendigt omfang.

Pft.

Med venlig hilsen

Jens

Jeg er sørme ikke helt stærk - men jeg kan da prøve at hjælpe. Hvilken kode skal du have lagt en kode ind i?

Hej - tak for hurtig respons - det er denne kode jeg gerne vil have ændret således den bruger "shape" i stedet så billederne ligges i filen.

Hensigten er at den skal slå en sti op i kolonne O og indsætte billedet i kolonne A. Det er mest klippe / klistre så det kan sagtens være at koden "ser forfærdelig ud" :-)

Jeg tester også på om billedet er bredere end højden og optimerer størrelsen så den passer til cellen - kan det lade sig gøre med "shapes" også ?

Pft.


Sub InsertPic()
    Dim pic As String 'file path of pic
    Dim myPicture As Picture 'embedded pic
    Dim rng As Range 'range over which we will iterate
    Dim cl As Range 'iterator
    Dim sti As String
       
    sti = Range("sti").Value
       
    Set rng = Range("A21:A500")
    For Each cl In rng

        If Not IsEmpty(cl.Offset(0, 1)) Then
           
            pic = (sti & cl.Offset(0, 15))
           
                     
            If pic <> sti Then
               
                If Dir(pic) <> "" Then
               
                Set myPicture = ActiveSheet.Pictures.Insert(pic)
               
                If myPicture.Width > myPicture.Height Then
                       
                        With myPicture
                        .ShapeRange.LockAspectRatio = msoTrue
                        .Width = cl.Width
                        .Top = Rows(cl.row).Top
                        .Left = Columns(cl.Column).Left
                        End With
                       
                        Else
               
                        With myPicture
                        .ShapeRange.LockAspectRatio = msoTrue
                        .Height = cl.Height
                        .Top = Rows(cl.row).Top
                        .Left = Columns(cl.Column).Left
                        End With
                       
                        End If
                    End If
                End If
        End If

    Next

End Sub

Hej - har du haft lejlighed til at kigge på udfordringen :-)

Pft.

Vh

Jens