But if DrawText does no antialiasing, why your example has not show just black and white pixels?
I try to find a workaround (Fred knows, that DrawText
has already worked smooth in earlier PB versions), because GDI+ must not be available on all machines.
Here are two first code snippets for showing a alpha blended text on a window, would be interesting which results you can see on your PC?
Code: Select all
Enumeration
#CatWindow
#CatImage
#CatIcon
#FontIDs
#FontIDsEnde=#FontIDs+6
EndEnumeration
#MaxFontSize=1
#MaxFontStyle=1
#FontFace="Calibri"
;#FontFace="Arial"
Global Dim TextFont(#MaxFontSize,#MaxFontStyle)
s=-10
For i=0 To 1
s-6
t=0
For j=0 To 1
TextFont(i,j)=LoadFont(#FontIDs+i*(#MaxFontStyle+1)+j,#FontFace,s,#PB_Font_HighQuality|t)
t=#PB_Font_Bold
Next j
Next i
Procedure CreateText(x,y,w,h,Text.s,Flags=0)
Protected FontSize
Protected FontStyle
; Absatz
#TA=#CR; Absatz
#TZ=#LF; Zeilenumbruch
#TT=#TAB; Tabulator
; Flags
#T1=#SI; Farbe 1 (rot)
#T2=#SO; Farbe 2 (grün)
#TB=#ACK; Fettschrift
#CB=Chr(#TB)
;#TU=#BEL; Unterstrichen
;#CU=Chr(#TU)
#TH=#ENQ; Highlight (gelb)
#CH=Chr(#TH)
#FontBold=1
#FontUnderline=2
#FontHighlight=4
l=Len(Text)
px=x
n=0
DrawingFont(TextFont(FontSize,FontStyle))
DrawingFont(FontID(#FontIDs))
While n<l
c=PeekC(@Text+n)
n+1
Select c
Case #TB
FontStyle!#FontBold
DrawingFont(TextFont(FontSize,FontStyle&#FontBold))
Case #TH
FontStyle!#FontUnderline
Default
If c=' '
xmem=x
nmem=n
MemFontStyle=FontStyle
EndIf
px=DrawText(px,y,Chr(c),$FF000000,$FFFFFF00)
If c<>' ' And px>w+x And nmem
px=x
n=nmem
FontStyle=MemFontStyle
y+20
EndIf
EndSelect
Wend
EndProcedure
Procedure CreateBox(Image,w,h,Title.s,Text.s)
Protected n,c
#NoTransparency=$FF000000
#Radius=10
CreateImage(Image,w,h,32|#PB_Image_Transparent)
StartDrawing(ImageOutput(Image))
DrawingMode(#PB_2DDrawing_AllChannels)
RoundBox(1,1,w-2,h-2,#Radius-1,#Radius-1,#NoTransparency|$A0A0A0)
RoundBox(2,2,w-4,h-4,#Radius-2,#Radius-2)
DrawingMode(#PB_2DDrawing_AlphaBlend)
DrawText(20,30,Title,#NoTransparency)
Text=Text+" "+#CH+Text+#CH+" "
CreateText(20,60,260,200,Text+Text+Text)
StopDrawing()
EndProcedure
Procedure AlphaImageWindow(WindowID,ImageID)
Protected Image_HDC
Protected Image_Bitmap.BITMAP,Image_BitmapInfo.BITMAPINFO
Protected ContextOffset.POINT,Blend.BLENDFUNCTION
Protected x,y,w,h,Alpha
SetWindowLong_(WindowID,#GWL_EXSTYLE,GetWindowLong_(WindowID,#GWL_EXSTYLE)|#WS_EX_LAYERED)
Image_HDC=CreateCompatibleDC_(#Null)
Image_Ancienne=SelectObject_(Image_HDC,ImageID)
GetObject_(ImageID,SizeOf(BITMAP),@Image_Bitmap)
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
w=Image_Bitmap\bmWidth-1
h=Image_Bitmap\bmHeight-1
Protected Dim Image.l(w,h)
GetDIBits_(Image_HDC,ImageID,0,Image_Bitmap\bmHeight,@Image(),@Image_BitmapInfo,#DIB_RGB_COLORS)
For x=0 To w
For y=0 To h
Couleur=Image(x,y)
Alpha=Couleur>>24&$FF
If Alpha<$FF
Image(x,y)=Alpha<<24|MulDiv_(Couleur&$FF,Alpha,255)|(MulDiv_(Couleur&$FF00,Alpha,255)&$FF00)|(MulDiv_(Couleur&$FF0000,Alpha,255)&$FF0000)
EndIf
Next
Next
SetDIBits_(Image_HDC,ImageID,0,Image_Bitmap\bmHeight,@Image(),@Image_BitmapInfo,#DIB_RGB_COLORS)
Blend\SourceConstantAlpha=255
Blend\AlphaFormat=1
Blend\BlendOp=0
Blend\BlendFlags=0
UpdateLayeredWindow_(WindowID,0,0,@Image_BitmapInfo+4,Image_HDC,@ContextOffset,0,@Blend,2)
SelectObject_(Image_HDC,Image_Ancienne)
DeleteDC_(Image_HDC)
EndProcedure
CreateBox(#CatImage,300,220,"Title","This is a nice text with "+#CB+"extremly"+#CB+" nonsence.")
OpenWindow(#CatWindow,0,200,ImageWidth(#CatImage),ImageHeight(#CatImage),"Test",#PB_Window_BorderLess|#PB_Window_ScreenCentered|#PB_Window_Invisible)
AlphaImageWindow(WindowID(#CatWindow),ImageID(#CatImage))
HideWindow(0,0)
Repeat
Event=WaitWindowEvent()
If Event=#WM_LBUTTONDOWN
SendMessage_(WindowID(0),#WM_NCLBUTTONDOWN,#HTCAPTION,0)
EndIf
Until Event=#PB_Event_CloseWindow Or Event=#WM_CHAR
In the second code I have tried to use larger fonts to get better results, but everything looks blurred when setting the #FontQuality>0...
BTW: the CatText procedure is used to calculate word wrapping and the height of the text in one pass and to draw the result in a second pass...
Code: Select all
#FontQuality=1; 0: original font size, 1: size*2, 2: size*4 etc.
Procedure Init()
Enumeration
#CatWindow
#CatImage
#CatText
#CatOnOff
EndEnumeration
#MaxFontSize=1
#MaxFontColors=2
#FontFace="Calibri"
Structure FontType
ID.i[2]
Height.i
EndStructure
Global Dim Font.FontType(#MaxFontSize)
Global Dim FontColor.i(#MaxFontColors)
FontColor(0)=$FF000000
FontColor(1)=$FFA02020
FontColor(2)=$FF20A020
Protected i,s
Protected LF.LOGFONT
;LF\lfHeight=32
;LF\lfWidth=0
;LF\lfEscapement=0
;LF\lfOrientation=0
;LF\lfWeight=#FW_DONTCARE
;LF\lfItalic=0
;LF\lfUnderline=0
;LF\lfStrikeOut=0
LF\lfCharSet=#DEFAULT_CHARSET
LF\lfOutPrecision=#OUT_DEFAULT_PRECIS
LF\lfClipPrecision=#CLIP_DEFAULT_PRECIS
LF\lfQuality=#CLEARTYPE_NATURAL_QUALITY;#CLEARTYPE_QUALITY
LF\lfPitchAndFamily=#DEFAULT_PITCH|#FF_DONTCARE
PokeS(@LF\lfFaceName[0],#FontFace)
For i=0 To 1
With Font(i)
\Height=(31+i*18)<<#FontQuality>>1
LF\lfHeight=-\Height
LF\lfWeight=#FW_NORMAL
;LF\lfWeight=#FW_DEMIBOLD
\ID[0]=CreateFontIndirect_(@LF)
;LF\lfWeight=#FW_BLACK
LF\lfWeight=#FW_BOLD
\ID[1]=CreateFontIndirect_(@LF)
EndWith
Next i
Font(0)\Height+2<<#FontQuality
Font(1)\Height-1<<#FontQuality
EndProcedure
Procedure AlphaImageWindow(Window,Image)
Protected Image_HDC,Image_Object
Protected Image_Bitmap.BITMAP,Image_BitmapInfo.BITMAPINFO
Protected ContextOffset.POINT,Blend.BLENDFUNCTION
Protected x,y,w,h,Alpha,Color
Window=WindowID(Window)
Image=ImageID(Image)
SetWindowLong_(Window,#GWL_EXSTYLE,GetWindowLong_(Window,#GWL_EXSTYLE)|#WS_EX_LAYERED)
Image_HDC=CreateCompatibleDC_(#Null)
Image_Object=SelectObject_(Image_HDC,Image)
GetObject_(Image,SizeOf(BITMAP),@Image_Bitmap)
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
w=Image_Bitmap\bmWidth-1
h=Image_Bitmap\bmHeight-1
SetWindowPos_(Window,#HWND_TOPMOST,100,100,w,h,#SWP_NOACTIVATE)
Protected Dim Image.l(w,h)
GetDIBits_(Image_HDC,Image,0,Image_Bitmap\bmHeight,@Image(),@Image_BitmapInfo,#DIB_RGB_COLORS)
For x=0 To w
For y=0 To h
Color=Image(x,y)
Alpha=Color>>24&$FF
If Alpha<$FF
Image(x,y)=Alpha<<24|MulDiv_(Color&$FF,Alpha,255)|(MulDiv_(Color&$FF00,Alpha,255)&$FF00)|(MulDiv_(Color&$FF0000,Alpha,255)&$FF0000)
EndIf
Next
Next
SetDIBits_(Image_HDC,Image,0,Image_Bitmap\bmHeight,@Image(),@Image_BitmapInfo,#DIB_RGB_COLORS)
Blend\SourceConstantAlpha=255
Blend\AlphaFormat=1
Blend\BlendOp=0
Blend\BlendFlags=0
UpdateLayeredWindow_(Window,0,0,@Image_BitmapInfo+4,Image_HDC,@ContextOffset,0,@Blend,2)
SelectObject_(Image_HDC,Image_Object)
DeleteDC_(Image_HDC)
EndProcedure
Procedure.i CatText(w,h,Text.s,Flags=0)
Debug "***"+Str(w)+"***"
#FontBold=%0001
#FlagBig= %00000001
#FlagVCenter= %00000010
#FlagCenter= %00000100
#FlagIndent= %00001000
#FlagDrawing= %10000000
Protected FontSize=Flags&#FlagBig
Protected FontStyle,MemFontStyle
Protected FontColor,MemFontColor
Protected Px,Py,MemPx,n,MemN,Word
Protected c,l,z
; Absatz
#TR=#CR; Absatz
#TZ=#LF; Zeilenumbruch
#CZ=#LF$
#TT=#TAB; Tabulator
#CT=#TAB$
; Flags
#T1=#SI; Farbe 1 (rot)
#C1=Chr(#T1)
#T2=#SO; Farbe 2 (grün)
#C2=Chr(#T2)
#TB=#ACK; Fettschrift
#CB=Chr(#TB)
#FontBold=1
;LineXY(x,y,x,y+h,$FFFF0000)
;LineXY(x+w,y,x+w,y+h,$FFFF0000)
w<<#FontQuality
h<<#FontQuality
If Flags&#FlagDrawing
StopDrawing()
EndIf
CreateImage(#CatText,w,h,32|#PB_Image_Transparent)
StartDrawing(ImageOutput(#CatText))
;DrawingMode(#PB_2DDrawing_AlphaBlend)
;DrawingMode(#PB_2DDrawing_Transparent)
DrawingMode(#PB_2DDrawing_AllChannels)
With Font(FontSize)
z=0
Word=0
l=Len(Text)
Repeat
FontStyle=0
FontColor=0
n=0
Px=0
If z And Flags&#FlagVCenter
Py=(h-Py-MulDiv_(\Height,10,8))>>1
Else
Py=0
EndIf
DrawingFont(\ID[FontStyle])
While n<l
c=PeekC(@Text+n)
n+1
Select c
Case #TB
FontStyle!#FontBold
DrawingFont(\ID[FontStyle])
Case #TR
Px=0
Py+\Height+\Height>>2
Word=0
Case #T1
If FontColor=1
FontColor=0
Else
FontColor=1
EndIf
Case #T2
If FontColor=2
FontColor=0
Else
FontColor=2
EndIf
Case #TZ
Px=0
Py+\Height
Word=0
Default
If c=' '
MemPx=Px
MemN=n
MemFontStyle=FontStyle
MemFontColor=FontColor
Word+1
EndIf
If z
Px=DrawText(Px,Py,Chr(c),FontColor(FontColor),#Null)
Else
Px+TextWidth(Chr(c))
EndIf
If c<>' ' And Px>w And MemN
;LineXY(MemPx,Py,MemPx,Py+\Height,$FF00FF00)
Px=0
If Word
n=MemN
FontStyle=MemFontStyle
FontColor=MemFontColor
PokeC(@Text+n-1,#TZ)
Word=0
Else
Text=Left(Text,n-1)+#CZ+Mid(Text,n)
l+1
EndIf
Py+\Height
EndIf
EndSelect
Wend
z+1+(Flags!#FlagDrawing)&#FlagDrawing
Until z>1
StopDrawing()
ResizeImage(#CatText,w>>#FontQuality,h>>#FontQuality)
If Flags&#FlagDrawing
StartDrawing(ImageOutput(#CatImage))
DrawingMode(#PB_2DDrawing_AlphaBlend)
EndIf
ProcedureReturn (Py+MulDiv_(\Height,10,8))>>#FontQuality
EndWith
EndProcedure
Procedure CatHelp(Title.s,Text.s)
#CatWidth=380
#CatCorner=6
#CatSpace=15
Protected n,c,h
#NoTransparency=$FF000000
For n=0 To Random(2)
Text=Text+#C1+Text+#C1+#C2+Text+#C2
Next n
n=CatText(#CatWidth-#CatSpace<<1,60,Text,#False)
h=n+50
CreateImage(#CatImage,#CatWidth,h,32|#PB_Image_Transparent)
StartDrawing(ImageOutput(#CatImage))
DrawingMode(#PB_2DDrawing_AllChannels)
RoundBox(1,1,#CatWidth-2,h-2,#CatCorner-1,#CatCorner-1,#NoTransparency|$A0A0A0)
RoundBox(2,2,#CatWidth-4,h-4,#CatCorner-2,#CatCorner-2)
DrawingMode(#PB_2DDrawing_AlphaBlend)
CatText(#CatWidth-#CatSpace<<1,50,Title,#FlagBig|#FlagVCenter|#FlagDrawing)
DrawImage(ImageID(#CatText),#CatSpace,0)
CatText(#CatWidth-#CatSpace<<1,h-50,Text,#FlagVCenter|#FlagDrawing)
DrawImage(ImageID(#CatText),#CatSpace,50)
StopDrawing()
AlphaImageWindow(#CatWindow,#CatImage)
HideWindow(#CatWindow,0)
EndProcedure
Init()
OpenWindow(#CatWindow,0,0,0,0,"Cat",#PB_Window_BorderLess|#PB_Window_Invisible)
StickyWindow(#CatWindow,1)
CatHelp("Hi, stranger!","Need some training? This is a "+#C2+"nice"+#C2+" text with "+#CB+"extremly"+#CB+" nonsence.")
Repeat
Event=WaitWindowEvent()
Select Event
Case #WM_LBUTTONDOWN
SendMessage_(WindowID(0),#WM_NCLBUTTONDOWN,#HTCAPTION,0)
Case #PB_Event_CloseWindow,#WM_CHAR
End
EndSelect
ForEver
