Afbeelding in opmerking met macro plaatsen

[johnnyhoes]

Ik ben a een tijdje aan het zoeken maar vind geen werkende oplossing.
Ik wil foto's in een opmerking plaatsen maar omdat het er erg veel zijn wil ik dat met een macro doen.
Via macro opnemen gaat het niet.
De macro moet ook even stoppen om de juiste foto te selecteren.
Wie heeft hier een oplossing voor?

 

[edmoor]

Als compleet voorbeeld heb ik een knop gemaakt in het werkblad en daar de volgende macro aan gehangen:

Sub InvoegenFotoInOpmerking()
    Dim Foto As String
    ChDir "C:"
    ChDir "\Fotoos"
    Foto = Application.GetOpenFilename(FileFilter:="Foto's (*.jpg), *.jpg", Title:="Kies een foto")
    If Foto <> "" Then
        ActiveCell.Select
        Selection.ClearComments
        With ActiveCell.AddComment
            .Text "Opmerking tekst"
            With .Shape
                .Fill.UserPicture Foto
            End With
        End With
    End If
End Sub

Uiteraard kun je deze naar eigen wens aanpassen.

 

[johnnyhoes]

Het werkt niet bij mij, ik blijf fouten krijgen, dit heb ik nu in een macro staan:
De regel die begint met foto = is nu geel in de foutopsporing,

Sub Foto_invoegen()
'
' Foto_invoegen Macro
'
' Sneltoets: Ctrl+q
'
    Dim Foto As String
    ChDir "C:"
    ChDir "\Users\John\Pictures"
    Foto = Application.GetOpenFilename(FileFilter:="Foto's (*.jpg), *.jpg", Title:="Kies een foto")
    If Foto <> "" Then
        ActiveCell.Select
        Selection.ClearComments
        With ActiveCell.AddComment
            .Text "Opmerking tekst"
            With .Shape
                .Fill.UserPicture Foto
            End With
        End With
    End If
End Sub

 

[johnnyhoes]

Als ik deze macro gebruik werkt alles wel maar het plaatje wordt niet in de opmerking gezet:

Sub Foto_invoegen()
'
' Foto_invoegen Macro
'
' Sneltoets: Ctrl+q
'
    Dim Foto As String
    ChDir "C:"
    ChDir "\Users\John\Pictures"
    fileToOpen = Application _
    .GetOpenFilename("JPEG-Afbeelding (*.jpg), *.jpg")
       ActiveCell.Select
        Selection.ClearComments
        With ActiveCell.AddComment
            .Text ""
            With .Shape
          

            End With
        End With
    
End Sub

 

[HSV]

Zo dan?

Sub InvoegenFotoInOpmerking()
    Dim Foto As String
    Dir "C:\Users\John\Pictures"
     Foto = Application.GetOpenFilename(FileFilter:="Foto's (*.jpg), *.jpg", Title:="Kies een foto")
    If Foto <> "" Then
        ActiveCell.ClearComments
        With ActiveCell.AddComment
            .Text "Opmerking tekst"
            With .Shape
                .Fill.UserPicture Foto
            End With
        End With
    End If
End Sub

 

[edmoor]

De voorbeeldcode zoals ik hem plaatste werkt goed.
De code zoals je deze om 17:52 hebt gepost werkt bij mij ook goed.
Het zou handig zijn als je ook even verteld welke fouten je krijgt daarbij krijgt.

In je code van 18:21 is het invoegen van de foto helemaal weg.

 

[johnnyhoes]

Deze macro van HSV werkt wel
Alleen als ik hem de eerst keer gebruik dan begint hij in de map documenten maar dat is niet zo erg.
Kan ik het formaat ook nog aanpassen in de macro, hij is standaard iets te klein.
Alvast wel heel hartelijk dank voor de snelle reacties en oplossingen

 

[edmoor]

Die begint in de verkeerde map omdat het zetten van de juiste map eruit is, voor de rest is hij gelijk als die in mijn eerste reactie.
Kijk eens naar de attributen van .Shape, daar kun je het formaat van de foto bepalen.

 

[HSV]

Mijn excuses dat het in het verkeerde pad begint: teruggezet.

Schaal aangepast.

Sub InvoegenFotoInOpmerking()
  Dim Foto As String
    ChDir "C:\Users\John\Pictures"
    Foto = Application.GetOpenFilename(FileFilter:="Fotos (*.jpg), *.jpg", Title:="Kies een foto")
     If Foto <> "" Then
      ActiveCell.ClearComments
        With ActiveCell.AddComment
            .Text "Opmerking tekst"
        With .Shape
            .Height = .Height * 2
            .Width = .Width * 2
            .Fill.UserPicture Foto
         End With
      End With
    End If
End Sub

@edmoor.
Ik kreeg foutmelding 76;
'Kan het pad niet vinden'.
Uiteraard aangepast naar mijn pad.

 

[edmoor]

Die fout krijg je nu niet meer?

Edit:
Nee, zo zou het ook moeten kunnen wat dat pad betreft.

 

[HSV]

Ik heb jouw code van 13:08 u getest, en kreeg daar de foutmelding.
Onder F1 van ChDir staan ze ook een driveletter toe.

 

[johnnyhoes]

Het werkt perfect nu alleen begint hij niet in de map pictures maar dat is alleen de eerste keer zo, de volgende keren gaat hij de de laast gebruikte map dus dat is perfect.
Bedankt voor alle hulp, ik was er zelf niet uit gekomen

 

[HSV]

Johnny,

Probeer deze versie eens of het in de juiste map opstart.

Sub InvoegenFotoInOpmerking()
  Dim Foto As String
    With Application.FileDialog(msoFileDialogOpen)
    .InitialFileName = "C:\Users\John\Pictures"
    .Filters.Add "Fotos", "*.jpg", 1
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    Foto = .SelectedItems(1)
     If Foto <> False Then
      ActiveCell.ClearComments
        With ActiveCell.AddComment
            .Text "Opmerking tekst"
        With .Shape
            .Height = .Height * 2
            .Width = .Width * 2
            .Fill.UserPicture Foto
         End With
      End With
    End If
    End With
End Sub

 

[johnnyhoes]

HSV, jou laatste code is het helemaal.
Dan kan ik elke map kiezen die ik wil.
Hartelijk dank