afmetingen van een figuur in excel wijzigen

[Justme47]

Wanneer ik plaatjes (Jpeg) invoeg in een excel werkblad dan is de afmeting telkens verschillend van grootte.
Dit komt natuurlijk door de resolutie van deze plaatjes.

Maar hoe krijg ik het in excel VBA voor elkaar dat deze plaatjes allemaal even groot zijn?


Gerhard

 

[wampier]

Als alles een standaard grootte moet krijgen kun je het volgende gebruiken:

Dim plaatje As Object
For Each plaatje In ActiveSheet.Pictures
    plaatje.height = 400
    plaatje.width = 400
Next plaatje

 

[Warme bakkertje]

Op welke manier voeg je de plaatjes in ?

 

[Justme47]

Het plaatje wordt ingevoegd via Invoegen-Figuur-Uit bestand.

Met dank aan Wampier gebruik ik nu de volgende Sub:

Sub plaatjes_invoegen()

Range("A2").Select
    ActiveSheet.Pictures.Insert("C:\plaatjes\Blue hills.jpg").Select
    ' het pad moet telkens worden aangepast om het goede plaatje te krijgen

    Dim plaatje As Object
For Each plaatje In ActiveSheet.Pictures
    plaatje.Height = 600
    plaatje.Width = 400
Next plaatje

End Sub

Dit werkt prima maar ik kom 2 probleempjes tegen.

1 Nu wordt altijd hetzelfde plaatje ingelezen en aangepast.
Bestaat er een routine die een soort verkenner opent waarmee ik mijn plaatjes kan selecteren en inlezen?

2 Het ingelezen plaatje wordt gedimensioneerd naar hoogte 600 en breedte 400.
De verhouding hoogte/breedte klopt dan niet meer.
Graag zou ik de breedte willen ingeven, waarbij de hoogte dan automatisch wordt ingesteld zodat het plaatje niet vervormt.

 

[Warme bakkertje]

Sub Insert_Pict()
'plakken in actieve cel
Dim ImgFileFormat As String, pic As Variant
On Error Resume Next
ImgFileFormat = "Image Files jpg (*.jpg),*.jpg,(*.bmp),others, tif (*.tif),*.tif"
Set pic = ActiveSheet.Pictures.Insert(Application.GetOpenFilename(ImgFileFormat))
On Error GoTo 0
    If Not pic Is Nothing Then
        Set rng = ActiveCell
        With pic
            .Height = rng.Height
            .Width = rng.Width
            .Left = rng.Left
            .Top = rng.Top
            .Placement = xlMoveAndSize
        End With
    End If
End Sub

of

Sub Insert_Pict()
'plakken in variabel bereik
Dim ImgFileFormat As String, pic As Variant
On Error Resume Next
Application.DisplayAlerts = False
Set rng = Application.InputBox("Selecteer bereik", "Foto invoegen", , , , , , 8)
ImgFileFormat = "Image Files jpg (*.jpg),*.jpg,(*.bmp),others, tif (*.tif),*.tif"
Set pic = ActiveSheet.Pictures.Insert(Application.GetOpenFilename(ImgFileFormat))
    If Not pic Is Nothing Then
        With pic
            .Height = rng.Height
            .Width = rng.Width
            .Left = rng.Left
            .Top = rng.Top
            .Placement = xlMoveAndSize
        End With
    Else: Exit Sub
    End If
Application.DisplayAlerts = True
End Sub

 

[Justme47]

bedankt Warme Bakkertje

De beide Sub's werken prima.

Bij de tweede Sub (plakken in een variabel bereik) moet ik een bereik selecteren en de Sub zet daar dan het plaatje in.
De verhouding hoogte/breedte is gelijk aan het geselecteerde gebied.
Graag had ik een routine waarbij de breedte van het plaatje al vast ligt en dat de hoogte uit het in te lezen plaatje wordt afgeleid, zodat de verhoudingen blijven kloppen.

Kan dat?

 

[wampier]

je kan redelijk eenvoudig de verhouding opslaan in een tussenvariabele:.

Dim plaatje As Object
Dim verhouding as Double
For Each plaatje In ActiveSheet.Pictures
    verhouding = plaatje.height / plaatje.width
    plaatje.height = verhouding * 400
    plaatje.width = 400
Next plaatje

 

[Justme47]

De uiteindelijke routine gaat er ongeveer zo uitzien:

Sub plaatje_inlezen_in_excel()

'plaatje inlezen op links boven op 10.10 
Dim ImgFileFormat As String, pic As Variant
On Error Resume Next
Application.DisplayAlerts = False
'Set rng = Application.InputBox("Selecteer bereik", "Foto invoegen", , , , , , 8)
ImgFileFormat = "Image Files jpg (*.jpg),*.jpg,(*.bmp),others, tif (*.tif),*.tif, tiff (*.tiff),*.tiff"
Set pic = ActiveSheet.Pictures.Insert(Application.GetOpenFilename(ImgFileFormat))
    If Not pic Is Nothing Then
        With pic
            '.Height = rng.Height
            '.Width = rng.Width
            '.Left = rng.Left
            .Left = 10
             '.Top = rng.Top
             .Top = 10
            .Placement = xlMoveAndSize
        End With
    Else: Exit Sub
    End If
 
'Plaatje dimensioneren op breedte 400 de hoogte is afhankelijk van de hoogte van het plaatje  
Dim plaatje As Object
Dim verhouding As Double
For Each plaatje In ActiveSheet.Pictures
    verhouding = plaatje.Height / plaatje.Width
    plaatje.Height = verhouding * 400
    plaatje.Width = 400
Next plaatje

Application.DisplayAlerts = True
End Sub

Deze routine werkt met hulp van Wampier en Warme Bakkertje zoals ik hoopte maar moet nog worden opgeschoond.

Een paar vragen nog:
waar staat rng voor?
wat doet .Placement = xlMoveAndSize ?

 

[Warme bakkertje]

rng is een variabele die het gekozen bereik in de inputbox vertegenwoordigt. Je gebruikt deze variabele om de afbeelding te positioneren. Moveandsize past de grootte v/d afbeelding aan aan het gekozen bereik.

 

[Justme47]

Bedankt!
Alles duidelijk.