• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Ondersteuning voor een macro met afbeeldingen.

Status
Niet open voor verdere reacties.
Ik ben nog eens aan het uitproberen gegaan en ben tot de conclusie gekomen dat de foto's niet mee opgeslagen worden met het document, en dat was nou wel de bedoeling.
Zoals ik in mijn eerdere berichten aan heb gegeven heb ik de code daar wel voor, maar ik kan hem niet implementeren.
Dat heb ik zo vaak geprobeerd en dat loopt elke keer op een foutcode uit.

Graag hulp hierbij.
 
Met een andere methode waarbij je de link kan verbreken en de afbeelding in het bestand wordt opgeslagen, zie https://docs.microsoft.com/en-us/office/vba/api/excel.shapes.addpicture
Code:
Public Sub Afbeelding1()
    sPath = Application.GetOpenFilename(Title:="Selecteer Afbeelding")
    If sPath = False Then
        Exit Sub
    Else
        For Each oCol In ActiveCell.MergeArea.Columns
            lWidth = lWidth + oCol.Width
        Next
        For Each oRow In ActiveCell.MergeArea.Rows
            lHeight = lHeight + oRow.Height
        Next
        With [COLOR="#FF0000"]ActiveSheet.Shapes.AddPicture[/COLOR](sPath, [COLOR="#FF0000"]msoFalse, msoTrue[/COLOR], 1, 1, -1, -1)
            .LockAspectRatio = msoTrue
            If .Width * lHeight < .Height * lWidth Then
                .Height = lHeight
            Else
                .Width = lWidth
            End If
            .Top = ActiveCell.Top + (lHeight - .Height) / 2
            .Left = ActiveCell.Left + (lWidth - .Width) / 2
        End With
    End If

End Sub
 
Laatst bewerkt:
Helaas, het werkt nog steeds niet. Bij het opslaan van het document verandert de grootte niet.
Het blijven dus "Links".
 
Wijzingen in bestandsgrootte zijn niet direct zichtbaar in windows verkenner.
Wat gebeurt er al je verkenner afsluit en weer opent?
 
Ik heb van alles zitten proberen, maar het lukt mij niet om het goed te krijgen.
Ik heb ook naar de website gekeken die je mee had gestuurd en daar ben ik steeds mee bezig geweest maar ik krijg steeds een foutmelding.
Zoals ik al zei: ik heb geen idee hoe ik dat moet implementeren.
Ben er al weer uren mee bezig...

Antwoord op uw vraag: er gebeurt niets.
 
Als ik de regel aan wil passen met: LinkToFile:=False, SaveWithDocument:=True, dan kloppen de formaten die aangegeven zijn in uw code (1, 1, -1, -1) niet meer.
Dan moet er een definitie aangegeven worden, maar ik heb geen idee wat er dan moet komen staan.
 
Werkt dit? bestand zonder ballast.
Bij mij wel, windows 10, office2007nl.

En over welke foutmelding heb je het dan, graag de letterlijke tekst of een afbeelding.
 

Bijlagen

  • Test cabelguy.xlsm
    56,9 KB · Weergaven: 30
Laatst bewerkt:
HET WERKT!!! Hahaha

Ik weet niet waarom het gisteren niet werkte, maar het werkt.

Ik zal echt wel iets niet goed gedaan hebben, maar wat...? Geen idee...:d


Ik ben echt blij!

Alphamax, nogmaals heel hartelijk dank voor alles, ik ben erg in mijn nopjes haha.



P.S.

Ik hoor het graag als u er achter bent waarom een portrait foto niet wordt aangepast in een Landscape cel :thumb:
 
De reden dat een portrait foto meestal als landscape wordt afgebeeld heeft ermee te maken dat camera's een orientatie sensor hebben.
De orientatie wordt opgeslagen in een extra veld in het jpg bestand
Slimme programma's als verkenner gebruiken info om de foto juist af te beelden.
Dommere programma's als excel gebruiken deze info niet.
Zie https://www.impulseadventure.com/photo/exif-orientation.html
 
Hmmm.... interessant onderwerp. Goed om te weten.

Ik bedoelde eigenlijk de grootte van de foto dat die niet wordt aangepast aan de Landscape cel grootte, de foto wordt er te groot in gezet, terwijl een portrait foto er wel in aangepast wordt.
Of zou het aan Office 365 liggen? Wat ik dus gebruik.
 
Ik bedoel de Landscape foto wordt wel in een Portrait cel aangepast aan de grootte, maar niet vice versa.
 
Ik ben bezig met universele code voor alle foto's maar er gebeuren nog dingen die ik nog niet kan verklaren.
 
Universele code, plaats elke JPG recht ongeacht in welk positie de foto genomen is

Code:
Option Explicit

Private Sub Afbeelding1()

Dim aCell As Variant
Dim aPicture As Variant
Dim bUpRight As Boolean
Dim dPictureDiagonal As Double
Dim lOrientation As Long
Dim lZoom As Long
Dim vPath As Variant

    vPath = Application.GetOpenFilename(Title:="Selecteer Afbeelding")
    If vPath = False Then
        Exit Sub
    Else
    
        Application.ScreenUpdating = False
        
        lZoom = ActiveWindow.Zoom
        ActiveWindow.Zoom = 100 'when not 100, picture fits not nice in cell

        With ActiveSheet.Shapes(Application.Caller).TopLeftCell.MergeArea
            aCell = Array(.Left, .Top, .Width, .Height)
        End With

        With CreateObject("WIA.ImageFile")
            .LoadFile vPath
            lOrientation = .Properties("Orientation") - 1
        End With

        With ActiveSheet.Shapes.AddPicture(vPath, False, True, 0, 0, -1, -1)
            .LockAspectRatio = msoTrue

            aPicture = Array(.Width, .Height)

            dPictureDiagonal = Sqr(aPicture(0) ^ 2 + aPicture(1) ^ 2)
            .IncrementLeft (dPictureDiagonal - aPicture(0)) / 2 - 1 'when corner rotates through negative values, unpridictable results
            .IncrementTop (dPictureDiagonal - aPicture(1)) / 2 - 1

            If (lOrientation And 4) Then
                .IncrementRotation 90
                .Flip msoFlipHorizontal
            End If
            If (lOrientation And 2) Then
                .IncrementRotation 180
            End If
            If (lOrientation And 1) Then
                .Flip msoFlipHorizontal
            End If

            bUpRight = lOrientation < 4
            If aPicture(1) * aCell(3 + bUpRight) < aPicture(0) * aCell(2 - bUpRight) Then
                .Width = aCell(3 + bUpRight)
            Else
                .Height = aCell(2 - bUpRight)
            End If

            .IncrementLeft aCell(0) + (aCell(2) - .Width) / 2 - .Left
            .IncrementTop aCell(1) + (aCell(3) - .Height) / 2 - .Top

        End With

    End If

    ActiveWindow.Zoom = lZoom
    
    Application.ScreenUpdating = True

End Sub
 

Bijlagen

  • helpmij cabelguy exif orientation.xlsm
    56,2 KB · Weergaven: 28
Haha toch gevonden hoe het werkt?

Ik krijg alleen de volgende foutmelding:
 

Bijlagen

  • Foutmelding.jpg
    Foutmelding.jpg
    43,8 KB · Weergaven: 29
Laatst bewerkt door een moderator:
Bijlage werkend gemaakt
 
Code:
With ActiveSheet.Shapes(Application.Caller).TopLeftCell.MergeArea
    aCell = Array(.Left, .Top, .Width, .Height)
End With
Deze code pakt de aaneengesloten cellen (MergeArea) rondom de linkerbovenhoek (TopLeftCell) van jouw button/shape (Application.Caller) met de tekst "Afbeelding invoegen".
Je hoeft dus niet de juiste cel te selecteren om de afbeelding op de juiste plaats te krijgen.
 
Laatst bewerkt:
@huijb
Wat bedoel je met bijlage werkend gemaakt?
Is het uploaden misgegaan?
of
Werkt de code niet goed?

Helaat heb ik nog niet getest met nieuwere excel versies dan 2007.

Alvast bedankt,
 
Misschien was ik niet duidelijk genoeg. Het was corrupt dus niet te zien. Zichtbaar gemaakt dus.
 
Ok, bedankt.
Ik geloof dat er een soort bug in de forumsoftware zit.
De plaatser van de bijlage kan de bijlage wel zien en openen, iedereen anders kan dat niet.
 
Ik denk eerder, maar kan het mis hebben, dat men niet precies weet hoe te uploaden. Er waren in het verleden wel wat issues maar die zie ik de laatste tijd niet meer. Behoudens deze dan.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan