Etirer une image proportionnellement, au centre d'un contrôle, en limitant à une taille maximum


Commenter

Contenu du snippet 

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

Compatibilité : VB6

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (PCPT)