Afbeelding invoegen, zoeken met verkenner

[Appievee]

Beste forummers,

Hopelijk krijg ik mijn vraag duidelijk genoeg uitgelegd (zie ook bijlage)

Aanleiding
Binnen een bestand moet een afbeelding van het project in een beveiligd eindblad komen (om te voorkomen dat formules onbedoeld kapot worden gemaakt). Echter bij het beveiligen van het blad is het niet meer mogelijk een afbeelding in te voegen. Dus wellicht biedt een VBA oplossing.

Ik heb gezocht op internet, en een VBA gevonden wat zou moeten werken, maar ik krijg het niet aan de praat. Wat ik wil bereiken is het volgende.

• Collega's klikken op het gebied waar het plaatje moet komen in de verder beveiligde blad
• Dan bladeren ze naar het juiste bestand op hun computer
• Het figuur wordt automatisch verkleind/vergroot (lengte breedte verhouding wel hetzelfde latend) tot de afmeting van het gebied

Hopelijk kan iemand mij helpen? Merci!

Gr. Albert

 

[Elsendoorn2134]

Albert,

Je zegt een VBA oplossing op internet gevonden te hebben, zou je deze ook willen meesturen.

Veel Succes.

 

[Warme bakkertje]

Plaats ipv die samengevoegde cellen een ImageControl op je werkblad en dan kan je verder met deze.

Sub tst()
    With Blad1.Image1
        .Picture = LoadPicture("")
        .Picture = LoadPicture(Application _
            .GetOpenFilename("Pics (*.jpg), *.jpg"))
     End With
End Sub

Selecteer bij de eigenschappen van je ImageControl >> PictureSizeMode >> 1-fmPictureSizeModeStretch

 

[mvw64]

Misschien helpt dit u verder

 

[tkint]

@mvw64

Beste,

Ik wil jouw vba-code gebruiken in een andere toepassing maar ik slaag er niet in om de afbeelding te wissen vooraleer een nieuwe in te voegen. Graag een hint.

mvg,
tkint

 

[mvw64]

Zet deze regel in jou macro achter ActiveSheet.Unprotect Password:="x"

ActiveSheet.Unprotect Password:="x"
ActiveSheet.Pictures.Delete

 

[Warme bakkertje]

Sub Afbeelding_Invoegen()
    Dim vFilename As Variant
    Dim s As Shape, r As Range
    On Error Resume Next
    Sheets("Blad1").Shapes("TempPic").Delete
    On Error GoTo 0
    vFilename = Application.GetOpenFilename("JPEG-Afbeelding (*.jpg), *.jpg", , "In te voegen afbeelding selecteren", , False)
    If TypeName(vFilename) = "Boolean" Then Exit Sub: If CStr(vFilename) = "" Then Exit Sub
    If Dir(CStr(vFilename)) <> "" Then
        Set r = Range("B5"): w = Range("B5").MergeArea.Width: h = Range("B5").MergeArea.Height
        Set s = ActiveSheet.Shapes.AddPicture(CStr(vFilename), msoFalse, msoTrue, r.Left, r.Top, w, h)
        s.Name = "TempPic"
        s.TopLeftCell = Range("B5")
    End If
End Sub

 

[Appievee]

Kijk dat zijn mooie oplossingen! Dank!

Ik heb die van Warm Bakkertje gebruikt als basis in combinatie met het (un)Protecten. Werkt perfect:thumb:

 

[Warme bakkertje]

Op deze manier ben je zeker dat alles op het juiste blad gebeurt.

Sub Afbeelding_Invoegen()
    Dim vFilename As Variant
    Dim s As Shape, r As Range
    On Error Resume Next
    With Sheets("Blad1")
        .Unprotect
        .Shapes("TempPic").Delete
        Err.Clear: On Error GoTo 0
        vFilename = Application.GetOpenFilename("JPEG-Afbeelding (*.jpg), *.jpg", , "In te voegen afbeelding selecteren", , False)
        If TypeName(vFilename) = "Boolean" Then Exit Sub: If CStr(vFilename) = "" Then Exit Sub
        If Dir(CStr(vFilename)) <> "" Then
            Set r = .Range("B5"): w = .Range("B5").MergeArea.Width: h = .Range("B5").MergeArea.Height
            Set s = ActiveSheet.Shapes.AddPicture(CStr(vFilename), msoFalse, msoTrue, r.Left, r.Top, w, h)
            s.Name = "TempPic"
            s.TopLeftCell = .Range("B5")
        End If
        .Protect
    End With
End Sub