Sub Stretch(ByRef oDest As Object, sPath As String, Optional ByVal lMaxWidth As Long = 0, Optional ByVal lMaxHeight As Long = 0)
'oDest control avec hDC classique (propriétés hDC, Width, Height, ScaleX-Y, PaintPicture), doit être en twips
'lMaxWidth largeur max, celle du control par défaut
'lMaxHeight hauteur max, celle du control par défaut
Dim lOldWidth As Long
Dim lOldHeight As Long
Dim lNewWidth As Long
Dim lNewHeight As Long
Dim cRatio As Currency
Dim oStd As New StdPicture
' régule la taille MAX par défaut
If (lMaxWidth <= 0) Or (lMaxWidth > oDest.Width) Then lMaxWidth = oDest.Width
If (lMaxHeight <= 0) Or (lMaxHeight > oDest.Height) Then lMaxHeight = oDest.Height
' charge l'image et récupère sa taille
Set oStd = LoadPicture(sPath)
lOldWidth = oDest.ScaleX(oStd.Width, vbHimetric, vbTwips)
lOldHeight = oDest.ScaleY(oStd.Height, vbHimetric, vbTwips)
' orientation, on va étirer l'image au plus possible en touchant la taille max autorisée avec le bord du type d'image. l'autre côté peut tout de même dépasser
If lOldWidth > lOldHeight Then
' image réelle : paysage
lNewWidth = lMaxWidth
cRatio = lMaxWidth / lOldWidth
lNewHeight = lOldHeight * cRatio
If lNewHeight > lMaxHeight Then
' la hauteur dépasse, même manip
cRatio = lMaxHeight / lNewHeight
lNewHeight = lMaxHeight
lNewWidth = lNewWidth * cRatio
End If
Else
' image réelle : portrait
lNewHeight = lMaxHeight
cRatio = lMaxHeight / lOldHeight
lNewWidth = lOldWidth * cRatio
If lNewWidth > lMaxWidth Then
' la largeur dépasse, même manip
cRatio = lMaxWidth / lNewWidth
lNewWidth = lMaxWidth
lNewHeight = lNewHeight * cRatio
End If
End If
' on dessine le rendu centré (NB : l'API StretchBlt donne une trop mauvaise qualité, autant passer par la méthode accessible par le contrôle)
oDest.PaintPicture oStd, (oDest.Width - lNewWidth) / 2, (oDest.Height - lNewHeight) / 2, lNewWidth, lNewHeight, 0, 0, lOldWidth, lOldHeight, vbSrcCopy
Set oStd = Nothing
End Sub
' =====================
' EXEMPLE D'UTILISATION
' =====================
'
Private Sub Command1_Click()
' par exemple sur une picturebox sans bordure, avec l'autoredraw
Picture1.BorderStyle = vbBSNone
Picture1.AutoRedraw = True
Picture1.BackColor = vbRed
' nettoyer si ncéssaire
Picture1.Cls
' Picture1 : on étire l'image en gardant la proportion, sur la taille TOTALE de la box
Call Stretch(Picture1, "C:\image1.jpg")
' Picture1 (aussi !!) : on étire l'image en gardant la proportion, sur la MOITIé de la box (toujours en son centre)
Call Stretch(Picture1, "C:\image1.jpg", Picture1.Width / 2, Picture1.Height / 2)
End Sub