Реализация шрифтов с помощью GDI
Это своего рода расширенная реализация Draw string. Автор кода дает возможность использовать любой шрифт из установленных в системе для вывода текстовой информации. Использование простое, наверно единственный минус - платформозависимо.
Автор: Mysoft
Платформа: Windows
' FBGFX Font Render by Mysoft '' DrawFont([BUFFER],[POSX],[POSY],"STRING","Font Name",FontSize,[Color],[Style],[Charset]) ''uncomment the line below if you want the program to use unicode '#define Unicode '' this define allow you to set some effect while using anti-alias/blur (1 to 2) #DEFINE GAMMA 1.3 #INCLUDE "windows.bi" #INCLUDE "fbgfx.bi" Enum Charsets 'already denfined NULL_CHARSET = 0 'ANSI_CHARSET 'DEFAULT_CHARSET 'SYMBOL_CHARSET 'SHIFTJIS_CHARSET 'GB2312_CHARSET 'HANGEUL_CHARSET 'CHINESEBIG5_CHARSET 'OEM_CHARSET End Enum Enum TextStyle FS_BOLD = 2 FS_ITALIC = 4 FS_ANTIALIAS = 8 FS_BLUR = 16+8 End Enum Declare Sub DrawFont(BUFFER As Any ptr=0,POSX As Integer, POSY As Integer, _ FTEXT As String, FNAME As String,FSIZE As Integer, _ FCOLOR As uinteger=rgb(255,255,255), FSTYLE As integer=0, CHARSET As integer=DEFAULT_CHARSET) ' ************************************************************* ' ************************ EXAMPLE **************************** ' ************************************************************* Screenres 640,480,32,5 DrawFont(,30,20,"Testing ITALICI","Times New Roman",32,Rgb(32,64,255),FS_ITALIC) DrawFont(,380,20,"Microsoft","Tahoma",32,Rgb(32,64,255),FS_BOLD Or FS_ANTIALIAS) DrawFont(,30,100,"Testing ITALIC heuaheuea","Script",50,Rgb(32,64,255)) DrawFont(,30,180,"Testing ITALIC heuaheuea","Script",50,Rgb(32,64,255),FS_ANTIALIAS) DrawFont(,30,300,"?±E?","Webdings",100,Rgb(32,64,255),FS_BLUR) Sleep ' *********************************************************************** ' *********************************************************************** ' *********************************************************************** Sub DrawFont(BUFFER As Any ptr=0,POSX As Integer, POSY As Integer, _ FTEXT As String, FNAME As String,FSIZE As Integer, _ FCOLOR As uinteger=rgba(255,255,255,0), FSTYLE As integer=0, CHARSET As integer=DEFAULT_CHARSET ) ' allocating as static for speed Static FINIT As Integer Static As hdc THEDC Static As hbitmap THEBMP Static As Any Ptr THEPTR Static As fb.image Ptr FBBLK Static As Integer WIDCHAR(65535) Static As Integer TXTSZ,COUNT,RESU,RESUU Static As Any Ptr SRCBUF,DSTBUF Static As hfont THEFONT Static As Integer FW,FI,TXYY,FCOR Static DSKWND As hwnd, DSKDC As hdc Static MYBMPINFO As BITMAPINFO Static As TEXTMETRIC MYTXINFO Static As SIZE TXTSIZE Static As RECT RCT #DEFINE FontSize(PointSize) -MulDiv(PointSize, GetDeviceCaps(THEDC, LOGPIXELSY), 72) If FINIT = 0 Then '' allocating things and starting the "engine" FINIT = 1 With MYBMPINFO.bmiheader .biSize = Sizeof(BITMAPINFOHEADER) .biWidth = 2048 .biHeight = -513 .biPlanes = 1 .biBitCount = 32 .biCompression = BI_RGB End With ' creating a DC and a bitmap that will receive the rendered font DSKWND = GetDesktopWindow() DSKDC = GetDC(DSKWND) THEDC = CreateCompatibleDC(DSKDC) THEBMP = CreateDIBSection(THEDC,@MYBMPINFO,DIB_RGB_COLORS,@THEPTR,null,null) ReleaseDC(DSKWND,DSKDC) End If ' creating the font If (FSTYLE And FS_BOLD) Then FW = FW_BOLD Else FW = FW_NORMAL If (FSTYLE And FS_ITALIC) Then FI = True Else FI = False THEFONT = CreateFont(FontSize(FSIZE),0,0,0,FW,FI,0,0,CHARSET,0,0,0,0,Cast(Any Ptr,Strptr(FNAME))) ' selecting it SelectObject(THEDC,THEBMP) SelectObject(THEDC,THEFONT) GetTextMetrics(THEDC,@MYTXINFO) ' get text width/height GetTextExtentPoint32(THEDC,Strptr(FTEXT),Len(FTEXT),@TXTSIZE) TXTSZ = TXTSIZE.CX TXYY = TXTSIZE.CY If (FSTYLE And FS_ITALIC) Then If MYTXINFO.tmOverhang Then TXTSZ += MYTXINFO.tmOverhang Else TXTSZ += 1+(FSIZE/2) End If TXYY += 1+(FSIZE/8) End If If (FSTYLE And FS_ANTIALIAS) Then #IF GAMMA>1 And GAMMA <= 2 TXTSZ += GAMMA*2 #ENDIF End If With RCT .LEFT = 0 .TOP = 1 .RIGHT = TXTSZ .BOTTOM = TXYY+1 End With TXTSZ -= 1 TXYY -= 1 ' RGB to BGR Asm mov eax,[FCOLOR] And eax,0xFFFFFF mov [FCOR],eax bswap eax ror eax,8 mov [FCOLOR],eax End Asm ' Set Colors SetBkColor(THEDC,Rgba(255,0,255,0)) SetTextColor(THEDC,FCOLOR) ' disabling font smooth,rendering and enable again (if applicable) SystemParametersInfo(SPI_GETFONTSMOOTHING,null,@RESU,null) If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,False,@RESUU,null) ExtTextOut(THEDC,0,1,ETO_CLIPPED Or ETO_OPAQUE,@RCT,Strptr(FTEXT),Len(FTEXT),null) If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,True,@RESUU,null) ' filling FBGFX header FBBLK = THEPTR+(2048*4)-sizeof(fb.image) FBBLK->Type = 7 FBBLK->bpp = 4 FBBLK->Width = 2048 FBBLK->height = 512 FBBLK->pitch = 2048*4 ' blitting the rendered font to destion If (FSTYLE And FS_ANTIALIAS) Then Dim As Any Ptr MYBLK MYBLK = THEPTR+(2048*4) Asm mov ecx,2048*511 mov ebx,[FCOR] mov esi,[MYBLK] HERE: cmp [esi], dword Ptr 0xFF00FF je _TRANS_ mov [esi+3], Byte Ptr 0xFF _TRANS_: And [esi], dword Ptr 0xFF000000 Or [esi], ebx Add esi,4 dec ecx jnz HERE End Asm Dim As Integer TX,TY Dim As Integer ALP #DEFINE GetAlpha(PX,PY) Peek(MYBLK+((PY)*8192)+((PX)*4)+3) #DEFINE SetAlpha(PX,PY,NA) Poke(MYBLK+((PY)*8192)+((PX)*4)+3),NA If (FSTYLE And FS_BLUR) = FS_BLUR Then ' blur primeira linha For TX = 1 To TXTSZ-1 ALP = (GetAlpha(TX,0)+GetAlpha(TX+1,0)+GetAlpha(TX-1,0)+ _ GetAlpha(TX,1)+GetAlpha(TX-1,1)+GetAlpha(TX+1,1)) / 6 #IF GAMMA>1 And GAMMA <= 1.6 ALP *= (GAMMA+.5) If ALP > 255 Then ALP = 255 #ENDIF SetAlpha(TX,TY,ALP) Next TX ' blur conteudo For TX = 1 To TXTSZ-1 For TY = 1 To TXYY-1 ALP = (GetAlpha(TX,TY)+GetAlpha(TX+1,TY)+GetAlpha(TX-1,TY)+ _ GetAlpha(TX,TY-1)+GetAlpha(TX,TY+1) + _ GetAlpha(TX-1,TY-1)+GetAlpha(TX-1,TY+1)+ _ GetAlpha(TX+1,TY-1)+GetAlpha(TX+1,TY+1)) / 9 #IF GAMMA>1 And GAMMA <= 1.6 ALP *= (GAMMA+.5) If ALP > 255 Then ALP = 255 #ENDIF SetAlpha(TX,TY,ALP) Next TY Next TX ' blur ultima linha For TX = 1 To TXTSZ-1 ALP = (GetAlpha(TX,TY)+GetAlpha(TX+1,TY)+GetAlpha(TX-1,TY)+ _ GetAlpha(TX,TY-1)+GetAlpha(TX-1,TY-1)+GetAlpha(TX+1,TY-1)) / 6 #IF GAMMA>1 And GAMMA <= 1.6 ALP *= (GAMMA+.5) If ALP > 255 Then ALP = 255 #ENDIF SetAlpha(TX,TY,ALP) Next TX Else ' antialias primeira linha For TX = 1 To TXTSZ-1 ALP = (GetAlpha(TX,0)+GetAlpha(TX+1,0)+_ GetAlpha(TX-1,0)+GetAlpha(TX,1))/4 #IF GAMMA>1 And GAMMA <= 2 ALP *= GAMMA If ALP > 255 Then ALP = 255 #ENDIF SetAlpha(TX,TY,ALP) Next TX ' antialias conteudo For TX = 1 To TXTSZ-1 For TY = 1 To TXYY-1 ALP = (GetAlpha(TX,TY)+GetAlpha(TX+1,TY)+GetAlpha(TX-1,TY)+_ GetAlpha(TX,TY-1)+GetAlpha(TX,TY+1))/5 #IF GAMMA>1 And GAMMA <= 2 ALP *= GAMMA If ALP > 255 Then ALP = 255 #ENDIF SetAlpha(TX,TY,ALP) Next TY Next TX ' antialias ultima linha For TX = 1 To TXTSZ-1 ALP = (GetAlpha(TX,TY)+GetAlpha(TX+1,TY)+ _ GetAlpha(TX-1,TY)+GetAlpha(TX,TY-1))/4 #IF GAMMA>1 And GAMMA <= 2 ALP *= GAMMA If ALP > 255 Then ALP = 255 #ENDIF SetAlpha(TX,TY,ALP) Next TX End If Put BUFFER,(POSX,POSY),FBBLK,(0,0)-(TXTSZ-1,TXYY),alpha Else Put BUFFER,(POSX,POSY),FBBLK,(0,0)-(TXTSZ-1,TXYY),Trans End If ' cleanning up things DeleteObject(THEFONT) End Sub
