Charge images couche alpha png ou tif sauve en tif et png deplacement transparent

Télécharger le projet
Commenter

Description

c'est la suite de la source déja sur ce site
DÉPLACER UN OBJET TRANSPARENT (PNG AVEC COUCHE ALPHA) SUR UN PICTUREBOX EN VB6
la grosse différence c'est que j'ai résolu le problème
de la sauvegarde d'une image avec couche alpha en PNG et en TIF
je me suis souvenu que le format TIF acceptait la non compression et la couche alpha(un Bitmap 32 bits compatible contrairement au BMP) j'ai écrit un convertisseur Bitmap32->Tif puis je converti le TIF en PNG (gdiplus.dll)

Source / Exemple : 


Option Explicit
Dim WP&, HP& 'largeur et hauteur de l'E.T.
Dim BP() As Byte 'Bitmap 32 bits avec couche Alpha de l'E.T.
Dim HeP As BITMAPINFO 'Bitmap 24 bits(BVR)
Dim Wi&, Hi& 'largeur et hauteur de l'image principale (Picture1)
Dim Bi() As Byte, HeI As BITMAPINFO 'Bitmap 24 bits(BVR)
Dim Xm&, Ym& 'Cordonnées de la souris sur picture2 lors de Picture2_MouseDown
Dim HTif(&HEFF) As Byte 'Header Tif 32 Bits

Private Sub Form_Load()
Caption = "Déplacez l'E.T. avec la souris - Cranach 1530~ Adam et Eve au Jardin d'Eden"
'charge l'image de fond dans Picture1 au bon endroit
Picture1.ScaleMode = vbPixels
Picture1.BorderStyle = 0 'None
Picture1.AutoSize = True
'L'image Principale est déja dans le Picture1
'Picture1.Picture = LoadPicture("Cranach 1530~ Adam et Eve au Jardin d'Eden.jpg")
'ajuste la taille de la Form
Width = Picture1.Width + (Width - ScaleWidth)
Height = Picture1.Top + Picture1.Height + (Height - ScaleHeight)
Label1.Width = ScaleWidth
Label1.Font.Size = (Screen.TwipsPerPixelY + 1) / 2

'extrait le Bitmap 24 Bits de picture1
Wi = Picture1.ScaleWidth
Hi = Picture1.ScaleHeight
With HeI 'Initialise le Header BITMAPINFO
.biSize = 40
.biWidth = Wi
.biHeight = Hi
.biPlanes = 1
.biBitCount = 24
End With
ReDim Bi(Width24b(Wi) - 1, Hi - 1) 'on ne peux faire un tableau à 3 dimension que si Wi est divisible pas 4
GetDIBits Picture1.hdc, Picture1.Picture, 0, Hi, Bi(0, 0), HeI, 0 'DIB_RGB_COLORS
'Converti ET.png en Bmp 32bits vers TMP fichier temporaire
Dim TMP$
TMP = Environ("TMP") & "\ET.tmp"
'Convert "ET.png", TMP, 0 '0 conversion vers BMP
Convert "ET.png", TMP, 0 '0 conversion vers BMP
'extait les dimensions et le bitmap 32 bits(avec couche alpha) de TMP
Open TMP For Binary As 1
Get 1, 19, WP 'largeur de l'ET
Get 1, , HP 'hauteur de l'ET
ReDim BP(3, WP - 1, HP - 1)
Get 1, 55, BP 'bitmap lu
Close 1
Kill TMP 'efface le fichier temporaire
'initialise Picture2
Picture2.ScaleMode = vbPixels
Picture2.BorderStyle = 0 'None
Picture2.AutoRedraw = True
Picture2.Width = WP
Picture2.Height = HP
'Dessine et Place Picture2
PlacePicture2 376, 244
'Fin de l'ancien Projet
'teste la presence de HeaderTif32.bin
If Dir("HeadTif32.bin") = "" Then MsgBox "HeaderTif32.bin non trouvé !": Exit Sub
Dim X&, Y&, TMPTif$, TMPPng$
'Charge le Header HTif
Open "HeaderTif32.bin" For Binary As 1: Get 1, , HTif: Close 1
'Recopie Picture2 ver picture1
Picture1.AutoRedraw = True
Picture1.PaintPicture Picture2.image, 376, 244, WP, HP, 0, 0, WP, HP
'Picture2.Visible = False
'Exit Sub
'recharge la nouvelle image dans le tableau bitmap BI
Picture1.Picture = Picture1.image
GetDIBits Picture1.hdc, Picture1.Picture, 0, Hi, Bi(0, 0), HeI, 0 'DIB_RGB_COLORS
'rendre l'ET plus transparent(affaiblir la couche alpha)
For Y = 0 To HP - 1: For X = 0 To WP - 1: BP(3, X, Y) = 0.65 * BP(3, X, Y): Next X, Y
'sauve le bitmap32 en tif32 (avec couche alpha)
TMPTif = Environ("TMP") & "\TmpTif.tif"
'TMPTif = "TmpTif.tif"
Bitmap32ToUncompressedTif BP, TMPTif
'Convertir le TIF en PNG
TMPPng = Environ("TMP") & "\TmpPng.png"
Convert TMPTif, TMPPng, 1
'Convertir le PNG en en Bmp32
Convert TMPPng, TMP, 0
'On recharge le BitMap32 qui a subi 3 conversions Bitmap32->TIF->PNG->Bitmap32
Open TMP For Binary As 1
Get 1, 19, WP 'largeur de l'ET
Get 1, , HP 'hauteur de l'ET
ReDim BP(3, WP - 1, HP - 1)
Get 1, 55, BP 'bitmap lu
Close 1
'On efface les 3 fichiers temporaires
Kill TMPTif
Kill TMPPng
Kill TMP
'On replace le nouvel ET plus tranparent au même endroit
PlacePicture2 376, 244
'voila c'est tout j'ai fait beaucoup de manipulatios dont le seul but était
'de montrer comment sauver en PNG avec couche Alpha (accessoirement comment sauver en TIF)
End Sub

Private Sub Bitmap32ToUncompressedTif(B() As Byte, TifFile$)
Dim X&, Y&, YI&, W&, H&, UW&, UH&, D() As Byte
If UBound(B) <> 3 Then MsgBox "Pas de couche Alpha": End
UW = UBound(B, 2): W = UW + 1
UH = UBound(B, 3): H = UH + 1
'On entre la Largeur W,la hauteur H et la taille du bitmap32 4 * W * H dans le header HTif
CopyMemory HTif(&H1E), W, 2
CopyMemory HTif(&H2A), H, 2
CopyMemory HTif(&H72), H, 2
CopyMemory HTif(&H7E), 4 * W * H, 4
ReDim D(3, UW, UH)
'Inversion Y et permutation Rouge Bleu
For Y = 0 To UH: YI = UH - Y
 For X = 0 To UW
  D(0, X, Y) = B(2, X, YI) 'rouge
  D(1, X, Y) = B(1, X, YI) 'vert
  D(2, X, Y) = B(0, X, YI) 'bleu
  D(3, X, Y) = B(3, X, YI) 'alpha
Next X, Y
'on sauve, le tif est prêt
H = FreeFile
Open TifFile For Binary As H
Put H, , HTif: Put H, , D
Close H
End Sub

Private Sub Picture2_MouseDown(Button%, Shift%, X!, Y!)
Xm = X: Ym = Y
End Sub

Private Sub Picture2_MouseMove(Button%, Shift%, X!, Y!)
If Button Then
 PlacePicture2 X + Picture2.Left - Xm, Y + Picture2.Top - Ym
 Picture1.Refresh ' Nettoyage de Picture1
End If
End Sub

Private Sub PlacePicture2(X0&, Y0&)
Dim X0i&, Y0r& 'origines dans le bitmap de l'image principale Bi
Dim Wu&, Hu& 'largeur et hauteur de la zone à copier
Dim Xt&, Yt&, X&, C& 'variables de travail
Dim B() As Byte 'Bitmap 24 Bits qui sera chargé dans Picture2
Dim Alpha!  'niveau d'opacité de 0 à 1
Dim NAlpha! 'niveau de transparence de 0 à 1 (1-Alpha)
X0i = X0
Y0r = Hi - Y0 - HP 'les ccordonnées Y du bitmap sont inversées (de bas en haut)
'Vérifications pour ne pas sortir du tableau Bitmap Bi (image principale)
Wu = WP: If X0 + WP > Wi Then Wu = Wi - X0i
If X0i < 0 Then Xt = -X0i: Wu = Wu + X0i: X0i = 0
Hu = HP: If Y0r + HP > Hi Then Hu = Hi - Y0r
If Y0r < 0 Then Yt = -Y0r: Hu = Hu + Y0r: Y0r = 0
'Cree un bitmap 24 bits de la taille de picture2 (ET)
ReDim B(Width24b(WP) - 1, HP - 1)
If Wu > 0 And Hu > 0 Then
 Wu = 3 * Wu: Xt = 3 * Xt: X0i = 3 * X0i
 'Copie le Bitmap de l'image principale (Bi) sous picture2 dans le nouveau bitmap (B)
 For Yt = Yt To Yt + Hu - 1
  CopyMemory B(Xt, Yt), Bi(X0i, Y0r), Wu: Y0r = Y0r + 1
 Next
 'Fusionne le Bitmap B avec BP(avec couche alpha)
 For Yt = 0 To HP - 1
  For Xt = 0 To WP - 1
   If BP(3, Xt, Yt) Then
    Alpha = BP(3, Xt, Yt) / 255:
    NAlpha = 1 - Alpha
    X = 3 * Xt 'B et Bi sont à 2 dimensions BP à 3
    For C = 0 To 2
     B(X, Yt) = Alpha * BP(C, Xt, Yt) + NAlpha * B(X, Yt)
     X = X + 1
    Next
   End If
  Next
 Next
 'charge le nouveau Bitmap B dans Picture2.image et Picture2.picture
 With HeP 'place les dimensions dans le Header BITMAPINFO
 .biSize = 40
 .biWidth = WP
 .biHeight = HP
 .biPlanes = 1
 .biBitCount = 24
 End With
 SetDIBits Picture2.hdc, Picture2.image, 0, HP, B(0, 0), HeP, 0 'DIB_RGB_COLORS
 Picture2.Picture = Picture2.image
End If
'Positionne Picture2
Picture2.Left = X0: Picture2.Top = Y0
Picture2.Refresh
End Sub

'les fonctions GetDibits, SetDibits de même que le format de fichier BMP
'utilisent un tableau dont la taile est:
' 4 * ((BitPerPixel * Width + 31)\ 32) * Height
'si (BitPerPixel * Width) est divible par 32 on peut faire un tableau à 3 dimensions C,X,Y sinon non
Private Function Width24b&(Width&)
Width24b = 4 * ((24 * Width + 31) \ 32)
End Function

Conclusion :


J'ai beaucoup cherché sur ce site
je pense être le seul à proposer une sauvegarde PNG avec couche alpha (et sans DLL additionnelle)
Je suis ouvert à une solution plus directe
Mais je vous offre un code assez léger, rapide et qui surtout
fonctionne
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 (deleplace)