Tester vous même, compatible 32 et 64 bits
Code : Tout sélectionner
UsePNGImageDecoder()
Procedure.l SetLayeredWindow(WindowID.i)
; Mettre l'attribut WS_EX_LAYERED à la fenêtre
SetWindowLongPtr_(WindowID, #GWL_EXSTYLE, GetWindowLongPtr_(WindowID, #GWL_EXSTYLE) | #WS_EX_LAYERED)
If (GetWindowLongPtr_(WindowID, #GWL_EXSTYLE) & #WS_EX_LAYERED) <> 0
ProcedureReturn 1
EndIf
ProcedureReturn 0
EndProcedure
Procedure.l AlphaImageWindow(WindowID.i, ImageID.i) ; Mettre une image PNG comme fond d'une fenêtre
Protected Image_HDC.i, Image_Bitmap.BITMAP, Image_BitmapInfo.BITMAPINFO, ContextOffset.POINT, Blend.BLENDFUNCTION
Protected Image_Ancienne.i ,xx, yy, x, y, Rouge.l, Vert.l, Bleu.l, AlphaChannel.l, Ret.l=0
; Précalcul
Protected Dim Echelle.f($FF)
For x = 0 To $FF
Echelle(x) = x / $FF
Next
; Chargement du HDC
Image_HDC = CreateCompatibleDC_(#Null)
Image_Ancienne = SelectObject_(Image_HDC, ImageID)
If Image_HDC = 0 Or Image_Ancienne = 0
Goto Erreur
EndIf
; Dimension de l'image
If GetObject_(ImageID, SizeOf(BITMAP), @Image_Bitmap) = 0
Goto Erreur
EndIf
Image_BitmapInfo\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
Image_BitmapInfo\bmiHeader\biWidth = Image_Bitmap\bmWidth
Image_BitmapInfo\bmiHeader\biHeight = Image_Bitmap\bmHeight
Image_BitmapInfo\bmiHeader\biPlanes = 1
Image_BitmapInfo\bmiHeader\biBitCount = 32
; Zone mémoire pour copier l'image
xx = Image_Bitmap\bmWidth - 1
yy = Image_Bitmap\bmHeight - 1
Protected Dim Image.l(xx, yy)
; Copie de l'image en mémoire
If GetDIBits_(Image_HDC, ImageID, 0, Image_Bitmap\bmHeight, @Image(), @Image_BitmapInfo, #DIB_RGB_COLORS) = 0
Goto Erreur
EndIf
; Modification de l'image en mémoire
For x = 0 To xx
For y = 0 To yy
Couleur = Image(x, y)
AlphaChannel = Couleur >> 24 & $FF
If AlphaChannel < $FF
Rouge = (Couleur & $FF) * Echelle(AlphaChannel)
Vert = (Couleur >> 8 & $FF) * Echelle(AlphaChannel)
Bleu = (Couleur >> 16 & $FF) * Echelle(AlphaChannel)
Image(x, y) = Rouge | Vert << 8 | Bleu << 16 | AlphaChannel << 24
EndIf
Next
Next
; Transfert de la mémoire dans la l'image de base
If SetDIBits_(Image_HDC, ImageID, 0, Image_Bitmap\bmHeight, @Image(), @Image_BitmapInfo, #DIB_RGB_COLORS) = 0
Goto Erreur
EndIf
; L'image est mise en skin de la fenêtre
Blend\SourceConstantAlpha = 255 ; niveau de transparence
Blend\AlphaFormat = 1 ; Support de la couche alpha
Blend\BlendOp = 0
Blend\BlendFlags = 0
If UpdateLayeredWindow_(WindowID, 0, 0, @Image_BitmapInfo + 4, Image_HDC, @ContextOffset, 0, @Blend, 2) = 0
Goto Erreur
Else
Ret = 1
EndIf
Erreur:
; Fermeture du HDC
If Image_HDC <> 0 And Image_Ancienne <> 0
SelectObject_(Image_HDC, Image_Ancienne)
DeleteDC_(Image_HDC)
ElseIf Image_HDC <> 0
DeleteDC_(Image_HDC)
EndIf
ProcedureReturn Ret
EndProcedure
Procedure.l GetDimensionText(Text.s, FontID.l, *Width.Long, *Height.Long)
Protected Image.l, Ret.l = 0, CountText.l
Protected MaxLine.s, Line.s, MaxLen.l, Len.l, a.l
CountText = CountString(Text, Chr(13))
For a= 1 To CountText + 1
Line = StringField(Text, a, Chr(13))
Len = Len(Line)
If MaxLen < Len
MaxLen = Len
MaxLine = Line
EndIf
Next a
Image = CreateImage(#PB_Any, 100, 100)
If Image
If StartDrawing(ImageOutput(Image))
DrawingFont(FontID(FontID))
*Width\l = TextWidth(MaxLine) + 20
*Height\l = TextHeight(MaxLine)
StopDrawing()
EndIf
FreeImage(Image)
EndIf
If *Width\l <> 0 And *Height\l <> 0
*Height\l = *Height\l * (CountText + 1)
Ret = 1
EndIf
ProcedureReturn Ret
EndProcedure
Procedure.l CreateText(Width.l, Height.l, Text.s, TextColor=$000000, TextFontID=#PB_Default)
Protected Image.l, CountText.l, Line.s, MoveHeight.l = 0
CountText = CountString(Text, Chr(13))
Image = CreateImage(#PB_Any, Width, Height, 32 , #PB_Image_Transparent)
If Image
If StartDrawing(ImageOutput(Image))
DrawingMode(#PB_2DDrawing_AlphaBlend|#PB_2DDrawing_Transparent)
DrawingFont(FontID(TextFontID))
For a = 1 To CountText +1
Line = StringField(Text, a, Chr(13))
DrawText((Width - TextWidth(Line))/2, MoveHeight, Line, TextColor | $FF000000)
MoveHeight = MoveHeight + TextHeight(Line)
Next a
StopDrawing()
EndIf
EndIf
; effet antialiasing grâce au redimensionnement
ResizeImage(Image, Width/2, Height/2)
ProcedureReturn Image
EndProcedure
Procedure.l CreateTextWithImage(Image.l, Text.s, HeightPosition.l, TextColor=$000000, TextFontID=#PB_Default)
Protected CountText.l, Line.s, MoveHeight.l = 0
CountText = CountString(Text, Chr(13))
If StartDrawing(ImageOutput(Image))
DrawingMode(#PB_2DDrawing_AlphaBlend|#PB_2DDrawing_Transparent)
DrawingFont(FontID(TextFontID))
For a = 1 To CountText +1
Line = StringField(Text, a, Chr(13))
DrawText((ImageWidth(Image) - TextWidth(Line)) / 2 , HeightPosition + MoveHeight, Line, TextColor | $FF000000)
MoveHeight = MoveHeight + TextHeight(Line)
Next a
StopDrawing()
Else
Image = 0
EndIf
; effet antialiasing grâce au redimensionnement
ResizeImage(Image, ImageWidth(Image)/2, ImageHeight(Image)/2)
ProcedureReturn Image
EndProcedure
LoadFont (0, "Microsoft Sans Serif", 64)
Texte.s = "PureBasic" + Chr(13) + "by" + Chr(13) + "Nico"
; Essayer l'une ou l'autre des options
;----------------------------------------------------------------------------------
If GetDimensionText(Texte, 0, @Width, @Height)
Image = CreateText(Width, Height, Texte, RGB(255,0,0), 0)
EndIf
;----------------------------------------------------------------------------------
;----------------------------------------------------------------------------------
; Si vous décochez ce qui suit, pensez à cocher les 3 lignes de code précédentes
; Pensez à modifier le chemin de l'image!
;----------------------------------------------------------------------------------
; If LoadImage(1, "C:\Users\Nico\Pictures\Firefox.png")
; Image = CreateTextWithImage(1, Texte, 40, RGB(255,0,0), 0)
; EndIf
;----------------------------------------------------------------------------------
; A présent si l'image est créé, ses dimensions ont été divisées par 2 pour avoir l'effet antialiasing
If Image
IDWindow.l = OpenWindow(#PB_Any, 100, 100, ImageWidth(Image), ImageHeight(Image), "", #PB_Window_BorderLess | #PB_Window_ScreenCentered)
If IDWindow
If SetLayeredWindow(WindowID(IDWindow))
If AlphaImageWindow(WindowID(IDWindow), ImageID(Image)) = 0
MessageRequester("Erreur", "Echec de la fonction : AlphaImageWindow!")
CloseWindow(IDWindow)
EndIf
Else
MessageRequester("Erreur", "Echec de la fonction : SetLayeredWindow")
CloseWindow(IDWindow)
EndIf
StickyWindow(IDWindow, 1)
Repeat
Event = WaitWindowEvent()
Select Event
Case #WM_LBUTTONDOWN
SendMessage_(WindowID(IDWindow), #WM_NCLBUTTONDOWN, #HTCAPTION, 0)
Case #PB_Event_CloseWindow
Quit = 1
EndSelect
Until Quit = 1
EndIf
Else
MessageRequester("Erreur", "L'image n'a pu être créé!!")
EndIf
