• 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.
C

CabelGuy

Gebruiker
Lid geworden
30 apr 2021
Berichten
29
Geachte experts,

Ik heb 2 problemen. 1, ik ben een VBA noob en 2, ik heb een probleem met het invoegen van een afbeelding met een macro.
Ik ben hier al de nodige weken mee bezig en heb op het internet en Youtube erg weinig hierover kunnen vinden.
Wat ik gevonden heb, heb ik dan ook gebruikt en hier en daar een regel proberen in te voegen in de macro.
Maar het werkt niet naar behoren zoals ik het graag zou willen.

Het gaat om het volgende:
Het document wat ik heb is voor hoogbouw in de glasvezel en er wordt met verschillende tabbladen gewerkt waar veel foto's in verwerkt moeten worden.
Nu dacht ik daar voor een macro te maken die voor mij via de verkenner in verschillende mappen en locaties de foto's toe zou kunnen voegen.
Nu wil het geval dat de tabbladen met de foto's op verschillende locaties en cellen (dus variabel) zijn.
Ik wil graag dat de afbeeldingen mee worden opgeslagen in het document(geen link naar de afbelding) en met behoud van de aspectratio van de afbeelding, maar toch gecentreerd word in de actieve cel.

Dit is wat ik hiervoor nu gebruik:

Code: 
Sub Afbeelding1()
Dim fNameAndPath As Variant
Dim img As Picture
fNameAndPath = Application.GetOpenFilename(Title:="Selecteer Afbeelding")
If fNameAndPath = False Then Exit Sub
Set img = ActiveSheet.Pictures.Insert(fNameAndPath)
With img
.ShapeRange.LockAspectRatio = msoTrue
.Height = 200
.Top = ActiveCell.Top + 35
.Left = ActiveCell.Left + 2
End With
End Sub

Dit werkt wel maar het kan beter naar mijn idee.
Nu zou ik er het volgende bij willen plaatsen, maar dat gaat niet zomaar.

Code: 
Set pic = ActiveSheet.Shapes.AddPicture(Filename:=.SelectedItems(1), LinkToFile:=False, _
SaveWithDocument:=True, Left:=ActiveCell.Left, Top:=ActiveCell.Top, _
Width:=ActiveCell.Width, Height:=ActiveCell.Height)
Of iets wat er op lijkt.
Ik heb ook geprobeerd om de hoogte en de breedte met -1 te doen, maar dan krijg ik een joekel van een afbeelding te zien.

Hopende dat het een beetje duidelijk is ;)

Hoe zou ik dit goed kunnen krijgen?

m.v.g. en alvast bedankt, Erwin.
 
Laatst bewerkt:
Het voorbeeldbestand is weggevallen.

Gebruik svp code tags rondom VBA-code in een bericht.
 
Test.xlsm

Sorry, ik had het bestand niet mee gestuurd.
 

Bijlagen

  • Test.xlsm
    307,7 KB · Weergaven: 43
Ik gruw van de overbodig samengevoegde cellen.

Code: 
Sub M_snb()
  With Cells(5,1)
    sn = Array(.Left, .Top)
  End With
    
  With Application.FileDialog(3)
    .InitialFileName = "G:\OF\*.jpg"
    If .Show Then
      With ActiveSheet.Shapes.AddPicture(.SelectedItems(1), 1, 1, sn(0), sn(1), 100, 100)
        .LockAspectRatio = -1
        .ScaleHeight 2, 0, 0
      End With
    End If
  End With
End Sub
 
Laatst bewerkt:
Vierkante foto

Wauw, bedankt voor de snelle reactie en de code.

De code werkt goed, maar nu krijg ik een vierkante afbeelding in mijn cel.

De foto moet in zijn eigen formaat blijven, hetzij liggend of staand.

En sorry voor de gruwel van de cellen, ik krijg dit zo aangeleverd en hier moet ik mee werken :confused:.
 
Dan wellciht:
Code: 
Sub M_snb()
  ActiveSheet.Cells.UnMerge
  With Cells(5, 1)
    sn = Array(.Left, .Top)
  End With
    
  With Application.FileDialog(3)
    .InitialFileName = "G:\OF\*.jpg"
    If .Show Then
      With ActiveSheet.Shapes.AddPicture(.SelectedItems(1), 1, 1, sn(0), sn(1), 100, 100)
        .ScaleHeight 2, 0, 0
        .ScaleWidth 2, 0, 0
      End With
    End If
  End With
End Sub
 
Tabblad aan gort

Nu gaat het hele tabblad uit zijn voegen. Er blijft niks meer over van de opmaak.
 
De opmaak moet niet afhangen van samengevoegde cellen; dat is de verkeerde aanpak.
Zie de bijlage.

Ik gebruik nu:
Code: 
Sub M_snb()
   ActiveSheet.Cells.UnMerge
   With Cells(5, 1)
     sn = Array(.Left, .Top)
    End With
    
   With Application.FileDialog(3)
      .InitialFileName = "G:\OF\*.jpg"
      If .Show Then
            With ActiveSheet.Shapes.AddPicture(.SelectedItems(1), 1, 1, sn(0), sn(1), -1, -1)
                 .ScaleHeight 1.5, 0, 0
                 .ScaleWidth 1.5, 0, 0
            End With
      End If
   End With
End Sub
 

Bijlagen

  • __Test(40).xlsm
    319,3 KB · Weergaven: 49
Werkt nog minder

In mijn eerste bericht heb ik gezegd dat -1 niet werkt, omdat ik dan een joekel van een foto krijg.

Ook hier is dit weer het geval.

Sorry als ik lastig ben :eek:
 
Naruurlijk werkt het als je de scaleheight daarna op.2 zet bijv.
Dat is een kwestie van uitproberen, ik heb geen beeld van de omvang van jouw foto's.
 
De foto's worden gemaakt met een tablet of telefoon.
Het zijn standaard foto's die gemaakt worden, die in de desbetreffende cellen geplaatst moeten worden.

Voor wat betreft de "Scale" heb ik van alles uitgeprobeerd, zelfs tot aan 1000 toe, maar het veranderd niet.

Mijn originele script werkt prima, zelfs qua formaat van de foto's. Alleen wordt via dat script geen enkele foto in het document opgeslagen.
Het zijn "Links" die in het document komen en niet de afbeeldingen.

Dat is eigenlijk wat ik zou willen, dat de foto's mee genomen worden in het document als hij wordt opgeslagen.

Een leuke bijkomstigheid zou zijn dat de foto's meteen aan de actieve cel en gecentreerd aangepast zouden worden met behoud van het originele formaat van de foto.
Of is dat wishfull thinking?

Ik heb een macro gevonden die dat doet, maar dan is de foto exact hetzelfde als de cel.
De foto wordt dan letterlijk in de cel geplakt met de formaten "Range" van de cel, en dat is ook weer niet de bedoeling.
Die macro is perfect als het formaat van de foto gehandhaafd blijft.

Ik heb zoveel uitgeprobeerd dat ik er echt niet meer aan uit kom.

Deze code heb ik later gevonden maar ik heb geen idee hoe ik die moet implementeren.

Code: 
Set pic = ActiveSheet.Shapes.AddPicture(Filename:=.SelectedItems(1), LinkToFile:=False, _
 SaveWithDocument:=True, Left:=ActiveCell.Left, Top:=ActiveCell.Top, _
 Width:=ActiveCell.Width, Height:=ActiveCell.Height)
 
Okee, ik heb het een beetje aangepast en het werkt een stuk beter. 0.2 is idd beter haha.

Waarom komt de foto niet in de actieve cel die ik geselecteerd heb? De foto komt bovenaan in het blad terecht.
En waarom onthoud de macro niet in welke map de foto's staan. De map die ik het laatst geselecteerd heb?
Anders kan ik net zo goed de knop "Invoegen" blijven gebruiken (zonder de macro). Dat is minder klikken dan nu.

Sorry dat ik zo lastig ben, maar ik ben er al zo lang mee bezig en ik wil graag dat het een keer lukt.
 
In Excel is het werkblad onafhankelijk van de grafische laag voor de afbeeldingen.

Heb je überhaupt het geplaatste bestand bekeken ?

Als vormgeving, alsof het papier is, belangrijkers is dan dataverwerking kun je beter een teksverwerkingsprogramma gebruiken dan Excel.
 
Houdt rekening met samengevoegde cellen en centreert de afbeelding.
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 ActiveSheet.Pictures.Insert(sPath)
            .ShapeRange.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

Maar...

Er is bij het inladen een vervelend probleem, portrait foto's worden toch als landscape afgebeeld, zie https://www.ivertech.com/Articles/Image-Rotation-Issue-With-Windows-10.aspx en https://office-watch.com/2012/outlooks-flipping-image-problem/
 
Laatst bewerkt:
Wauw, dit werkt grandioos!!!

Van de portrait foto's heb ik geen last gelukkig, alleen zijn de portrait foto's groter dan de cel. Dit geldt trouwens niet voor de A4 formaten met 1 foto, maar wel voor de A4 formaten met 2 foto's op 1 blad.
De landscape foto's zijn perfect.

Bedankt Alphamax, dit is echt perfect.
 
Nu zullen je rapporten wel een stuk sneller klaar zijn, en een stuk netter ;)
 
Ik heb nog wel een nieuwsgierige vraag.

Kunt u mij vertellen waarom dat is? Waarom de portrait foto's groter blijft bij de Landscape cellen?
 
CabelGuy zei:
Ik heb nog wel een nieuwsgierige vraag.

Kunt u mij vertellen waarom dat is? Waarom de portrait foto's groter blijft bij de Landscape cellen?
Klik om te vergroten...
Nee ik ben er nog niet achter waarom de code anders omgaat met portrait foto's dan met landscape foto's.
Eigenlijk was ik onaangenaam verrast dat het nu zo werkt, in mijn herrrinering was het niet zo.
Ligt het aan de nieuwere windows versies?, ligt aan het jpg-formaat?
Dat wil ik nog uitzoeken.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan