Meerdere afbeeldingen inlezen a.d.h.v. fotolink met oorspronkelijke verhouding

[CamJacobus]

Goedemiddag allen,

Het inlezen van meerdere afbeeldingen a.d.h.v. een fotolink is mij gelukt met behulp van een oud draadje. Hier zat het bijgevoegde bestand bij. Is het mogelijk om de afbeelding met de oorspronkelijk verhouding wordt ingelezen, waarbij de hoogte hetzelfde blijft? Dit is mij tot op heden, ondanks meerdere pogingen, nog steeds niet goed gelukt. Heeft iemand hier een oplossing voor?

Alvast bedankt!
Jaco

 

[alphamax]

Zie https://www.helpmij.nl/forum/showth...el-(versie-2)?p=6052051&viewfull=1&styleid=15, ene CamJacobus is vergeten te reageren op het laatste bericht.

 

[CamJacobus]

Ha Alphamax,

Excuses, ik kwam daar toen ook niet uit en ben er daarna niet meer aan toe gekomen. Ik ben nu met een ander bestand bezig, waar ik weer tegen dezelfde hobbel aanloop inderdaad. Ik zal jouw bijdrage nog eens goed bekijken, maar ik ben bang dat dit voor mij nog niet duidelijk genoeg is. Dit ligt aan mijn gebrekkige kennis van VBA. Is het mogelijk om nog wat extra toelichting te geven hoe dit werkt?

Alvast bedankt!
Jaco

 

[CamJacobus]

Ik heb nog een andere macro gevonden, waarin dit probleem wordt beetgepakt. Ik heb het als volgt opgelost:

Option Explicit

'De grote van de foto's worden hieronder bepaald.
Private Const MAXROWH = 125
Private Const scaleH = 0.9

Private Const MAXROWW = 31.44
Private Const scaleW = 5.1

'De foto's komen in de Picture_Col kolom en de referenties staan in de PictureName_Col kolom.
Private Const Picture_Col = 4
Private Const PictureName_Col = 54

'De gegevens starten vanaf de Start Row rij.
Private Const Start_Row = 5

'Deze Sub plaatst een foto in de cel die als parameter doorgegeven wordt. De
'tweede parameter is de FullPath-naam van de foto.
Sub InsertPicture(ByVal myCell As Range, ByVal cPicture As String)

    Dim mySheet As Worksheet
    Dim myPicture As Shape
    Dim nTop As Double
    Dim nLeft As Double
    Dim ScaleWidth As Double
    Dim ScaleHeight As Double
    Dim i As Long


'De coördinaten van de linker bovenhoek van de foto en die van de cel zijn gelijk.
With myCell
    nTop = .Top
    nLeft = .Left
End With

'De worksheet waartoe de cel behoort, moeten we kennen.
Set mySheet = myCell.Parent

'Veronderstel dat de naam van het fotobestand OK is, maar het formaat niet. Dan zal de
'AddPicture methode een foutmelding veroorzaken.
On Error GoTo Errhandler


'Een nieuwe foto (Shape) toevoegen op de gepaste coördinaten. De syntax is:
'expression.AddPicture(FileName, LinkToFile, SaveWithDocument, Left, Top, Width, Height)
'Om het Excel-bestand niet op te blazen gebruiken we de optie LinkToFile = True.
Set myPicture = mySheet.Shapes.AddPicture(cPicture, msoTrue, msoFalse, -1, -1, -1, -1)
myPicture.ScaleHeight 1, msoTrue
myPicture.ScaleWidth 1, msoTrue


    ' adjust cell width
        ScaleWidth = (MAXROWW * scaleW) / myPicture.Width
        ScaleHeight = (MAXROWH * scaleH) / myPicture.Height

   
   If ScaleWidth < ScaleHeight Then
        If ScaleWidth > 0 Then
            myPicture.ScaleHeight ScaleWidth, msoFalse, msoScaleFromTopLeft
        End If
        myCell.ColumnWidth = MAXROWW
        myCell.RowHeight = MAXROWH
   Else
        If ScaleHeight > 0 Then
            myPicture.ScaleHeight ScaleHeight, msoFalse, msoScaleFromTopLeft
        End If
        myCell.RowHeight = MAXROWH
        myCell.ColumnWidth = MAXROWW
   End If
   
    'center the picture
    myPicture.Left = myCell.Left + ((myCell.ColumnWidth * scaleW - myPicture.Width) / 2) + 4
    myPicture.Top = myCell.Top + ((myCell.RowHeight * scaleH - myPicture.Height) / 2) + 2
    
    'Hyperlink toevoegen om de originele foto te openen als men op de "Thumbnail" klikt.
    mySheet.Hyperlinks.Add Anchor:=myPicture, Address:=cPicture

Exit Sub

Errhandler:
    myCell.Value = "N/A Picture"
    Application.ScreenUpdating = True

End Sub

Hopelijk kunnen anderen hier weer hun voordeel mee doen.