Buchempfehlung
Windows-Programmierung. Das Entwicklerhandbuch zur WIN32-API
Windows-Programmierung. Das Entwicklerhandbuch zur WIN32-API
"Der" Petzold, das über 1000 Seiten starke Standardwerk zum Win32-API - besonders nützlich u. a. bei der GUI-Programmierung in FreeBASIC! [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe
Liste
Übersicht / Liste
Neu
Datei hochladen
Suche
Quellcode suchen
Download
Dateidownload

inc\CreateStaticText.bas

Uploader:MitgliedEternal_Pain
Datum/Zeit:19.03.2014 04:44:53
Hinweis: Dieser Quelltext ist Bestandteil des Projekts Windows Easy Gui (WEG), zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.

'FontStyles
#Define Regular     &h00
#Define Italic      &h01
#Define Bold        &h02
#Define Underline   &h04
#Define StrikeOut   &h08

Sub Item_StaticText.Destroy()
    ID = "" : Title = ""
    DestroyWindow(whwnd)
    DeleteObject(Font)
    DeleteObject(BckBrush)
    Font   = 0 : BckBrush = 0
    FColor = 0 : BColor   = 0
End SUb

Function CreateStaticText(byref ItemHandle as Item        ,  byval px     as Integer     , byval py        as Integer     , _
                          byval TxT        as String      ,  byval Font   as String  = "", byval FontStyle as UInteger = 0, _
                          byval FontSize   as Integer = 16,  byval FColor as Integer = 0 , byval BColor    as Integer  = TRANSPARENT) as Item

    Dim as UInteger Style   = WS_CHILD OR WS_CLIPSIBLINGS

    If (ItemHandle = 0) orelse (Len(TxT) = 0) Then return NULL

    Dim as RECT    prect
    Dim as HWND    phwnd
    Dim as Integer rx, ry

    If (ItemHandle -> ID = WindowID) Then
        phwnd = ItemHandle -> whwnd
        rx = px : ry = py
    ElseIf (ItemHandle -> ID = GroupBoxID) Then
        phwnd = GetParent(ItemHandle -> whwnd)
        GetClientRect(ItemHandle -> whwnd, @prect)
        MapWindowPoints(ItemHandle -> whwnd, phwnd, Cast(LPPOINT, @prect),2)
        rx = prect.left + px : ry = prect.top + py
    Else
        LOGSTRING(Time & " | ERROR | Parent is not an valid Item.")
        Return NULL
    End If

    Dim as Item_StaticText ptr newStaticText = new Item_StaticText

    newStaticText -> whwnd = CreateWindowEx(NULL, "STATIC", TxT, Style, 0, 0, 0, 0, phwnd, NULL, Globals.hInstance, newStaticText)

    If (newStaticText -> whwnd = 0) Then
        Delete newStaticText
        LOGSTRING(Time & " | ERROR | Failed to create " & StaticTextID)
        MessageBox(NULL,"Failed to create " & StaticTextID, "Error", NULL)
        Return NULL
    End If

    SetWindowLongPtr(newStaticText -> whwnd, GWLP_USERDATA, Cast(LONG_PTR, newStaticText))

    newStaticText -> ID     = StaticTextID
    newStaticText -> Title  = TxT
    newStaticText -> FColor = Convert_RGB_To_BGR(FColor)
    newStaticText -> BColor = TRANSPARENT

    If BColor<>TRANSPARENT Then
        newStaticText -> BColor   = Convert_RGB_To_BGR(BColor)
        newStaticText -> BckBrush = CreateSolidBrush(newStaticText -> BColor)
    End If

    If Font = "" Then Font = WinExtFontName

    Dim as LOGFONT  lf

    With lf
        .lfHeight    = FontSize
        .lfFaceName  = Font
        .lfItalic    = IIF(Bit(FontStyle,0),TRUE,FALSE)
        .lfWeight    = IIF(Bit(FontStyle,1),FW_BOLD,FW_REGULAR)
        .lfUnderline = IIF(Bit(FontStyle,2),TRUE,FALSE)
        .lfStrikeOut = IIF(Bit(FontStyle,3),TRUE,FALSE)
    End With

    newStaticText -> Font = CreateFontIndirect(@lf)

    Dim as HDC      dDC = GetDC(NULL)
    Dim as HDC      fDC = CreateCompatibleDC(dDC)
    Dim as SIZE     fSize

    SelectObject(fDC, newStaticText -> Font)
    GetTextExtentPoint32(fDC, TxT, len(TxT), @fSize)

    ''// extend for overhanging text (italic and bold problems)
    ''// http://www.codeproject.com/Articles/14915/Width-of-text-in-italic-font
    Dim as ABCFLOAT ptr WidthsABC = new ABCFLOAT[256]
    GetCharABCWidthsFloat(fDC, 0, 255, WidthsABC)

    'DeleteObject(newStaticText -> Font)
    DeleteDC(fDC)
    ReleaseDC(NULL,dDC)

    ''// overhang of the last character
    Dim as double dOverhangTrailing = WidthsABC[TxT[Len(TxT)-1]].abcfC

    Delete[] WidthsABC
    If dOverhangTrailing<0 Then fSize.CX -= dOverhangTrailing

    MoveWindow(newStaticText -> whwnd, rx, ry, fSize.CX, fSize.CY, TRUE)
    ShowWindow(newStaticText -> whwnd, SW_SHOW)

    SendMessage(newStaticText -> whwnd, WM_SETFONT, Cast(WPARAM, newStaticText -> Font), Cast(LPARAM, TRUE))

    LOGSTRING(Time & " | INFO  | " & StaticTextID & " " & TxT & " created on " & ItemHandle -> ID & " " & ItemHandle -> Title & ".")

    Globals.ItemList.AddItem(newStaticText)

    return newStaticText
End Function