Foto in juiste verhouding

[MMarie]

Kan iemand mij helpen? Ben al even op zoek geweest en geprobeerd om in mijn huidige macro voor het invoegen van een foto in excel vanuit het netwerk, de foto in de juiste verhouding te krijgen.
De foto wordt er nu ingezet volgens de in de macro opgegeven waarden, maar het enige wat ik eigenlijk vast wil hebben is de afstand van links en van boven, en een vaste hoogte. De breedte moet dan de verhouding van de foto blijven zodat deze niet wordt uitgerekt. De in te voegen foto kan overigens zowel staand of liggend zijn.

Hier de macro:

Private Sub cmdFotoOpvragen_Click()
Application.ScreenUpdating = False

Dim myObj
Dim Pictur
Set myObj = ActiveSheet.DrawingObjects
For Each Pictur In myObj
If Left(Pictur.Name, 7) = "Picture" Then
Pictur.Select
Pictur.Delete
End If

Next

Dim ClusterNummer As String, FotoNummer As String, T As String

mydir = "G:\mapnaam\"
ClusterNummer = Range("H3")
FotoNummer = "_000"
T = ".jpg"

On Error GoTo ErrorMessage:
ActiveSheet.Shapes.AddPicture Filename:=mydir & ClusterNummer & FotoNummer & T, _
    linktofile:=msoFalse, _
    savewithdocument:=msoTrue, _
        Left:=230, _
        Top:=130, _
        Width:=325, _
        Height:=325
                 
ErrorMessage:
If Err.Number = 1004 Then
MsgBox "Foto is niet beschikbaar"

End If

Application.ScreenUpdating = True

End Sub

 

[edmoor]

Probeer het eens zo:

ActiveSheet.Shapes.AddPicture Filename:=mydir & ClusterNummer & FotoNummer & T, _
    linktofile:=msoFalse, _
    Width:=-1, _
    Height:=-1, _
    savewithdocument:=msoTrue, _
        Left:=230, _
        Top:=130, _
        Height:=325

Die beide -1 waarden geven aan dat je de originele verhouding wilt houden.

 

[MMarie]

Als ik jouw aanpassing overneem gebeurt er niks. Krijg ook geen foutmelding.
Als ik de laatste Height weglaat dan werkt het wel, alleen lijkt hij dan echt te kijken naar de grote van bestand. Een lage resolutie wordt een klein plaatje, een hoge resolutie wordt heel groot.
Het vastzetten van de hoogte lukt dus nog niet op deze manier?

 

[edmoor]

Ik heb alleen aangegeven wat Microsoft erover zegt. Maar probeer het eens zo, ook voor een betere fout afhandeling:

Private Sub cmdFotoOpvragen_Click()
    Dim Foto As String
    Dim myObj
    Dim Pictur
    Dim Pict As Shape
    
    Foto = "G:\mapnaam\" & Range("H3") & "_000.jpg"
    
    If Dir(Foto) = "" Then
        MsgBox "Foto niet beschikbaar"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set myObj = ActiveSheet.DrawingObjects
    For Each Pictur In myObj
        If Left(Pictur.Name, 7) = "Picture" Then
            Pictur.Select
            Pictur.Delete
        End If
    Next
    
    Set Pict = ActiveSheet.Shapes.AddPicture(Foto, _
        msoTrue, msoFalse, -1, -1, 230, 130)
        Pict.Height = 325
    
    Application.ScreenUpdating = True
End Sub

Zo wordt de foto eerst opgemaakt en geplaatst, waarna pas de hoogte wordt gezet.

 

[MMarie]

Ik krijg nu (met jouw gehele macro) de melding foto niet beschikbaar.
Ik heb zelf nog geprobeerd het stukje met de 'set pict' toegevoegd aan de oude macro, en ik krijg nu wel standaard de melding foto is niet beschikbaar, als ik dan op ok, druk komt de foto toch. Hier zit dus nog iets geks?

De foto komt nu in de juiste verhouding. Dit werkt enkel voor de staande foto maar niet voor de liggende foto, dan houdt ie de vaste hoogte aan en blijkbaar ook een vaste breedte, en het wordt ineens een staande foto. Ideeen?

hier mijn aanpassing:

Private Sub cmdFotoOpvragen_Click()
Application.ScreenUpdating = False

Dim myObj
Dim Pictur
Set myObj = ActiveSheet.DrawingObjects
For Each Pictur In myObj
If Left(Pictur.Name, 7) = "Picture" Then
Pictur.Select
Pictur.Delete
End If

Next

Dim ClusterNummer As String, FotoNummer As String, T As String

mydir = "G:\mapnaam\"
ClusterNummer = Range("H3")
FotoNummer = "_000"
T = ".jpg"

On Error GoTo ErrorMessage:
ActiveSheet.Shapes.AddPicture Filename:=mydir & ClusterNummer & FotoNummer & T, _
    linktofile:=msoFalse, _
    savewithdocument:=msoTrue, _
        Left:=230, _
        Top:=130, _
        Width:=325, _
        Height:=325
  
  Set Pict = ActiveSheet.Shapes.AddPicture(Foto, _
        msoTrue, msoFalse, -1, -1, 230, 130)
        Pict.Height = 325

ErrorMessage:
If Err.Number = 1004 Then
MsgBox "Foto is niet beschikbaar"

End If
    

Application.ScreenUpdating = True

End Sub

 

[MMarie]

Excuus, er ontbrak bij mij een \ aan het einde van de mapnaam. Jouw macro werkt wel, alleen de foto wordt nu helemaal links boven het werkblad geplaatst en de liggende foto wordt nog steeds niet goed weergegeven (zie vorig bericht)

 

[MMarie]

Ik heb nog aangepast, ook nav macro, volgorde was niet goed, de -1 moesten de laatste 2 zijn en niet de eerste. Dus hij werkt nu naar wens. Bedankt voor de hulp!

Set Pict = ActiveSheet.Shapes.AddPicture(Foto, _
        msoTrue, msoFalse,[COLOR="#FF0000"] 230, 130, -1, -1[/COLOR])
         Pict.Height = 325

 

[edmoor]

Kommaatje vergist dus. Excuus