IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Contribuez Discussion :

GdiPlus : Rotation image / Décomposition des Gifs animés [Sources]


Sujet :

Contribuez

  1. #1
    Responsable Access

    Avatar de Arkham46
    Profil pro
    Inscrit en
    Septembre 2003
    Messages
    5 865
    Détails du profil
    Informations personnelles :
    Localisation : France, Loiret (Centre)

    Informations forums :
    Inscription : Septembre 2003
    Messages : 5 865
    Points : 14 522
    Points
    14 522
    Par défaut GdiPlus : Rotation/Redimensionnement/Découpage image + Gif animé
    EDIT :
    Ce module de code n'est plus à jour, utilisez plutôt :
    http://arkham46.developpez.com/artic...fice/clgdiplus


    Fonctionnalitées :
    - Chargement d'images au format Jpeg/Gif/Png/Tiff/Bmp
    - Rotation et retournement(mirroir) d'images
    - Redimensionnement de l'image
    - Découpage de l'image
    - Décomposition des Gif animés
    - Sauvegarde au format Jpeg/Gif/Png/Tiff/Bmp
    - Affichage de l'image dans un contrôle image Access

    Téléchargez d'abord GdiPlus si vous ne l'avez pas sur votre PC (la librairie est intégrée à XP)
    téléchargez gdiplus

    Mettez la librairie gdiplus.dll de préférence dans le répertoire de l'application
    Ensuite, créer un nouveau module de classe et placez-y le code du message suivant.

    Sauvegardez le module de classe sous le nom ClGdiPlus.

    Les fonctions :
    OpenFile : Ouvre un fichier
    - pFile : nom du fichier
    - pWidth : largeur de l'image
    - pHeight : hauteur de l'image
    - pSaveOriginal : Vrai pour conserver l'image originale
    (laissez à Faux si vous ne vous servez pas de ResetImage)
    SaveFile : Sauvegarde le fichier ouvert au format Jpeg :
    - pFile : Nom du fichier
    - pFormat : Format du fichier : JPG,GIF,BMP,PNG,TIF
    - pQuality : Qualité du fichier pour JPG, de 0 à 100, laisser le paramètre vide pour sauvegarder avec la qualité du fichier source
    ResetImage : restaure l'image originale
    (si pSaveOriginal était égal à vrai lors de l'ouverture du fichier)
    CloseFile : Ferme le fichier ouvert
    ResizeImage : Redimensionne l'image
    - pWidth : Largeur de l'image
    - pHeight : Hauteur de l'image
    CropImage : Découpe l'image
    - pLeft : Position à gauche
    - pTop : Position en haut
    - pWidth : Largeur de la découpe
    - pHeight : Hauteur de la découpe
    RotateFlip : Rotation et/ou effet mirroir
    - pType : type de traitement, utilisez les propriétés avec Access97, les énumérations à partir de Access 2000
    GifGetFrameCount : Renvoit le nombre d'images d'un Gif animé
    GifGetFrameDelay : Renvoit le délai d'affichage de chaque image d'un Gif Animé (tableau de long)
    GifSetFrame : Affecte une image d'un gif animé
    - pFrame : numéro de l'image
    GdiPlusToPictureData : Renvoit un tableau PictureData contenant l'image

    Les transformations sont appliquées à l'image courante (donc les transformations se cumulent).
    Pour revenir à l'image d'origine, utiliser la fonction ResetImage.


    Les fonctions s'appliquent à une image stockée en mémoire.
    Pour visualiser l'image, utiliser la fonction GdiPlusToPictureData.


    Exemple : Rotation d'une image de 90° puis sauvegarde
    Code à mettre dans le module d'un formulaire, avec un contrôle image nommé Image0.
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    Option Compare Database
    Option Explicit
     
    Private ClGDIP As New ClGdiPlus
     
    Private Sub MonBoutonAffichage_Click()
    ' ouvre le fichier
    ClGDIP.OpenFile "c:\MonFichier.jpeg"
    ' Rotation de 90°
    ClGDIP.RotateFlip ClGDIP.zRotate90FlipNone
    ' Pour Access >=2000 utiliser la ligne suivante à la place de la ligne précédente:
    ' ClGDIP.RotateFlip Rotate90FlipNone
    ' Affecte l'image au contrôle 
    Me.Image0.PictureData = ClGDIP.GdiPlusToPictureData
    ' Sauvegarde l'image au format Jpeg
    ClGDIP.SaveFile "c:\MonFichier_90.jpeg"
    ' Sauvegarde l'image au format Png
    ClGDIP.SaveFile "c:\MonFichier_90.png","PNG"
    End Sub
    Exemple : Affichage d'un gif animé
    Code à mettre dans le module d'un formulaire, avec un contrôle image nommé Image0.
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
     
    Option Compare Database
    Option Explicit
     
    Private ClGDIP As New ClGdiPlus
    Private FrameNb As Long ' Image du Gif animé en cours d'affichage
    Private FrameCount As Long ' Nombre d'images du Gif animé
    Private FrameDelay As Variant ' Délai entre chaque image du Gif animé
     
    Private Sub MonBouton_Click()
    ' Ouvre le fichier
    ClGDIP.OpenFile "c:\MonGifAnimé.gif"
    ' Nombre d'images du Gif animé
    FrameCount = ClGDIP.GifGetFrameCount
     ' Délai entre chaque image du Gif animé
    FrameDelay = ClGDIP.GifGetFrameDelay
    ' Affiche la première image du Gif animé
    Me.Image0.PictureData = ClGDIP.GdiPlusToPictureData
    ' Initialise le numéro d'image 
    FrameNb = 1
    ' Lance la minuterie avec le délai de la première image
    ' Les délais sont exprimés en dizièmes de seconde
    Me.TimerInterval = FrameDelay(0) * 10
    End Sub
     
    Private Sub Form_Timer()
    ' Avance le compteur d'une image
    FrameNb = FrameNb + 1
    ' Si on atteint la dernière image, on revient à la première
    If FrameNb > FrameCount Then FrameNb = 1
    ' Change la minuterie avec le délai de l'image en cours
    Me.TimerInterval = FrameDelay(FrameNb - 1) * 10
    ' Change l'image en cours
    ClGDIP.GifSetFrame FrameNb - 1
    ' Affiche la nouvelle image
    Me.Image0.PictureData = ClGDIP.GdiPlusToPictureData
    ' Traite les messages pour ne pas bloquer l'application
    DoEvents
    End Sub
    Une base d'exemple au format Access 97 ICI (ou ):
    - sélection d'une image d'un gif animé
    - rotation d'une image de 90°
    - zoom sur une image
    - déplacement de l'image zoomée par drag&drop
    - sauvegarde de l'image

  2. #2
    Responsable Access

    Avatar de Arkham46
    Profil pro
    Inscrit en
    Septembre 2003
    Messages
    5 865
    Détails du profil
    Informations personnelles :
    Localisation : France, Loiret (Centre)

    Informations forums :
    Inscription : Septembre 2003
    Messages : 5 865
    Points : 14 522
    Points
    14 522
    Par défaut
    Créer un nouveau module de classe et placez-y le code suivant:

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    214
    215
    216
    217
    218
    219
    220
    221
    222
    223
    224
    225
    226
    227
    228
    229
    230
    231
    232
    233
    234
    235
    236
    237
    238
    239
    240
    241
    242
    243
    244
    245
    246
    247
    248
    249
    250
    251
    252
    253
    254
    255
    256
    257
    258
    259
    260
    261
    262
    263
    264
    265
    266
    267
    268
    269
    270
    271
    272
    273
    274
    275
    276
    277
    278
    279
    280
    281
    282
    283
    284
    285
    286
    287
    288
    289
    290
    291
    292
    293
    294
    295
    296
    297
    298
    299
    300
    301
    302
    303
    304
    305
    306
    307
    308
    309
    310
    311
    312
    313
    314
    315
    316
    317
    318
    319
    320
    321
    322
    323
    324
    325
    326
    327
    328
    329
    330
    331
    332
    333
    334
    335
    336
    337
    338
    339
    340
    341
    342
    343
    344
    345
    346
    347
    348
    349
    350
    351
    352
    353
    354
    355
    356
    357
    358
    359
    360
    361
    362
    363
    364
    365
    366
    367
    368
    369
    370
    371
    372
    373
    374
    375
    376
    377
    378
    379
    380
    381
    382
    383
    384
    385
    386
    387
    388
    389
    390
    391
    392
    393
    394
    395
    396
    397
    398
    399
    400
    401
    402
    403
    404
    405
    406
    407
    408
    409
    410
    411
    412
    413
    414
    415
    416
    417
    418
    419
    420
    421
    422
    423
    424
    425
    426
    427
    428
    429
    430
    431
    432
    433
    434
    435
    436
    437
    438
    439
    440
    441
    442
    443
    444
    445
    446
    447
    448
    449
    450
    451
    452
    453
    454
    455
    456
    457
    458
    459
    460
    461
    462
    463
    464
    465
    466
    467
    468
    469
    470
    471
    472
    473
    474
    475
    476
    477
    478
    479
    480
    481
    482
    483
    484
    485
    486
    487
    488
    489
    490
    491
    492
    493
    494
    495
    496
    497
    498
    499
    500
    501
    502
    503
    504
    505
    506
    507
    508
    509
    510
    511
    512
    513
    514
    515
    516
    517
    518
    519
    520
    521
    522
    523
    524
    525
    526
    527
    528
    529
    530
    531
    532
    533
    534
    535
    536
    537
    538
    539
    540
    541
    542
    543
    544
    545
    546
    547
    548
    549
    550
    551
    552
    553
    554
    555
    556
    557
    558
    559
    560
    561
    562
    563
    564
    565
    566
    567
    568
    569
    570
    571
    572
    573
    574
    575
    576
    577
    578
    579
    580
    581
     
    Option Compare Database
    Option Explicit
     
    '***************************************************************************************
    '*                      CLASSE POUR UTILISATION DE GDIPLUS                             *
    '***************************************************************************************
    ' Fonctionnalitées :
    ' Chargement d'images au format Jpeg/Gif/Png/Tiff/Bmp
    ' Rotation et retournement(mirroir) d'images
    ' Redimensionnement de l'image
    ' Découpage de l'image
    ' Décomposition des Gif animés
    ' Sauvegarde au format Jpeg/Gif/Png/Tiff/Bmp
    ' Affichage de l'image dans un contrôle image Access
    '***************************************************************************************
    ' Auteur : Thierry GASPERMENT (Arkham46)
    ' v0.3 (08/11/06)
    ' Nécessite GDI+
    ' Le code est libre pour toute utilisation
    '***************************************************************************************
     
    '***************************************************************************************
    '*                                      LIENS                                          *
    '***************************************************************************************
    ' Téléchargement de GdiPlus.dll
    ' http://www.microsoft.com/downloads/details.aspx?FamilyID=6a63ab9c-df12-4d41-933c-be590feaa05a&DisplayLang=en
    '***************************************************************************************
    '*                                       API                                           *
    '***************************************************************************************
    ' Gestion des dll
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    ' API GDI+
    Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
    Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal FileName As Long, ByRef bitmap As Long) As Long
    Private Declare Function GdipGetPropertyItem Lib "gdiplus" (ByVal image As Long, ByVal propId As Long, _
                                                                ByVal propSize As Long, ByRef buffer As Any) As Long
    Private Declare Function GdipGetPropertyItemSize Lib "gdiplus" (ByVal image As Long, ByVal propId As Long, _
                                                                    ByRef Size As Long) As Long
    Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, LInput As GdiplusStartupInput, Optional ByVal lOutPut As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
    Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As Long, ByRef hbmReturn As Long, _
                                                                        ByVal Background As Long) As Long
    Private Declare Function GdipImageRotateFlip Lib "gdiplus" (ByVal image As Long, ByVal rfType As Long) As Long
    Private Declare Function GdipImageSelectActiveFrame Lib "gdiplus" _
                (ByVal image As Long, ByRef dimensionID As GUID, _
                ByVal frameIndex As Long) As Long
    Private Declare Function GdipImageGetFrameCount Lib "gdiplus" _
                (ByVal image As Long, ByRef dimensionID As GUID, _
                ByRef Count As Long) As Long
    Private Declare Function GdipGetImageThumbnail Lib "gdiplus" _
        (ByVal image As Long, ByVal thumbWidth As Long, _
        ByVal thumbHeight As Long, ByRef thumbImage As Long, _
        ByVal callback As Long, ByVal callbackData As Long) As Long
    Private Declare Function GdipGetImageDimension Lib "gdiplus" _
        (ByVal image As Long, ByRef Width As Single, _
        ByRef Height As Single) As Long
    Private Declare Function GdipCloneBitmapAreaI Lib "gdiplus" (ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal PixelFormat As Long, ByVal srcBitmap As Long, dstBitmap As Long) As Long
    Private Declare Function GdipGetImagePixelFormat Lib "gdiplus" (ByVal image As Long, PixelFormat As Long) As Long
    ' Déplace une zone de mémoire
    Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal length As Long)
    ' API GDI
    Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal Hdc As Long, ByVal nStretchMode As Long) As Long
    Private Declare Function StretchBlt Lib "gdi32" (ByVal Hdc As Long, _
                                                     ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
                                                     ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _
                                                     ByVal ySrc As Long, ByVal nSrcWidth As Long, _
                                                     ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
    Private Declare Function SetMapMode Lib "gdi32" (ByVal Hdc As Long, ByVal nMapMode As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function apiGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal Hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function LPtoDP Lib "gdi32" (ByVal Hdc As Long, lpPoint As PointAPI, ByVal nCount As Long) As Long
    Private Declare Function DPtoLP Lib "gdi32" (ByVal Hdc As Long, lpPoint As PointAPI, ByVal nCount As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal Hdc As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal Hdc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal Hdc As Long) As Long
    ' Image EMF
    Private Declare Function CreateEnhMetaFile Lib "gdi32" _
                                               Alias "CreateEnhMetaFileA" _
                                               (ByVal hdcRef As Long, _
                                                ByVal lpFileName As String, _
                                                ByRef lpRect As Any, _
                                                ByVal lpDescription As String) As Long
    Private Declare Function CloseEnhMetaFile Lib "gdi32" _
                                              (ByVal Hdc As Long) As Long
    Private Declare Function DeleteEnhMetaFile Lib "gdi32" _
                                               (ByVal hemf As Long) As Long
    Private Declare Function GetEnhMetaFileBits Lib "gdi32" _
                                                (ByVal hemf As Long, ByVal cbBuffer As Long, lpbBuffer As Byte) As Long
    '***************************************************************************************
    '*                                    Constantes                                       *
    '***************************************************************************************
    Private Const MM_HIMETRIC = 3
    Private Const MM_TEXT = 1
    Private Const COLORONCOLOR = 3              ' Mode pour StretchBlt
    Private Const SRCCOPY = &HCC0020
    Private Const CF_ENHMETAFILE = 14
    Private Const PropertyTagFrameDelay As Long = &H5100&
     
    '***************************************************************************************
    '*                                       Types                                         *
    '***************************************************************************************
    ' Rectangle pour API
    Private Type Rect
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    ' Type Point pour API
    Private Type PointAPI
        X As Long
        Y As Long
    End Type
    Private Type bitmap
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
    End Type
    Private Type BitmapInfoHeader
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
    End Type
    Private Type DIBSECTION
        dsBm As bitmap
        dsBmih As BitmapInfoHeader
        dsBitfields(2) As Long
        dshSection As Long
        dsOffset As Long
    End Type
    Private Type PropertyItem
        id As Long
        length As Long
    Type As Integer
        Value As Long
    End Type
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
    Private Type EncoderParameter
        GUID As GUID
        NumberOfValues As Long
    Type As Long
        Value As Long
    End Type
    Private Type EncoderParameters
        Count As Long
        Parameter(15) As EncoderParameter
    End Type
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type
    '***************************************************************************************
    '*                                    Variables                                        *
    '***************************************************************************************
    Private gBitmap As Long
    Private gBitmapWork As Long
    Private gGdipToken As Long
    Private gLib As Long
    '***************************************************************************************
    '*                                Propriétés / Enumérations                            *
    '***************************************************************************************
    #If VBA6 Then
    Public Enum ERotateFlip
        RotateNoneFlipNone = 0
        Rotate90FlipNone = 1
        Rotate180FlipNone = 2
        Rotate270FlipNone = 3
        RotateNoneFlipX = 4
        Rotate90FlipX = 5
        Rotate180FlipX = 6
        Rotate270FlipX = 7
        RotateNoneFlipY = Rotate180FlipX
        Rotate90FlipY = Rotate270FlipX
        Rotate180FlipY = RotateNoneFlipX
        Rotate270FlipXY = Rotate90FlipNone
        RotateNoneFlipXY = Rotate180FlipNone
        Rotate90FlipXY = Rotate270FlipNone
        Rotate180FlipXY = RotateNoneFlipNone
    end enum
    #Else
        Property Get zRotate180FlipXY(): zRotate180FlipXY = zRotateNoneFlipNone: End Property
        Property Get zRotate90FlipXY(): zRotate90FlipXY = zRotate270FlipNone: End Property
        Property Get zRotateNoneFlipXY(): zRotateNoneFlipXY = zRotate180FlipNone: End Property
        Property Get zRotate270FlipXY(): zRotate270FlipXY = zRotate90FlipNone: End Property
        Property Get zRotate180FlipY(): zRotate180FlipY = zRotateNoneFlipX: End Property
        Property Get zRotate90FlipY(): zRotate90FlipY = zRotate270FlipX: End Property
        Property Get zRotateNoneFlipY(): zRotateNoneFlipY = zRotate180FlipX: End Property
        Property Get zRotate270FlipX(): zRotate270FlipX = 7: End Property
        Property Get zRotate180FlipX(): zRotate180FlipX = 6: End Property
        Property Get zRotate90FlipX(): zRotate90FlipX = 5: End Property
        Property Get zRotateNoneFlipX(): zRotateNoneFlipX = 4: End Property
        Property Get zRotate270FlipNone(): zRotate270FlipNone = 3: End Property
        Property Get zRotate180FlipNone(): zRotate180FlipNone = 2: End Property
        Property Get zRotate90FlipNone(): zRotate90FlipNone = 1: End Property
        Property Get zRotateNoneFlipNone(): zRotateNoneFlipNone = 0: End Property
    #End If
     
    '***************************************************************************************
    '*                                    FONCTIONS                                        *
    '***************************************************************************************
    '---------------------------------------------------------------------------------------
    ' Propage l'erreur à l'appelant
    '---------------------------------------------------------------------------------------
    Private Sub ErrRaise()
        Err.Raise Err.number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    End Sub
     
    '---------------------------------------------------------------------------------------
    ' Ouverture du fichier
    '---------------------------------------------------------------------------------------
    ' pFile   : Fichier
    ' pWidth, pHeight : Taille de l'image
    ' si une dimension de l'image est omise, elle est calculés pour conserver le ratio de l'image
    ' la taille de l'image chargée est renvoyée dans ces paramètres
    ' pSaveOriginal : mettre à vrai pour conserver l'image originale et pouvoir la rétablir
    '   après transformation (à l'aide de la fonction ResetImage
    '---------------------------------------------------------------------------------------
    Public Function OpenFile(pFile As String, Optional pWidth As Long = 0, Optional pHeight As Long = 0, Optional pSaveOriginal As Boolean) As Boolean
        Dim lGdiPSI As GdiplusStartupInput
        Dim lWidth As Single
        Dim lHeight As Single
        Dim lBitmap As Long
        On Error GoTo Gestion_Erreur
        ' Fermeture d'un éventuel fichier déjà ouvert
        CloseFile
        ' Retour de la fonction
        OpenFile = True
        ' Initialisation GDI + version 1
        lGdiPSI.GdiplusVersion = 1
        If GdiplusStartup(gGdipToken, lGdiPSI) = 0 Then
            ' Création d'un Bitmap Gdi+ à partir du bitmap de l'image
            OpenFile = (GdipCreateBitmapFromFile(StrPtr(pFile), gBitmap) = 0)
            If OpenFile Then
                GdipGetImageDimension gBitmap, lWidth, lHeight
                If pWidth = 0 And pHeight = 0 Then 'Image complète
                    pWidth = lWidth
                    pHeight = lHeight
                Else ' Image redimensionnée
                    If pWidth = 0 Then
                        pWidth = pHeight * lWidth / lHeight
                    ElseIf pHeight = 0 Then
                        pHeight = pWidth * lHeight / lWidth
                    End If
                    OpenFile = (GdipGetImageThumbnail(gBitmap, pWidth, pHeight, lBitmap, 0, 0) = 0)
                    GdipDisposeImage gBitmap
                    gBitmap = lBitmap
                End If
            End If
        End If
    Gestion_Erreur:
        gBitmapWork = gBitmap
        If Not pSaveOriginal Then gBitmap = 0
        If Err.number <> 0 Then OpenFile = False
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Fermeture du fichier
    '---------------------------------------------------------------------------------------
    Public Function CloseFile()
    ' Supprime le bitmap
        If gBitmapWork <> gBitmap Then GdipDisposeImage gBitmapWork: gBitmapWork = gBitmap
        If gBitmap <> 0 Then GdipDisposeImage gBitmap: gBitmap = 0
        ' Ferme Gdi+
        If gGdipToken <> 0 Then GdiplusShutdown gGdipToken: gGdipToken = 0
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Sauvegarde le fichier
    '---------------------------------------------------------------------------------------
    ' pFile   : Fichier
    ' pFormat : format du fichier : JPG,GIF,BMP,PNG,TIF
    ' pQuality : Qualité Jpeg (0-100)
    '---------------------------------------------------------------------------------------
    Public Function SaveFile(pFile As String, Optional pFormat As String = "JPG", Optional ByVal pQuality As Integer = -1) As Boolean
        Dim lEncoder As GUID
        Dim lParams As EncoderParameters
        Dim lEncoderStr As String
        Const lJpegEncoderStr As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
        Const lGifEncoderStr As String = "{557cf402-1a04-11d3-9a73-0000f81ef32e}"
        Const lBmpEncoderStr As String = "{557cf400-1a04-11d3-9a73-0000f81ef32e}"
        Const lPngEncoderStr As String = "{557cf406-1a04-11d3-9a73-0000f81ef32e}"
        Const lTifEncoderStr As String = "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
        Const lQualityParamStr As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
     
        On Error GoTo Gestion_Erreur
        ' Format de l'encodeur
        Select Case pFormat
            Case "JPG"
                lEncoderStr = lJpegEncoderStr
            Case "GIF"
                lEncoderStr = lGifEncoderStr
            Case "BMP"
                lEncoderStr = lBmpEncoderStr
            Case "PNG"
                lEncoderStr = lPngEncoderStr
            Case "TIF"
                lEncoderStr = lTifEncoderStr
        End Select
        SaveFile = True
        ' Recherche de l'encodeur Jpeg
        CLSIDFromString StrPtr(lEncoderStr), lEncoder
        ' Paramètre de l'encodeur Jpeg
        If pQuality <> -1 And pFormat = "JPG" Then
            lParams.Count = 1
            With lParams.Parameter(0)
                ' Paramètrage de la qualité (0-100)
                CLSIDFromString StrPtr(lQualityParamStr), .GUID
                .NumberOfValues = 1
                .Type = 4    ' Type Long
                .Value = VarPtr(pQuality)
            End With
        End If
        ' Sauvegarde l'image
        If lParams.Count > 0 Then
            SaveFile = (GdipSaveImageToFile(gBitmapWork, StrPtr(pFile), lEncoder, lParams) = 0)
        Else
            SaveFile = (GdipSaveImageToFile(gBitmapWork, StrPtr(pFile), lEncoder, Null) = 0)
        End If
    Gestion_Erreur:
        If Err.number <> 0 Then SaveFile = False
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Initialisation de la classe
    '---------------------------------------------------------------------------------------
    Private Sub Class_Initialize()
        ' Charge la librarie gdiplus
        gLib = LoadLibrary(ApplicationPath & "gdiplus.dll")
    End Sub
     
    '---------------------------------------------------------------------------------------
    ' Libération de la classe
    '---------------------------------------------------------------------------------------
    Private Sub Class_Terminate()
        ' Ferme un éventuel fichier ouvert
        CloseFile
    End Sub
     
    '---------------------------------------------------------------------------------------
    ' Transfère les données du Bitmap dans un tableau de type PictureData
    '---------------------------------------------------------------------------------------
    ' phDIB        : Objet Bitmap
    ' On utilise un objet EMF car Access gère très mal les redimensionnements des Bitmaps
    '---------------------------------------------------------------------------------------
    Private Function DIBtoPictureData(phDIB As Long) As Variant
        Dim lhMeta As Long
        Dim lhMetaFile As Long
        Dim lhdcref As Long
        Dim lrect As Rect
        Dim lngret As Long
        Dim pt As PointAPI
        Dim lds As DIBSECTION
        Dim lhDC As Long
        Dim lOldBmp As Long
        Dim lPicData() As Byte
        On Error GoTo Gestion_Erreurs:
        ' Relecture de la taille de l'image
        Call apiGetObject(phDIB, Len(lds), lds)
        ' Récupère la taille en données de type OLE_Himetric pour la création de l'EMF
        pt.X = lds.dsBmih.biWidth
        pt.Y = lds.dsBmih.biHeight
        lhdcref = GetDC(0)   ' Device contexte temporaire
        lngret = SetMapMode(lhdcref, MM_HIMETRIC)
        DPtoLP lhdcref, pt, 1
        ' Rectangle pour création de l'EMF
        lrect.Right = pt.X
        lrect.Bottom = Abs(pt.Y)
        ' Conversion de la taille en pixels
        LPtoDP lhdcref, pt, 1
        pt.Y = Abs(pt.Y)
        SetMapMode lhdcref, lngret
        ' Création d'un contexte d'affichage EMF
        lhMeta = CreateEnhMetaFile(lhdcref, vbNullString, lrect, vbNullString)
        ' Coordonnées en pixels
        lngret = SetMapMode(lhMeta, MM_TEXT)
        ' Type de redimensionnement
        lngret = SetStretchBltMode(lhMeta, COLORONCOLOR)
        ' Crée un contexte d'affichage temporaire
        lhDC = CreateCompatibleDC(0)
        ' Affecte le bitmap au DC temporaire
        lOldBmp = SelectObject(lhDC, phDIB)
        ' Copie de l'image dans le MetaFile
        StretchBlt lhMeta, 0, 0, pt.X, pt.Y, lhDC, 0, 0, lds.dsBmih.biWidth, lds.dsBmih.biHeight, SRCCOPY
        ' Ferme le contexte d'affichage et récupère le MetaFile
        lhMetaFile = CloseEnhMetaFile(lhMeta)
        ' Récupère la taille des données Méta
        lngret = GetEnhMetaFileBits(lhMetaFile, 0, ByVal 0&)
        ' Redimensionne le tableau de données
        ReDim lPicData((lngret - 1) + 8)
        ' Récupère les données dans le tableau
        lngret = GetEnhMetaFileBits(lhMetaFile, lngret, lPicData(8))
        ' Supprime le MétaFile
        lngret = DeleteEnhMetaFile(lhMetaFile)
        ' Type de l'image dans le tableau de données
        lPicData(0) = CF_ENHMETAFILE
        ' Libère le device contexte de travail
        ReleaseDC 0&, lhdcref
        ' Supprime le DC
        DeleteObject SelectObject(lhDC, lOldBmp)
        DeleteDC lhDC
        ' Renvoie le résultat
        DIBtoPictureData = lPicData
    Gestion_Erreurs:
        If Err.number <> 0 Then DIBtoPictureData = Null  ' Renvoie Null si erreur
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Chemin de l'application
    '---------------------------------------------------------------------------------------
    ' Utile pour access97 : currentproject.path n'existe pas
    '---------------------------------------------------------------------------------------
    Private Function ApplicationPath() As String
        ApplicationPath = Left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Dir(CurrentDb.Name)))
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Récupère un tableau PictureData pour contrôle image Access
    '---------------------------------------------------------------------------------------
    Public Function GdiPlusToPictureData() As Variant
    Dim lBitmapGdi As Long
        ' Transformation du bitmap GDI+ en bitmap Gdi "classique"
        Call GdipCreateHBITMAPFromBitmap(gBitmapWork, lBitmapGdi, 0)
        ' Retour de la fonction = tableau de byte affectable à une propriété PictureData
        GdiPlusToPictureData = DIBtoPictureData(lBitmapGdi)
        ' Suppression du bitmap GDI
        DeleteObject lBitmapGdi
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Change l'image courante d'un gif animé
    ' pFrame : numéro de l'image
    '---------------------------------------------------------------------------------------
    Public Function GifSetFrame(pFrame As Long)
    Dim lFDTGUID As GUID
    Const lFrameDimensionTime As String = "{6AEDBD6D-3FB5-418A-83A6-7F45229DC872}"
        Call CLSIDFromString(StrPtr(lFrameDimensionTime), lFDTGUID)
        GdipImageSelectActiveFrame gBitmapWork, lFDTGUID, pFrame
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Nombre d'images d'un gif animé
    '---------------------------------------------------------------------------------------
    Public Function GifGetFrameCount() As Long
    Dim lFDTGUID As GUID
    Const lFrameDimensionTime As String = "{6AEDBD6D-3FB5-418A-83A6-7F45229DC872}"
        Call CLSIDFromString(StrPtr(lFrameDimensionTime), lFDTGUID)
        GdipImageGetFrameCount gBitmapWork, lFDTGUID, GifGetFrameCount
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Delais d'affichage des images d'un gif animé
    ' Renvoit un tableau contenant autant de délais que d'images dans le gif
    '---------------------------------------------------------------------------------------
    Public Function GifGetFrameDelay() As Variant
    Dim lPropSize As Long
    Dim lBuffer() As Byte
    Dim lPropertyItem As PropertyItem
    Dim lResultLong() As Long
    Dim lFrameCount As Long
    Dim lcpt As Long
    If GdipGetPropertyItemSize(gBitmapWork, PropertyTagFrameDelay, lPropSize) = 0 Then
        ReDim lBuffer(lPropSize - 1)
        If GdipGetPropertyItem(gBitmapWork, PropertyTagFrameDelay, lPropSize, lBuffer(0)) = 0 Then
            Call RtlMoveMemory(lPropertyItem, lBuffer(0), LenB(lPropertyItem))
            If lPropertyItem.length > 0 Then
                ' On déplace la valeur dans un tableau (tPropertyItem.Value est un pointeur)
                ReDim lReturnBuffer(lPropertyItem.length - 1)
                Call RtlMoveMemory(lReturnBuffer(0), _
                                   ByVal lPropertyItem.Value, _
                                   lPropertyItem.length)
                ' Pour chaque image, le delai est stocké dans un Long, donc taille = 4
                ReDim lResultLong(lPropertyItem.length / 4 - 1)
                RtlMoveMemory lResultLong(0), lReturnBuffer(0), lPropertyItem.length
                GifGetFrameDelay = lResultLong
            End If
        End If
    End If
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Rotation/Miroir de l'image
    ' pType : type de transformation
    '---------------------------------------------------------------------------------------
    #If VBA6 Then
    Public Function RotateFlip(pType As ERotateFlip)
    #Else
    Public Function RotateFlip(pType As Long)
    #End If
        Dim lWidth As Single
        Dim lHeight As Single
        Dim lPixelFormat As Long
        Dim lNewBitmap As Long
        GdipGetImageDimension gBitmapWork, lWidth, lHeight
        lPixelFormat = GdipGetImagePixelFormat(gBitmapWork, lPixelFormat)
        GdipCloneBitmapAreaI 0, 0, lWidth, lHeight, lPixelFormat, gBitmapWork, lNewBitmap
        Call GdipImageRotateFlip(lNewBitmap, pType)
        If gBitmapWork <> gBitmap Then GdipDisposeImage gBitmapWork
        gBitmapWork = lNewBitmap
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Redimensionne l'image
    '---------------------------------------------------------------------------------------
    ' pWidth        : Largeur
    ' pHeight       : Hauteur
    '---------------------------------------------------------------------------------------
    Public Function ResizeImage(Optional pWidth As Long = 0, Optional pHeight As Long = 0) As Boolean
        Dim lWidth As Single
        Dim lHeight As Single
        Dim lNewBitmap As Long
        ResizeImage = False
        GdipGetImageDimension gBitmapWork, lWidth, lHeight
        If pWidth = 0 And pHeight = 0 Then
            pWidth = lWidth
            pHeight = lHeight
        Else
            If pWidth = 0 Then
                pWidth = pHeight * lWidth / lHeight
            ElseIf pHeight = 0 Then
                pHeight = pWidth * lHeight / lWidth
            End If
            ResizeImage = (GdipGetImageThumbnail(gBitmapWork, pWidth, pHeight, lNewBitmap, 0, 0) = 0)
            If gBitmapWork <> gBitmap Then GdipDisposeImage gBitmapWork
            gBitmapWork = lNewBitmap
        End If
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Découpe l'image
    '---------------------------------------------------------------------------------------
    ' pLeft         : Position à gauche
    ' pTop          : Position en haut
    ' pWidth        : Largeur
    ' pHeight       : Hauteur
    '---------------------------------------------------------------------------------------
    Public Function CropImage(Optional pLeft As Long = 0, Optional pTop As Long = 0, Optional pWidth = 0, Optional pHeight = 0) As Boolean
        Dim lWidth As Single
        Dim lHeight As Single
        Dim lPixelFormat As Long
        Dim lNewBitmap As Long
        CropImage = False
        GdipGetImageDimension gBitmapWork, lWidth, lHeight
        If pWidth <> 0 Then lWidth = pWidth
        If pHeight <> 0 Then lHeight = pHeight
        lPixelFormat = GdipGetImagePixelFormat(gBitmapWork, lPixelFormat)
        CropImage = (GdipCloneBitmapAreaI(pLeft, pTop, lWidth, lHeight, lPixelFormat, gBitmapWork, lNewBitmap) = 0)
        If gBitmapWork <> gBitmap Then GdipDisposeImage gBitmapWork
        gBitmapWork = lNewBitmap
    End Function
     
    '---------------------------------------------------------------------------------------
    ' Rétablit l'image d'origine
    '---------------------------------------------------------------------------------------
    Public Function ResetImage()
        If gBitmapWork <> gBitmap Then GdipDisposeImage gBitmapWork
        gBitmapWork = gBitmap
    End Function

  3. #3
    Nouveau Candidat au Club
    Inscrit en
    Octobre 2007
    Messages
    1
    Détails du profil
    Informations forums :
    Inscription : Octobre 2007
    Messages : 1
    Points : 1
    Points
    1
    Par défaut Attention
    Attention a l'utilisation de GDI+

    La librairie a été crée pour Windows XP, Elle présente un problème a l'ouverture de certaine image JPEG(ou JPG), elle fait planté le système. (Source : http://www.certa.ssi.gouv.fr/site/CERTA-2004-AVI-312/)

    Le problème est contournable si aux préalable Le fichier JPG est ouvert avec GDI puis converti en BMP ou autre formats.

    Sous windows VISTA le problème est a moitié résolut : Le programme hôte est gelé puis fermer.

    Faite très attention a l'utilisation de cette librairie, quand a la redistribution elle est légale mais tenez informer les utilisateurs des risques éventuelle surtout pour les version antérieur a Windows VISTA

  4. #4
    Responsable Access

    Avatar de Arkham46
    Profil pro
    Inscrit en
    Septembre 2003
    Messages
    5 865
    Détails du profil
    Informations personnelles :
    Localisation : France, Loiret (Centre)

    Informations forums :
    Inscription : Septembre 2003
    Messages : 5 865
    Points : 14 522
    Points
    14 522
    Par défaut
    Bjr,

    Il faut bien entendu faire les mises à jour de son PC et/ou utiliser la dernière version de librairie à télécharger...

  5. #5
    Membre éprouvé Avatar de electroremy
    Homme Profil pro
    Ingénieur sécurité
    Inscrit en
    Juin 2007
    Messages
    932
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 43
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ingénieur sécurité
    Secteur : Industrie

    Informations forums :
    Inscription : Juin 2007
    Messages : 932
    Points : 1 267
    Points
    1 267
    Par défaut
    très interessant, merci pour ce travail

    je souhaite utiliser ce code dans visual basic 5

    j'ai réussi à créer la classe ClGdiPlus (il a suffit de supprimer Option compare database et de remplacer ApplicationPath par App.Path)

    par contre, est-il possible de travailler avec des objets picturebox et printer ?

    sinon, quelles-modifications dois-je apporter au code ?

    merci
    Quand deux personnes échangent un euro, chacun repart avec un euro.
    Quand deux personnes échangent une idée, chacun repart avec deux idées.

  6. #6
    Responsable Access

    Avatar de Arkham46
    Profil pro
    Inscrit en
    Septembre 2003
    Messages
    5 865
    Détails du profil
    Informations personnelles :
    Localisation : France, Loiret (Centre)

    Informations forums :
    Inscription : Septembre 2003
    Messages : 5 865
    Points : 14 522
    Points
    14 522
    Par défaut
    Citation Envoyé par electroremy Voir le message
    je souhaite utiliser ce code dans visual basic 5
    Bjr,

    Je ne connais pas VB5 et le format de son contrôle image.
    Mais après l'exécution de la fonction GdipCreateHBITMAPFromBitmap, tu obtiens un bitmap gdi32. Il doit bien y avoir quelque part le code pour injecter un bitmap gdi dans un contrôle VB.

    Bonne recherche.

Discussions similaires

  1. Bing se dote d'un nouveau filtre d'images pour rechercher des GIF animés
    Par Stéphane le calme dans le forum Actualités
    Réponses: 0
    Dernier message: 01/11/2014, 20h47
  2. loader des gif animés
    Par ctrlaltsuppr dans le forum Delphi
    Réponses: 1
    Dernier message: 02/08/2006, 05h37
  3. Travailler avec des gifs animés
    Par Commodore dans le forum Imagerie
    Réponses: 1
    Dernier message: 13/07/2006, 16h58
  4. Nouveau probleme aussi avec des gifs animés
    Par inferno66667 dans le forum Balisage (X)HTML et validation W3C
    Réponses: 12
    Dernier message: 06/02/2006, 18h58
  5. Arret des gif animés
    Par doura dans le forum Général JavaScript
    Réponses: 9
    Dernier message: 02/01/2006, 23h43

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo