Usercontrol image à partir de gdi+

Télécharger le projet
Commenter

Description

Le usercontrol gdIMG permet d'afficher une image stockée dans le propertybag (pas de fichier dépendant au programme)
l'image peut être un BMP, un PNG, JPG ... (et tient compte de la transparence)

On peut définir une couleur de fond ou activer la transparence pour le control.
On peut définir la transparence de l'image Transparency [0, 1]

On peut choisir parmi les trois comportements
- smNone : tracer l'image à sa taille réelle
- smAutosize : redimensionner le contrôle à la taille réelle de l'image
- smStretch : redimensionner l'image à la taille du contrôle

On peut utiliser les propriétés Offset_X,Offset_Y,Offset_W,Offset_H pour n'afficher qu'une zone de l'image

La propriété "file" permet d'entrer l'adresse du fichier à charger (en mode IDE).
Si on ne spécifie pas une adresse commençant par un nom de périférique "x:" l'adresse est par défaut relative au dossier de développement (app.path)

Le controle possède, en mode édition, les propriétés Update_Enabled et Update_Frequency qui autorisent ou non la recherche automatique de modification du fichier source de l'image (changement de la date de dernière écriture dans le fichier).
Si une modification est détectée le controle demande au programmeur si il souhaite recharger le fichier
- yes -> recharger
- no -> ne pas recharger et ne plus poser la question pour cette modification
- cancel -> ne pas recharger mais reposer la question à la prochaine vérification

Ce UserControl ne possède aucune dépendance (autre que VB6 et GDI+) et peut donc être ajouté très simplement à tout projet VB6.

Source / Exemple : 


Option Explicit
' par flocreate
' controle utilisateur permettant de placer des images
' de plus haute définition que le permet VB6 par défaut...

' DECLARATION DES APIs
'------------------------------------------------------------------------------------------------------------------------------------------
        Private Const Ok = 0
' pour l'ENVIRONEMENT
        Private Type GdiplusStartupInput
            GdiplusVersion As Long
            DebugEventCallback As Long
            SuppressBackgroundThread As Long
            SuppressExternalCodecs  As Long
        End Type
        Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
        Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
' pour le graphic
        Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal Hdc As Long, graphics As Long) As Long
        Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
        Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As Long, ByVal lColor As Long) As Long
' pour le STREAM
        Private Declare Sub CreateStreamOnHGlobal Lib "ole32.dll" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef ppstm As IUnknown)
' pour l'IMAGE
        Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, ByRef Image As Long) As Long
        Private Declare Function GdipLoadImageFromStream Lib "GdiPlus.dll" (ByVal mStream As IUnknown, ByRef mImage As Long) As Long
        Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
        Private Declare Function GdipDrawImage Lib "gdiplus" (ByVal mGraphics As Long, ByVal mImage As Long, ByVal mX As Single, ByVal mY As Single) As Long
        Private Declare Function GdipDrawImageRectI Lib "gdiplus" (ByVal graphics As Long, ByVal nImage As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal Height As Long) As Long
        Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal xDest As Long, ByVal yDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
        Private Declare Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal graphics As Long, ByVal Image As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As Long, ByVal imageAttributes As Long, Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As Long
        Private Const UnitPixel As Long = 2
        Private Declare Function GdipGetImageDimension Lib "gdiplus" (ByVal Image As Long, ByRef Width As Single, ByRef Height As Single) As Long
' changement d'attribut du monde
        Private Enum GpColorAdjustType
            ColorAdjustTypeDefault = 0
            ColorAdjustTypeBitmap = 1
            ColorAdjustTypeBrush = 2
            ColorAdjustTypePen = 3
            ColorAdjustTypeText = 4
            ColorAdjustTypeCount = 5
            ColorAdjustTypeAny = 6
        End Enum
        Private Enum GpColorMatrixFlags
            ColorMatrixFlagsDefault = 0
            ColorMatrixFlagsSkipGrays = 1
            ColorMatrixFlagsAltGray = 2
        End Enum
        Private Enum GpMatrixOrder
            MatrixOrderPrepend = 0
            MatrixOrderAppend = 1
        End Enum
        Private Enum GpCoordinateSpace
            CoordinateSpaceWorld = 0
            CoordinateSpacePage = 1
            CoordinateSpaceDevice = 2
        End Enum
        Private Type GpColorMatrix
            m(4, 4) As Single
        End Type
        Private Type GpPointF
            x As Single
            y As Single
        End Type
        Private Declare Function GdipCreateImageAttributes Lib "gdiplus" (ByRef imageattr As Long) As Long
        Private Declare Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal imageattr As Long) As Long
        Private Declare Function GdipRotateWorldTransform Lib "GdiPlus.dll" (ByVal graphics As Long, ByVal angle As Single, ByVal order As GpMatrixOrder) As Long
        Private Declare Function GdipSetImageAttributesColorMatrix Lib "gdiplus" (ByVal imageattr As Long, ByVal adjustType As GpColorAdjustType, ByVal enableFlag As Boolean, ByRef colorMatrix As GpColorMatrix, ByRef grayMatrix As GpColorMatrix, ByVal flags As GpColorMatrixFlags) As Long

'lecture de date de modif du fichier
        Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
        Private Const GENERIC_READ = &H80000000
        Private Const FILE_SHARE_READ = &H1
        Private Const OPEN_EXISTING = 3
        Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
        Private Type FILETIME
                dwLowDate       As Long
                dwHighDate      As Long
        End Type
        '/!\ précision en fonction de FAT & NTFS, voir msdn pour plus d'informations
        Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
' autre
        Private Declare Function GdipBitmapGetPixel Lib "GdiPlus.dll" (ByVal BITMAP As Long, ByVal x As Long, ByVal y As Long, ByRef color As Any) As Long
        Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
        Private Declare Function GetPixel Lib "gdi32" (ByVal Hdc As Long, ByVal x As Long, ByVal y As Long) As Long
'------------------------------------------------------------------------------------------------------------------------------------------
' LES VARIABLES LOCALES
    ' pour l'environement
    Private HandleEnv As Long           ' handle pour l'environement
    Private SI As GdiplusStartupInput
    ' pour le stream
    Private Bytes() As Byte             ' contenu du fichier image
    Private Stream As IUnknown          ' objet IStream sur la mémoire Bytes
    Private pFileDate As FILETIME       ' date du fichier pour savoir si reload nécéssaire
    Private pFile As String             ' addresse du fichier image

    ' pour l'image
    Private HandleImg As Long           ' handle pour l'image
        Private ImgW As Single, ImgH As Single
    Private pBackColor As OLE_COLOR     ' couleur du fond
    
    Public Enum eSizingMode
        smNone          ' pas d'adaptation
        smAutosize      ' le controle s'adapte à l'image
        smStretch       ' l'image s'adapte au controle
    End Enum
    Private pSizingMode As eSizingMode
    Private pFondTransparent As Boolean
    Private pTransparency As Single
    
    Private Off_X As Long, Off_Y As Long, Off_W As Long, Off_H As Long
'------------------------------------------------------------------------------------------------------------------------------------------
' LES EVENTS
Public Event Click()
Public Event DblClick()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
'------------------------------------------------------------------------------------------------------------------------------------------

'###############################################################################
'###############################################################################
Private Sub UserControl_Initialize()
    'démarer la dll
    SI.GdiplusVersion = 1
    If (GdiplusStartup(HandleEnv, SI) <> Ok) Then
        MsgBox "Une erreur s'est produite lors de l'initialisation de la dll GDI+", vbOKOnly + vbCritical
        HandleEnv = 0
    End If
    'init du stream
    Erase Bytes
    ImgW = 0: ImgH = 0
    Off_X = 0: Off_Y = 0: Off_W = 0: Off_H = 0
    
    pTransparency = 0
    pSizingMode = smNone
    pBackColor = vbWhite
    pFondTransparent = False
End Sub
'###############################################################################
Private Sub UserControl_Terminate()
    ' libérer l'image + le stream
    Call Free_Datas
    ' libérer la dll
    If (HandleEnv <> 0) Then
        Call GdiplusShutdown(HandleEnv)
        HandleEnv = 0
    End If
End Sub
'###############################################################################
'###############################################################################
Private Sub UserControl_WriteProperties(PB As PropertyBag)
    PB.WriteProperty "File", pFile, vbNullString
        PB.WriteProperty "FileDateH", CStr(pFileDate.dwHighDate), "0"
        PB.WriteProperty "FileDateL", CStr(pFileDate.dwLowDate), "0"
        
    PB.WriteProperty "BackColor", pBackColor, vbWhite
    PB.WriteProperty "Bytes", Bytes
    PB.WriteProperty "Enabled", UserControl.Enabled, True
    PB.WriteProperty "FondTransparent", pFondTransparent, False
    PB.WriteProperty "Transparency", pTransparency, 0
    
    PB.WriteProperty "SizingMode", pSizingMode, smNone
    
    PB.WriteProperty "Offset_X", Off_X, "0"
    PB.WriteProperty "Offset_Y", Off_Y, "0"
    PB.WriteProperty "Offset_W", Off_W, "0"
    PB.WriteProperty "Offset_H", Off_H, "0"
    
    PB.WriteProperty "Update_Enabled", TUpdate.Enabled, True
    PB.WriteProperty "UpDate_Frequency", TUpdate.Interval, 1000
End Sub
'###############################################################################
Private Sub UserControl_ReadProperties(PB As PropertyBag)
    Call Free_Datas 'dans le doute on libère les données
    
    pFile = PB.ReadProperty("File", vbNullString)
        pFileDate.dwHighDate = CLng(PB.ReadProperty("FileDateH", "0"))
        pFileDate.dwLowDate = CLng(PB.ReadProperty("FileDateL", "0"))
        
    pBackColor = PB.ReadProperty("BackColor", vbWhite)
    Bytes = PB.ReadProperty("Bytes", Bytes)
    UserControl.Enabled = PB.ReadProperty("Enabled", True)
    pFondTransparent = PB.ReadProperty("FondTransparent", False)
    pTransparency = CByte(PB.ReadProperty("Transparency", 0))
    pSizingMode = PB.ReadProperty("SizingMode", smNone)
    
    Off_X = CLng(PB.ReadProperty("Offset_X", "0"))
    Off_Y = CLng(PB.ReadProperty("Offset_Y", "0"))
    Off_W = CLng(PB.ReadProperty("Offset_W", "0"))
    Off_H = CLng(PB.ReadProperty("Offset_H", "0"))

    'créer l'image à partir du stream
    If Create_Stream Then
        'charger l'image
        Create_Img
    End If
    
    If Not UserControl.Ambient.UserMode Then
        'charger les valeurs
        TUpdate.Enabled = PB.ReadProperty("Update_Enabled", True)
        TUpdate.Interval = CLng(PB.ReadProperty("UpDate_Frequency", 1000))
        'savoir si besoin de recharger le fichier
        Call Maj_File
    Else
        'désactiver la maj auto
        TUpdate.Enabled = False
    End If
End Sub
'###############################################################################
'###############################################################################
Private Sub UserControl_Show()
    Draw
End Sub
Private Sub UserControl_Resize()
    Draw
End Sub
Private Sub UserControl_Paint()
'    Draw
End Sub
'###############################################################################
'###############################################################################
Private Sub UserControl_Click()
    RaiseEvent Click
End Sub
Private Sub UserControl_DblClick()
    RaiseEvent DblClick
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub
Private Sub UserControl_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    RaiseEvent MouseDown(Button, Shift, x, y)
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    RaiseEvent MouseMove(Button, Shift, x, y)
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    RaiseEvent MouseUp(Button, Shift, x, y)
End Sub
'###############################################################################
'###############################################################################

'###############################################################################
'###############################################################################
Public Property Get TransparentBackground() As Boolean
    TransparentBackground = pFondTransparent
End Property
Public Property Let TransparentBackground(NwValue As Boolean)
    pFondTransparent = NwValue
    PropertyChanged "TransparentBackground": Draw
End Property
'###############################################################################
Public Property Get BackColor() As OLE_COLOR
    BackColor = pBackColor
End Property
Public Property Let BackColor(NwColor As OLE_COLOR)
    pBackColor = NwColor
    PropertyChanged "BackColor": Draw
End Property
'###############################################################################
Public Property Get SizingMode() As eSizingMode
    SizingMode = pSizingMode
End Property
Public Property Let SizingMode(NwV As eSizingMode)
    pSizingMode = NwV
    PropertyChanged "SizingMode": Draw
End Property
'###############################################################################
Public Property Get Enabled() As Boolean
    Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(NwValue As Boolean)
    UserControl.Enabled = NwValue
    PropertyChanged "Enabled"   'on ne demande pas le réafichage pour cette méthode
End Property
'###############################################################################
Public Property Get File() As String
    File = Replace(pFile, "./", "")
End Property
Public Property Let File(NwFile As String)
' Disponible uniquement dans l'IDE
If (Not UserControl.Ambient.UserMode) Then

    Dim TmpAdd As String    ' adresse temporaire du nouveau fichier
    Dim tmpImg As Long      ' on va ouvrire le fichier pour vérifier qu'il est valide
    Dim res As Long
    
    If (Mid(NwFile, 2, 1) = ":") Then
        TmpAdd = NwFile
    Else
        TmpAdd = App.Path & "\" & NwFile
    End If

    If (Dir(TmpAdd) <> "") Then
        res = GdipLoadImageFromFile(StrConv(TmpAdd, vbUnicode), tmpImg) 'ne pas oublier le strconv ^^
        If (res = Ok) Then
            'libérer l'image qui a servit pour le test
            res = GdipDisposeImage(tmpImg)

            'charger l'image
            TmpAdd = Format_Add(TmpAdd)
            If (pFile <> TmpAdd) Then
                pFile = TmpAdd
                Call Free_Datas
                If Load_From_File(UnFormat_Add(pFile)) Then
                    If Create_Stream Then
                        If Create_Img Then
                            PropertyChanged "File": Draw
                        Else
                            pFile = ""  'sécu
                            PropertyChanged "File": Draw
                        End If
                    Else
                        pFile = ""  'sécu
                        PropertyChanged "File": Draw
                    End If
                Else
                    pFile = ""  'sécu
                    PropertyChanged "File": Draw
                End If
            End If
        Else
            Call MsgBox("Bad File", vbCritical + vbOKOnly)
        End If
    Else
        Call MsgBox("File Not Found" & vbCrLf & "'" & TmpAdd & "'", vbExclamation + vbOKOnly)
    End If
End If
End Property
'###############################################################################
Public Property Get UpDate_Enabled() As Boolean
    UpDate_Enabled = TUpdate.Enabled
End Property
Public Property Let UpDate_Enabled(NwV As Boolean)
If Not UserControl.Ambient.UserMode Then    'que dans l'IDE
        If (NwV = True) Then Call Maj_File
        TUpdate.Enabled = NwV
        PropertyChanged "UpDate_Enabled"
End If
End Property
Public Property Get UpDate_Frequency() As Long
    UpDate_Frequency = TUpdate.Interval
End Property
Public Property Let UpDate_Frequency(NwVal As Long)
If Not UserControl.Ambient.UserMode Then    'que dans l'IDE
        If (NwVal <= 0) Then
            UpDate_Enabled = False
        Else
            TUpdate.Interval = NwVal
            PropertyChanged "UpDate_Frequency"
        End If
End If
End Property
Private Sub TUpdate_Timer()
    Maj_File
End Sub
Private Function Get_FileTime(add As String) As FILETIME
    'ouvrire le fichier en mode lecture seule non blocant
    Dim hFile As Long
        hFile = CreateFile(add, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
    If (hFile <> 0) Then
        'lire les dates
        Dim Creation As FILETIME, Access As FILETIME, Modification As FILETIME
        Call GetFileTime(hFile, Creation, Access, Modification)
        'fermer le fichier
        Call CloseHandle(hFile)
        
        Get_FileTime = Modification
    End If
End Function
Private Sub Maj_File()
' ne faire que dans l'IDE
If Not UserControl.Ambient.UserMode Then
        'ne faire que si un fichier est contenu dans le stream
        If (Not Stream Is Nothing) Then
            Dim TmpAdd As String
                TmpAdd = UnFormat_Add(pFile)
            
            If (Dir(TmpAdd) <> "") Then
                'le fichier a bien été trouvé, comparer les dates
                Dim NwTime As FILETIME
                    NwTime = Get_FileTime(TmpAdd)
                    
                If (NwTime.dwHighDate <> pFileDate.dwHighDate) Or (NwTime.dwLowDate <> pFileDate.dwLowDate) Then
                    Dim res As VbMsgBoxResult
                        res = MsgBox(Replace(pFile, "./", "") & vbCrLf & _
                                     "The source file has been modified." & vbCrLf & _
                                     "Reload It ?", vbYesNoCancel + vbQuestion)
                    If (res = vbYes) Then
                        'libérer les données
                        Call Free_Datas
                        'charger le fichier
                        If Load_From_File(UnFormat_Add(pFile)) Then
                            'créer l'image à partir du stream
                            If Create_Stream Then
                                'charger l'image
                                Call Create_Img
                            End If
                        End If
                        'maj de la date
                        pFileDate = NwTime
                        PropertyChanged "FileDate": Draw
                    ElseIf (res = vbNo) Then
                        'maj de la date sans recharger le fichier
                        pFileDate = NwTime
                        PropertyChanged "FileDate"
                    Else '(res = vbCancel)
                        'ne rien faire, on redemandera la prochaine fois
                    End If
                End If
            Else
                'le fichier n'a pas été trouvé, recréer à partir du stream ?
                '[ ... ]
            End If
        End If
End If
End Sub
'###############################################################################
Public Property Get ImgWidth() As Long
    ImgWidth = CLng(ImgW)
End Property
Public Property Let ImgWidth(val As Long)
End Property
Public Property Get ImgHeight() As Long
    ImgHeight = CLng(ImgH)
End Property
Public Property Let ImgHeight(val As Long)
End Property
'###############################################################################
Public Property Get Offset_X() As Long
    Offset_X = Off_X
End Property
Public Property Get Offset_Y() As Long
    Offset_Y = Off_Y
End Property
Public Property Get Offset_W() As Long
    Offset_W = Off_W
End Property
Public Property Get Offset_H() As Long
    Offset_H = Off_H
End Property
Public Property Let Offset_X(NwVal As Long)
    Off_X = NwVal
    PropertyChanged "Offset_X": Draw
End Property
Public Property Let Offset_Y(NwVal As Long)
    Off_Y = NwVal
    PropertyChanged "Offset_Y": Draw
End Property
Public Property Let Offset_W(NwVal As Long)
    Off_W = NwVal
    PropertyChanged "Offset_W": Draw
End Property
Public Property Let Offset_H(NwVal As Long)
    Off_H = NwVal
    PropertyChanged "Offset_H": Draw
End Property
'###############################################################################
Public Property Get Transparency() As Single
    Transparency = pTransparency
End Property
Public Property Let Transparency(NwV As Single)
    If (NwV < 0) Then NwV = 0
    If (NwV > 1) Then NwV = 1
    pTransparency = NwV
    PropertyChanged "Transparency": Draw
End Property
'###############################################################################
Public Property Get Hwnd() As Long
    Hwnd = UserControl.Hwnd
End Property
Public Property Get Hdc() As Long
    Hdc = UserControl.Hdc
End Property
'###############################################################################
'###############################################################################

'###############################################################################
'###############################################################################
Public Sub Refresh()
    Draw
End Sub
Private Sub Draw()
On Error Resume Next
    
    'si nécéssaire, on remplit le fond avec l'image de parent --> simule transparence
    If pFondTransparent Then Call MakeContainerTransparent

    Dim HandleGraph As Long
    If (GdipCreateFromHDC(UserControl.Hdc, HandleGraph) = Ok) Then
                
        ' effacer le graphic avec la couleur de fond
        If Not pFondTransparent Then Call GdipGraphicsClear(HandleGraph, CC_to_GDI(pBackColor))

        ' Définir les dimensions de la destination
        Dim dW As Single, dH As Single
        If (pSizingMode = smAutosize) Then
            'on défini la taille de l'image (en Pixels)
            dW = ImgWidth
            dH = ImgHeight
            'on redimensionne le controle en fonction de la taille de l'image
            Dim NwW As Long, NwH As Long
                NwW = ScaleX(dW, vbPixels, Parent.ScaleMode)
                NwH = ScaleY(dH, vbPixels, Parent.ScaleMode)
            If (NwW > 0) Then UserControl.Width = NwW
            If (NwH > 0) Then UserControl.Height = NwH
        
        ElseIf (pSizingMode = smStretch) Then
            'on redimentionne l'image en fonction de la taille du controle
            dW = IIf((UserControl.Parent.ScaleMode = vbPixels), UserControl.Width, UserControl.Width / Screen.TwipsPerPixelX)
            dH = IIf((UserControl.Parent.ScaleMode = vbPixels), UserControl.Height, UserControl.Height / Screen.TwipsPerPixelY)
        Else '(pSizingMode = smNone) Then
            dW = ImgWidth
            dH = ImgHeight
        End If
        
        ' Définir les dimensions de la source
        Dim pW As Long: pW = IIf((Off_W > 0), Off_W, ImgW)
        Dim pH As Long: pH = IIf((Off_H > 0), Off_H, ImgH)
        
        
        'changer les attributs du graphique
        Dim hImageAttr As Long, res As Long
        res = GdipCreateImageAttributes(hImageAttr)
        Dim lpColorMatrix As GpColorMatrix
            With lpColorMatrix
                .m(0, 0) = 1
                .m(1, 1) = 1
                .m(2, 2) = 1
                .m(3, 3) = pTransparency
                .m(4, 4) = 1
            End With
        'renseigner les attributs
        res = GdipSetImageAttributesColorMatrix(hImageAttr, ColorAdjustTypeBitmap, True, lpColorMatrix, lpColorMatrix, ColorMatrixFlagsDefault)
            
        'tracer l'image
        res = GdipDrawImageRectRectI(HandleGraph, HandleImg, 0, 0, dW, dH, Off_X, Off_Y, pW, pH, UnitPixel, hImageAttr, 0, 0)

        'libérer les attributs d'image
        res = GdipDisposeImageAttributes(hImageAttr)
        
        ' libérer le graphic
        res = GdipDeleteGraphics(HandleGraph)
        
        UserControl.Refresh
    End If
End Sub
'###############################################################################
Private Function Load_From_File(file_add As String) As Boolean
' on part du principe que les variables requises sont libres (libérées)
On Error Resume Next
    'trouver la taille du fichier
    Dim pSize As Long: pSize = FileLen(file_add)    'si le fichier n'existe pas : provoque une erreur
    If (Err.Number <> 0) Then Exit Function  ' return false
    'initialiser le tableau de bytes
    ReDim Bytes(0 To pSize - 1)
    If (Err.Number <> 0) Then Exit Function  ' return false
    'ovrire le fichier
    Dim canal As Byte: canal = FreeFile
    Open (file_add) For Binary Access Read As #canal
    If (Err.Number <> 0) Then Exit Function  ' return false
    'charger le fichier en un coup (bcp plus rapide que byte par byte ^^)
    Get #canal, , Bytes
    'fermer le fichier
    Close #canal
    'sauver la date du fichier pour la détection de majs
    pFileDate = Get_FileTime(file_add)
    
    'retourner le résultat (Reussite ou Echec)
    Load_From_File = CBool(Err.Number = 0)
End Function
Private Function Create_Stream() As Boolean
' on part du principe que les variables requises sont libres (libérées)
On Error Resume Next
    'créer le stream à partir du tableau de bytes
    Call CreateStreamOnHGlobal(VarPtr(Bytes(0)), False, Stream)
    
    'retourner le résultat (Reussite ou Echec)
    Create_Stream = CBool(Err.Number = 0)
    
    ImgW = 0: ImgH = 0
End Function
Private Function Create_Img() As Boolean
    ' on part du principe que les variables requises sont libres (libérées)
    Create_Img = CBool(GdipLoadImageFromStream(Stream, HandleImg) = Ok)
    Call GdipGetImageDimension(HandleImg, ImgW, ImgH)
End Function
Private Function Free_Datas()
    ' libérer l'image
    If (HandleImg <> 0) Then
        Call GdipDisposeImage(HandleImg)
        HandleImg = 0
    End If
    ' libérer le stream
    If (Not Stream Is Nothing) Then
        Set Stream = Nothing
        Erase Bytes
    End If
    'reseter la date
    pFileDate.dwHighDate = 0
    pFileDate.dwLowDate = 0
End Function
'###############################################################################
Private Function Format_Add(add As String) As String
    ' à partir d'une adresse absolue, créer une adresse relative à l'executable / ou projet
    ' "app.path\" -> "./"
    If (Len(add) < 2) Then
        Format_Add = add
    Else
        If (InStr(1, add, App.Path & "\") = 1) Then
            Format_Add = Replace(add, App.Path & "\", "./", 1, 1)
        Else
            Format_Add = add
        End If
    End If
End Function
Private Function UnFormat_Add(add As String) As String
    ' à partir d'une variable relative, créer une adresse absolue
    ' "./" -> "app.path\"
    UnFormat_Add = Replace(add, "./", App.Path & "\", 1, 1)
End Function
'###############################################################################
Private Function CC_to_GDI(ByVal c As ColorConstants) As Long
    Dim T(3) As Byte
    CopyMemory T(0), c, 4
    Dim tmp As Byte: tmp = T(0): T(0) = T(2): T(2) = tmp  'inversion Rouge & Bleu
    T(3) = &HFF
    CopyMemory CC_to_GDI, T(0), 4
End Function
'###############################################################################
'###############################################################################

Private Sub MakeContainerTransparent()
On Error Resume Next

   Dim ctl As Control
   Dim h1 As Long, h2 As Long
   
    h2 = UserControl.Hdc               ' the dc of this control.
    If UserControl.Parent.Hwnd = UserControl.ContainerHwnd Then
        UserControl.Parent.AutoRedraw = True
        h1 = UserControl.Parent.Hdc
    Else
        'the container resides in another container, so use parent container's hDC.
        For Each ctl In UserControl.Parent.Controls
            'find container.
            If ctl.Hwnd = UserControl.ContainerHwnd Then 'Found our container
                ctl.AutoRedraw = True 'AutoRedraw must be True
                h1 = ctl.Hdc 'Get the containers hDC
                Exit For
            End If
        Next
    End If
    '  get offsets for BitBlt.
    Dim dL As Long: dL = UserControl.Extender.Left
    Dim dT As Long: dT = UserControl.Extender.Top
    Dim dW As Long: dW = UserControl.ScaleWidth
    Dim dH As Long: dH = UserControl.ScaleHeight
    If (UserControl.Extender.Container.ScaleMode = vbTwips) Then
        dL = dL / Screen.TwipsPerPixelX
        dT = dT / Screen.TwipsPerPixelY
        dW = dW / Screen.TwipsPerPixelX
        dH = dH / Screen.TwipsPerPixelY
    End If
    '  Copy background to our usercontrol hDC.
    Call BitBlt(h2, 0, 0, dW, dH, h1, dL, dT, vbSrcCopy)
End Sub

Conclusion :


Le projet présente une image d'émoticon au format JPG (essayez d'avoir une image de cette "qualité" en VB6 avec les composants classiques :s)

Le projet présente également une démonstration des propriétés Offset à travers l'implémentation d'un bouton 3 états (UP,OVER,DOWN)

Les commentaires & suggestions sont les bienvenus...
Bien cordialement
Télécharger le projet

Codes Sources

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 (Flocreate)