fb:porticula NoPaste

Info / Hilfe Liste
Übersicht / Liste Neu
Datei hochladen Suche
Quellcode suchen
Dateidownload
Windows TrueType experiment

Uploader:	Eternal_Pain
Datum/Zeit:	03.03.2014 06:33:26
#include once "windows.bi"

#include once "fbgfx.bi"



#Define Regular     &h00

#Define Italic      &h01

#Define Bold        &h02

#Define Underline   &h04

#Define StrikeOut   &h08



Type TTFTextMap

    Width  as Integer

    Height as Integer

    Map    as UByte ptr

End Type



Type pTTFTextMap as TTFTextMap ptr



Function CreateTTFTextMap(Byval Text as String, Byval Font as String, Byval Size as Integer, Byval Style as Integer) as pTTFTextMap

    Dim as Integer      minx    , miny     , maxx , maxy

    Dim as Integer      ScrWidth, ScrHeight

    Dim as Integer      Yv      , R        , G , B , C

    Dim as Integer ptr  rgbMap

    Dim as HDC          hdc     , vhdc

    Dim as HWND         hWnd

    Dim as HBITMAP      hbmp

    Dim as BITMAPINFO   bmpi

    Dim as HFONT        hFont

    Dim as LOGFONT      LogFont

    Dim as pTTFTextMap  TextMap



    Screeninfo ScrWidth, ScrHeight

    Screencontrol fb.GET_WINDOW_HANDLE, cast(integer,hWnd)



    hdc    = GetWindowDC(hWnd)

    vhdc   = CreateCompatibleDC(hdc)

    hbmp   = CreateCompatibleBitmap(hdc, ScrWidth, ScrHeight)

    bmpi   = type(type<BITMAPINFOHEADER>(sizeof(BITMAPINFOHEADER),ScrWidth,-ScrHeight,1,32,BI_RGB,0,0,0,0,0),{0,0,0,0})

    rgbMap = NEW Integer[ScrWidth*ScrHeight]



    With LogFont

        .lfHeight    = Size

        .lfFaceName  = Font

        .lfItalic    = IIF(Bit(Style,0),TRUE,FALSE)

        .lfWeight    = IIF(Bit(Style,1),FW_BOLD,FW_REGULAR)

        .lfUnderline = IIF(Bit(Style,2),TRUE,FALSE)

        .lfStrikeOut = IIF(Bit(Style,3),TRUE,FALSE)

    End With



    hFont = CreateFontIndirect(@LogFont)



    SelectObject(vhdc, hFont)

    SelectObject(vhdc, hbmp)



    SetBkMode(vhdc, &h000000)

    SetTextColor(vhdc, &hFFFFFF)



    TextOut(vhdc, 0, 0, Text, Len(Text))



    rgbMap = NEW Integer[ScrWidth * ScrHeight]

    GetDIBits(vhdc, hbmp, 0, ScrHeight, rgbMap, cast(any ptr,@bmpi), DIB_RGB_COLORS)



    DeleteObject(hFont)

    DeleteObject(hbmp)

    DeleteDC(vhdc)

    ReleaseDC(hWnd, hdc)



    minx = ScrWidth : miny = ScrHeight



    rgbMap[0]=1 ''test



    For y as Integer = 0 to ScrHeight-1

    For x as Integer = 0 to ScrWidth-1

        C=rgbMap[x+(y*ScrWidth)]

        If (C = 0) Then Continue For



        R = lobyte(hiword(C))

        G = hibyte(loword(C))

        B = lobyte(loword(C))



        Yv = 0.30 * R + 0.59 * G + 0.11 * B



        rgbMap[x+(y*ScrWidth)] = Yv



        If x<minx Then minx = x

        If x>maxx Then maxx = x

        If y<miny Then miny = y

        If y>maxy Then maxy = y

    next x

    next y



    TextMap = NEW TTFTextMap

    TextMap -> Width  = (maxx-minx)+1

    TextMap -> Height = (maxy-miny)+1

    TextMap -> Map    = NEW ubyte[TextMap -> Width * TextMap -> Height]



    For y as Integer = miny to maxy

    For x as Integer = minx to maxx

        C=rgbMap[x+(y*ScrWidth)]

        If (C = 0) Then Continue For

        TextMap -> Map[(x-minx) + ((y-miny)*TextMap -> Width)] = C

    Next x

    Next y



    Delete[] rgbMap

    Return TextMap

End Function



'test

Sub DrawTTFText(byval posx as Integer, byval posy as Integer, byval text as String, byval font as String, byval size as Integer, byval style as Integer)

    Dim as pTTFTextMap   Map

    Dim as Integer       c



    Map = CreateTTFTextMap(text,font,size,style)



    For y as Integer = 0 to Map->Height-1

    For x as Integer = 0 to Map->Width-1

        c = Map->Map[x+(y*Map->Width)]

        If c Then pset(posx+x,posy+y),rgb(c,c,c)

    Next x

    Next y



    Delete[] Map->Map

End Sub















screenres 640,480,32



DrawTTFText 100,100,"test 123","Arial",60,Regular





sleep