Afbeeldingen importeren in Excel (versie 2)

CamJacobus · 5 jan 2018

Goedemiddag allen,

Ik heb weer een issue met de import van afbeeldingen in Excel dmv een macro. Dit keer is het wel een ander probleem dan de vorige keer. Zie onderstaande code en bijlage:

Code:

Sub Invoegen_afbeeldingen()

    Dim PicList() As Variant
    Dim PicFormat As String
    Dim Rng As Range
    Dim sShape As Shape
    On Error Resume Next
    PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
    Sheets("Bijlage fotorapportage").Select
    Range("A8").Select
    xColIndex = Application.ActiveCell.Column
    If IsArray(PicList) Then
        xRowIndex = Application.ActiveCell.Row
        For lLoop = LBound(PicList) To UBound(PicList)
            Set Rng = Cells(xRowIndex, xColIndex)
            Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoTrue, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
            With sShape
                .ShapeRange.LockAspectRatio = msoTrue
                .Height = Rng.Height
            End With
            xRowIndex = IIf(xColIndex >= 5, xRowIndex + 3, xRowIndex)
            xColIndex = IIf(xColIndex >= 5, 1, xColIndex + 2)
        Next
End If
End Sub

Bekijk bijlage Afbeeldingeninvoegen.xlsm

Het lukt mij op geen enkele wijze om de AspectRatio gelijk te houden aan het originele bestand. Alle afbeeldingen worden geïmporteerd met de afmetingen gelijk aan de cel. Heeft iemand hier een oplossing voor?

Alvast bedankt!

Peter B · 5 jan 2018

In de volgende regel maak je het plaatje exact zo groot als de cel. Vervolgens zet je de aspectratio:

Code:

Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoTrue, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)

Volgens mij moet je dan ook beginnen met deze regel te vervangen door:

Code:

Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoTrue, msoCTrue, Rng.Left, Rng.Top, -1, -1)

Vervolgens moet je volgens mij de hoogte relatief aanpassen (dat weet ik niet zeker). Dus niet keihard de height opgeven, maar gebruik maken van scaleheight. Dus i.p.v.:

Code:

.Height = Rng.Height

de volgende code:

Code:

.ScaleHeight Rng.Height / sShape.Height, msoTrue

snb · 5 jan 2018

Ik zie het probleem niet:

Code:

Sub M_snb()
   With Application.FileDialog(3)
       .AllowMultiSelect = True
       .Filters.Add "Images", "*.jpg", 2
       .FilterIndex = 2
       If .Show Then
         For Each it In .SelectedItems
             c00 = Choose(Sheets("bijlage fotorapportage").Shapes.Count - 1, "A6", "C6", "E6", "A10", "C10", "E10")
             Sheets("bijlage fotorapportage").Shapes.AddPicture it, -1, -1, Range(c00).Left, Range(c00).Top, 200, 200
         Next
       End If
   End With
End Sub

Peter B · 8 jan 2018

@snb:
Natuurlijk toch nieuwsgierig, dus heb je code getest.
Ik moest Application.FileDialog(3) aanpassen naar Application.FileDialog(1) om de code te laten draaien. Voor sommige mensen ws. obvious, maar toch
Vervolgens wordt ieder plaatje zonder aspectratio verkleind. Ze zijn allemaal vierkant

CamJacobus · 8 jan 2018

Goedemorgen snb en Peter,

Bedankt voor het meedenken! Ik heb beide oplossingen geprobeerd. Bij snb heb ik inderdaad ook alleen vierkante afbeeldingen. Bij de oplossing van Peter is de aspectratio wel goed, alleen worden de afbeeldingen niet meer op de juiste plek gepositioneerd.

Groeten,
Jaco

snb · 8 jan 2018

NB. Ik ga nu uit van een leeg werkblad zonder afbeeldingen, max te selecteren afbeeldingen: 6

dan:

Code:

Sub M_snb()
   With Application.FileDialog(1)
       .AllowMultiSelect = True
       .Filters.Add "Images", "*.jpg", 2
       .FilterIndex = 2
       If .Show Then
         For Each it In .SelectedItems
             c00 = Choose(Sheets(1).Shapes.Count + 1, "A6", "C6", "E6", "A10", "C10", "E10")
             With Sheets(1).Shapes.AddPicture(it, -1, -1, Range(c00).Left, Range(c00).Top, 200, 200)
                 .ScaleHeight 1, True
                 .ScaleWidth 1, True
             End With
         Next
       End If
   End With
End Sub

CamJacobus · 8 jan 2018

snb zei:

NB. Ik ga nu uit van een leeg werkblad zonder afbeeldingen, max te selecteren afbeeldingen: 6

dan:

Code:

Sub M_snb()
   With Application.FileDialog(1)
       .AllowMultiSelect = True
       .Filters.Add "Images", "*.jpg", 2
       .FilterIndex = 2
       If .Show Then
         For Each it In .SelectedItems
             c00 = Choose(Sheets(1).Shapes.Count + 1, "A6", "C6", "E6", "A10", "C10", "E10")
             With Sheets(1).Shapes.AddPicture(it, -1, -1, Range(c00).Left, Range(c00).Top, 200, 200)
                 .ScaleHeight 1, True
                 .ScaleWidth 1, True
             End With
         Next
       End If
   End With
End Sub

Bedankt! Ik heb hem als onderstaande code toegepast:

Code:

Sub Invoegen_afbeeldingen()
   With Application.FileDialog(1)
       .AllowMultiSelect = True
       .Filters.Add "Images", "*.jpg", 2
       .FilterIndex = 2
       If .Show Then
         For Each it In .SelectedItems
             c00 = Choose(Sheets("Bijlage fotorapportage").Shapes.Count + 1, "A8", "C8", "E8", "A11", "C11", "E11")
             With Sheets("Bijlage fotorapportage").Shapes.AddPicture(it, -1, -1, Range(c00).Left, Range(c00).Top, 200, 200)
                 .ScaleHeight 1, True
                 .ScaleWidth 1, True
             End With
         Next
       End If
   End With
End Sub

Bekijk bijlage Afbeeldingeninvoegen.xlsm

Bij het toevoegen van 6 afbeeldingen krijg ik een foutmelding op regel:

Code:

With Sheets("Bijlage fotorapportage").Shapes.AddPicture(it, -1, -1, Range(c00).Left, Range(c00).Top, 200, 200)

Daarnaast wordt ook bij het toevoegen van minder afbeeldingen de afbeeldingen niet op de juiste plek gezet en goed geresized. De Aspectratio is wel goed.

CamJacobus · 17 jan 2018

Goedemorgen,

Ik heb zelf nog zitten puzzelen, maar krijg toch niet het juiste resultaat. Kan iemand mij verder helpen?

Groeten,
Jaco

alphamax · 17 jan 2018

er is geen controle in de code op te weinig of te veel plaatjes ten opzichte van de ranges

Code:

[SIZE=1]Option Explicit

Sub Invoegen_afbeeldingen()
    Dim lngIndex As Long
    Dim objCell As Object
    Dim objShape As Object
    Dim vntFile As Variant
    On Error Resume Next
    With Sheets(1)
        'opruimen!
        For Each objShape In .Shapes
            If objShape.Type = 13 Then
            objShape.Delete
            End If
        Next
        With Application.FileDialog(1)
            .AllowMultiSelect = True
            .Filters.Add "Images", "*.jpg", 2
            .FilterIndex = 2
            If .Show Then
                For Each vntFile In .SelectedItems
                    lngIndex = lngIndex + 1
                    Set objCell = Range(Choose(lngIndex, "A8", "C8", "E8", "A11", "C11", "E11"))
                    Application.Goto objCell
                    With Sheets(1).Pictures.Insert(vntFile)
                        .Top = objCell.Top
                        .Left = objCell.Left
                        If .Height / .Width < objCell.Height / objCell.Width Then
                            .Height = .Height * objCell.Width / .Width
                            .Width = objCell.Width
                        Else
                            .Height = objCell.Height
                            .Width = .Width * objCell.Height / .Height
                        End If
                    End With
                    Set objCell = Nothing
                Next
            End If
        End With
    End With
End Sub[/SIZE]

Afbeeldingen importeren in Excel (versie 2)

CamJacobus

Verenigingslid

Bijlagen

Peter B

Gebruiker

snb

Verenigingslid

Peter B

Gebruiker

CamJacobus

Verenigingslid

snb

Verenigingslid

CamJacobus

Verenigingslid

CamJacobus

Verenigingslid

alphamax

Terugkerende gebruiker

Bijlagen

Nieuwste berichten

Wij waarderen jouw privacy