pas mal de temps que je n'ai pas posté de codes, en attendant pourriez-vous tester cet exécutable ?
DrawFontCanvas
Un clic droit et sélectionnez la fonte
Merci pour vos retours
Voici toutes les fontes utilisées :
Apple II Font
Apple II Font Out
Minitel Font
Terminal Font
Ghost'n Goblins Font :
Et le code :
Code : Tout sélectionner
;- Datasection
DataSection
_DS_IMG_Font_APPLE: IncludeBinary "Img_Spr\IMG_FONT_APPLE.png"
_DS_IMG_Font_APPLE_Out: IncludeBinary "Img_Spr\IMG_FONT_APPLE_OUT.png"
_DS_IMG_Font_MINITEL: IncludeBinary "Img_Spr\IMG_FONT_MINITEL.png"
_DS_IMG_Font_TERMINAL: IncludeBinary "Img_Spr\IMG_FONT_TERMINAL.png"
_DS_IMG_Font_GOBLINS: IncludeBinary "Img_Spr\IMG_FONT_G&G.png"
EndDataSection
Enumeration
#MAIN_WIN
#CANVAS
EndEnumeration
#SCREEN_Width = 640
#SCREEN_Height = 480
#NB_CHAR_BY_LINE = 28 ; 28 Char by Line inside Font Image
Structure CS_PIXEL
Pixel.l ; Fixed to 4 bits
EndStructure
Structure CS_FONT
FontName.s
CharWidth.i
CharHeight.i
Address.i
EndStructure
Global.i ActualSizeH = 0, ActualSizeW = 0, SpaceForDisable = 1, LastFontUsed = -1, LastNumFont = 0, ResizeMode = #PB_Image_Raw
Global.i TransparentColor, ImgFont
Global.i MaxCharByLine, MaxLine
Global.i ColorFontWhite, ColorFontBlack, ColorFontGrey, ColorFontRed, ColorFontGreen, ColorFontBlue, ColorFontNewRed, ColorFontYellow
Global.i PosX, PosY
Global.CS_FONT FontList
Procedure.i ConvertToAlpha(__ImageID.i, __TransparentColor.i)
; The '__TransparentColor' become Alpha
Protected.i _BufferImg, _PitchImg, _PixelFormatImg
Protected.i _X, _Y, _OnePixel
Protected.i *Line.CS_PIXEL
StartDrawing(ImageOutput(__ImageID))
_BufferImg = DrawingBuffer()
_PitchImg = DrawingBufferPitch()
; _PixelFormatImg = DrawingBufferPixelFormat() - #PB_PixelFormat_ReversedY
For _Y = 0 To ImageHeight(__ImageID) - 1
*Line = _BufferImg + _PitchImg * _Y
For _X = 0 To ImageWidth(__ImageID) - 1
_OnePixel = *Line\Pixel
If _OnePixel = $FF000000 | __TransparentColor ; Color to change ?
*Line\Pixel = $00FFFFFF ; Convert to AlphaChannel
EndIf
*Line + 4 ; Next Pixel
Next
Next
StopDrawing()
EndProcedure
Procedure SetImgColor(__Color.i)
TransparentColor = __Color
EndProcedure
Procedure.i MakeFontColor(__Color.i)
Protected.i _NewImgFont
_NewImgFont = CreateImage(#PB_Any, ImageWidth(ImgFont), ImageHeight(ImgFont), 32)
If _NewImgFont
StartDrawing(ImageOutput(_NewImgFont))
; Draw a box for the char color
Box(0,0,ImageWidth(ImgFont),ImageHeight(ImgFont), __Color)
; Drawing the font in Alpha mdoe
DrawAlphaImage(ImageID(ImgFont), 0, 0, 255)
StopDrawing()
;Convert the transparent color to an Alpha
ConvertToAlpha(_NewImgFont, TransparentColor)
ProcedureReturn _NewImgFont
Else
ProcedureReturn #False
EndIf
EndProcedure
Procedure GenerateColorFont()
If IsImage(ColorFontWhite) : FreeImage(ColorFontWhite) : EndIf
If IsImage(ColorFontBlack) : FreeImage(ColorFontBlack) : EndIf
If IsImage(ColorFontGrey) : FreeImage(ColorFontGrey) : EndIf
If IsImage(ColorFontRed) : FreeImage(ColorFontRed) : EndIf
If IsImage(ColorFontGreen) : FreeImage(ColorFontGreen) : EndIf
If IsImage(ColorFontBlue) : FreeImage(ColorFontBlue) : EndIf
If IsImage(ColorFontNewRed) : FreeImage(ColorFontNewRed) : EndIf
If IsImage(ColorFontYellow) : FreeImage(ColorFontYellow) : EndIf
; $BBGGRR
ColorFontWhite = MakeFontColor($FFFFFF)
ColorFontBlack = MakeFontColor($000000)
ColorFontGrey = MakeFontColor($99A8AC)
ColorFontRed = MakeFontColor($0000FF)
ColorFontGreen = MakeFontColor($00FF00)
ColorFontBlue = MakeFontColor($FF0000)
ColorFontNewRed = MakeFontColor($6600FF)
ColorFontYellow = MakeFontColor($00CCEE)
EndProcedure
Procedure SetValueFont(__Name.s, __Width.i, __Height.i, __Address.i)
FontList\FontName = __Name
FontList\CharWidth = __Width
FontList\CharHeight = __Height
FontList\Address = __Address
ActualSizeW = FontList\CharWidth
ActualSizeH = FontList\CharHeight
If IsImage(ImgFont) : FreeImage(ImgFont) : EndIf
ImgFont = CatchImage(#PB_Any, FontList\Address)
If ImgFont
ConvertToAlpha(ImgFont, #White)
SetImgColor($FF00FF)
GenerateColorFont()
Else
MessageRequester("Error","Cannot create new image font for "+FontList\FontName)
End
EndIf
EndProcedure
Procedure SetFont(__Num.i)
Select __Num
Case 0
SetValueFont("Apple", 6, 8, ?_DS_IMG_Font_APPLE)
Case 1
SetValueFont("Apple OUT", 7, 10, ?_DS_IMG_Font_APPLE_Out)
Case 2
SetValueFont("Minitel", 14, 17, ?_DS_IMG_Font_MINITEL)
Case 3
SetValueFont("Terminal", 12, 16, ?_DS_IMG_Font_TERMINAL)
Case 4
SetValueFont("Ghost & Goblins", 16, 16, ?_DS_IMG_Font_GOBLINS)
EndSelect
LastNumFont = __Num
EndProcedure
Procedure Init()
UsePNGImageDecoder()
SetFont(0)
EndProcedure
Procedure SetResizeMode(__Flag.i = #PB_Image_Raw)
ResizeMode = __Flag
EndProcedure
Procedure ResizeFont(__Width.i = -1, __Height.i = -1)
Protected.f _RatioH, _RatioW
SetFont(LastNumFont)
If __Width <> -1
_RatioW = __Width / FontList\CharWidth
Else
_RatioW = 1 ; cf below, multiply with the Height
EndIf
If __Height <> -1
_RatioH = __Height / FontList\CharHeight
Else
_RatioH = _RatioW
EndIf
SpaceForDisable = _RatioW
ActualSizeH = FontList\CharHeight * _RatioH
ActualSizeW = FontList\CharWidth * _RatioW
SetWindowTitle(#MAIN_WIN, "FONT "+FontList\FontName+" / Size ("+Str(ActualSizeW)+"x"+Str(ActualSizeH)+")")
ResizeImage(ImgFont, ImageWidth(ImgFont) * _RatioW, ImageHeight(ImgFont) * _RatioH, ResizeMode)
MaxCharByLine = WindowWidth(#MAIN_WIN)/ActualSizeW
MaxLine = WindowHeight(#MAIN_WIN)/ActualSizeH
GenerateColorFont()
EndProcedure
Procedure GS_TextGadget(__X.i,__Y.i,__Text.s, __FontID.i = -1)
Protected.i _Len = Len(__Text)
Protected.s _Char
Protected.i _Ascii, _FontLine, _ClipX, _ClipY
Protected.i _Index, _tmpImage
If __FontID = 0
MessageRequester("Error", "No ID for font "+FontList\FontName)
End
EndIf
If __FontID = -1
If LastFontUsed <> -1
__FontID = LastFontUsed
Else
;Error
End
EndIf
EndIf
For _Index = 1 To _Len
_Char = Mid(__Text, _Index, 1)
_Ascii = Asc(_Char) - 32
_ClipX = (_Ascii % #NB_CHAR_BY_LINE) * ActualSizeW
_ClipY = (_Ascii / #NB_CHAR_BY_LINE) * ActualSizeH
_tmpImage = GrabImage(__FontID, #PB_Any, _ClipX, _ClipY, ActualSizeW, ActualSizeH)
If _tmpImage : DrawAlphaImage(ImageID(_tmpImage), __X, __Y, 255) : FreeImage(_tmpImage) : EndIf
__X + ActualSizeW
Next
LastFontUsed = __FontID
EndProcedure
Procedure Cls(__Canvas.i, __color.i)
StartDrawing(CanvasOutput(__Canvas))
Box(0,0,#SCREEN_Width,#SCREEN_Height, __color)
StopDrawing()
EndProcedure
Procedure DrawMyFont(__Canvas.i)
Protected.i _PosX = 0, _PosY = 0
StartDrawing(CanvasOutput(__Canvas))
GS_TextGadget(_PosX,_PosY, "Hello there !", ColorFontWhite)
GS_TextGadget(_PosX+SpaceForDisable,_PosX+ActualSizeH+SpaceForDisable, "Open or Cancel", ColorFontWhite)
GS_TextGadget(_PosX,_PosY+ActualSizeH, "Open or Cancel", ColorFontGrey)
GS_TextGadget(_PosX,_PosY+ActualSizeH*2, "Now i'm in red :)", ColorFontRed)
GS_TextGadget(_PosX,_PosY+ActualSizeH*3, "----**** Like the Green one ? ****----", ColorFontGreen)
GS_TextGadget(_PosX,_PosY+ActualSizeH*4, "Or the blue one is better, make your choice :D", ColorFontBlue)
GS_TextGadget(_PosX,_PosY+ActualSizeH*5, "----5----1----5----2----5----3----5----4----5----5----5----6----5----7----5----8----5----9--", ColorFontBlack)
GS_TextGadget(_PosX,_PosY+ActualSizeH*6, " 0 0 0 0 0 0 0 0 0")
GS_TextGadget(_PosX,_PosY+ActualSizeH*8, "Once upon a time, a woman with big brown eyes knocked at my door...")
GS_TextGadget(_PosX,_PosY+ActualSizeH*9, "She started to scream but stopped when she saw me",ColorFontWhite)
GS_TextGadget(_PosX,_PosY+ActualSizeH*10, "i was making my exercices and i was sweaty...")
GS_TextGadget(_PosX,_PosY+ActualSizeH*15," TOP SCORE",ColorFontNewRed)
GS_TextGadget(_PosX,_PosY+ActualSizeH*15,"PLAYER # PLAYER $",ColorFontYellow)
GS_TextGadget(_PosX,_PosY+ActualSizeH*16,"10000 100,000,000 0",ColorFontWhite)
GS_TextGadget(_PosX,_PosY+ActualSizeH*20,"Maximum characters by line = "+Str(MaxCharByLine),ColorFontYellow)
GS_TextGadget(_PosX,_PosY+ActualSizeH*21,"Maximum lines = "+Str(MaxLine))
StopDrawing()
EndProcedure
Procedure UpdateWindow()
MaxCharByLine = WindowWidth(#MAIN_WIN)/ActualSizeW
MaxLine = WindowHeight(#MAIN_WIN)/ActualSizeH
SetWindowTitle(#MAIN_WIN, "FONT "+FontList\FontName+" / Size ("+Str(ActualSizeW)+"x"+Str(ActualSizeH)+")")
Cls(#CANVAS, RGB(150, 100, 50))
SetActiveGadget(#CANVAS)
EndProcedure
Procedure CheckEventCanvas(__CanvasGadget.i)
DrawMyFont(__CanvasGadget)
Select EventType()
Case #PB_EventType_Input
Debug Chr(GetGadgetAttribute(__CanvasGadget, #PB_Canvas_Input))
Case #PB_EventType_RightClick
DisplayPopupMenu(0, WindowID(#MAIN_WIN))
Case #PB_EventType_KeyUp
_key = GetGadgetAttribute(__CanvasGadget, #PB_Canvas_Key)
If _key = #PB_Shortcut_Escape
_Quit = 1
EndIf
EndSelect
EndProcedure
Procedure DisplayWindow()
Protected.i _ValEvent
If OpenWindow(#MAIN_WIN, 0, 0, #SCREEN_Width, #SCREEN_Height, "FONT "+FontList\FontName+" / Size ("+Str(ActualSizeW)+"x"+Str(ActualSizeH)+")", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_ScreenCentered)
If CreatePopupMenu(0)
OpenSubMenu("Change Font")
MenuItem(1, "Apple")
MenuItem(2, "Apple OUT")
MenuItem(3, "Minitel")
MenuItem(4, "Terminal")
MenuItem(5, "Ghost & Goblins")
CloseSubMenu()
OpenSubMenu("Size")
MenuItem(6, ">> Original size")
MenuItem(7, "Size 6")
MenuItem(8, "Size 7")
MenuItem(9, "Size 8")
MenuItem(10, "Size 9")
MenuItem(11, "Size 10")
MenuItem(12, "Size 11")
MenuItem(13, "Size 12")
MenuItem(14, "Size 13")
MenuItem(15, "Size 14")
CloseSubMenu()
MenuBar()
MenuItem(99, "Quit")
EndIf
CanvasGadget(#CANVAS, 0, 0, #SCREEN_Width, #SCREEN_Height, #PB_Canvas_Keyboard)
MaxCharByLine = WindowWidth(#MAIN_WIN)/ActualSizeW
MaxLine = WindowHeight(#MAIN_WIN)/ActualSizeH
Cls(#CANVAS, RGB(150, 100, 50))
SetActiveGadget(#CANVAS)
Repeat
Repeat
_EventWindow = WaitWindowEvent()
Select _EventWindow
Case #PB_Event_CloseWindow
_Quit = 1
Case #PB_Event_Gadget
If EventGadget() = #CANVAS
CheckEventCanvas(#CANVAS)
EndIf
Case #PB_Event_Menu
_ValEvent = EventMenu()
Select _ValEvent
Case 1
SetFont(0) : UpdateWindow()
Case 2
SetFont(1) : UpdateWindow()
Case 3
SetFont(2) : UpdateWindow()
Case 4
SetFont(3) : UpdateWindow()
Case 5
SetFont(4) : UpdateWindow()
Case 6
ResizeFont(FontList\CharWidth, FontList\CharHeight) : Cls(#CANVAS, RGB(150, 100, 50))
Case 7 To 15
ResizeFont(_ValEvent-1) : Cls(#CANVAS, RGB(150, 100, 50))
Case 99 : _Quit = 1
EndSelect
EndSelect
Until _Quit
Until _Quit
EndIf
EndProcedure
;- ---- MAIN ----
Init()
DisplayWindow()
