VBA Fotobreedte wijzigen als de breedte te groot is

[matthiej88]

Hallo mensen,

Voor het maken van een fotorapportage maken we gebruik van een macro. De macro gaat per object twee foto's toevoegen m.b.v. een loop. De macro zorgt voor een vaste fotohoogte, zodat deze in de betreffende rij past en het direct opmaaktechnisch ook goed staat.

Het gaat echter alleen fout als de lengte-breedte verhouding van de foto te veel uit verhouding is. De fotohoogte klopt dan, maar omdat de foto heel breed word, gaat hij het afdrukbereik aanpassen.

Nu wil ik de hoogte altijd op 160 houden en de breedte alleen aanpassen als het echt nodig is (i.v.m. verhouding).

Hier ff een stukje code om e.e.a wat te verduidelijken:

Sheets("Fotorapportage").Select
ActiveSheet.Pictures.Insert(Fpth).Select
With Selection
        .Height = 160
If .Width > 180 Then .Width = 180
End If
        .Top = Range("B9").Top
If Y = 1 Then
        .Left = Range("B9").Left
Else
        .Left = Range("C9").Left
End If
End With

Ik zat zelf te denken om iets als dit in de macro te zetten:

if .width >180 then 
.width = 180 
end with

Dit werkt natuurlijk niet, maar ik weet niet hoe ik het wel goed moet schrijven.

Graag jullie hulp, alvast bedankt!

Matthijs

 

[Cobbe]

Je zal deze regel er ergens moeten tussenwringen:

Selection.ShapeRange.LockAspectRatio = msoFalse

 

[paulva]

Volgens mij gaat het met de volgende code lukken. Je laadt de foto eerst in de image1 met picturesizemode op 0, hierdoor blijft de verhouding tussen hoogte en breedte correct.

voorbeeld: hoogte 20000, breedte 80000. Verhouding 4
Breedte/hoogte >2
dus breedte = 200, hoogte = 50

voorbeeld2: hoogte 80000, breedte 20000. Verhouding 0,25
Breedte/hoogte <2
dus hoogte = 100, breedte = 25

(edit: image1.visible = false natuurlijk)

'picturesizemode op 0 voor Image1
'picturesizemode op 1 voor Image2

'maximum hoogte 100
'maximum breedte 200
'verhouding = 200/100, dus 2

        Image1.Picture = LoadPicture(ActiveWorkbook.Path & "/" & ActiveCell.Value)
        Image2.Picture = LoadPicture(ActiveWorkbook.Path & "/" & ActiveCell.Value)
        
        If Image1.Picture.Width / Image1.Picture.Height > 2 Then
            Image2.Width = 200
            Image2.Height = 200 * Image1.Picture.Height / Image1.Picture.Width
        Else
            Image2.Height = 100
            Image2.Width = 100 * Image1.Picture.Width / Image1.Picture.Height
        End If