Buchempfehlung
MySQL kurz & gut
MySQL kurz & gut
Das preiswerte Taschen- buch stellt MySQL-rele- vante Inhalte systematisch und knapp dar, sodass es sich optimal zum Nach- schlagen beim Pro- grammieren eignet. [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\CreateFontSelectCombo.bas

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

Declare Function AddFontSelectCombo(byref ItemHandle as Item, byval FontName as String) as Integer

Sub Item_FontSelectCombo.Destroy()
    ID = "" : Title = ""
    DestroyWindow(whwnd)
    iCount    = 0 : iState    = 0
    wSizeMode = 0 : hSizeMode = 0
    iWidth    = 0 : iHeight   = 0
End Sub

''Callback
Function EnumFontFamiliesExProc(byval lpelfe as ENUMLOGFONTEX ptr, byval lpntme as NEWTEXTMETRICEX ptr, byval FontType as Integer, byval lParam as LPARAM) as Integer
    If (FontType and TRUETYPE_FONTTYPE)=TRUETYPE_FONTTYPE andalso bit(lpntme->ntmTm.ntmFlags,6) Then 'Print "Typ   : TrueType-Font";
        If lpelfe->elfLogFont.lfFaceName[0]<>64 Then AddFontSelectCombo(Cast(Item,lParam), lpelfe->elfLogFont.lfFaceName)
    End If
    return 1
End Function

Function CreateFontSelectCombo(byref ItemHandle as Item, byval px as Integer, byval py as Integer, byval iWidth as Integer = 0, byval iHeight as Integer = 0) as Item
    Dim as UInteger ExStyle = WS_EX_CLIENTEDGE
    Dim as UInteger Style   = WS_CHILD OR WS_VSCROLL OR CBS_AUTOHSCROLL OR CBS_DROPDOWNLIST OR CBS_HASSTRINGS OR WS_TABSTOP OR WS_CLIPSIBLINGS OR CBS_NOINTEGRALHEIGHT OR CBS_OWNERDRAWVARIABLE

    If (ItemHandle = 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_FontSelectCombo ptr newFontSelectCombo = new Item_FontSelectCombo

    newFontSelectCombo -> whwnd = CreateWindowEx(ExStyle, "COMBOBOX", NULL, Style, rx, ry, iWidth, iHeight, phwnd, NULL, Globals.hInstance, newFontSelectCombo)

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

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

    newFontSelectCombo -> ID        = FontSelectComboID
    newFontSelectCombo -> Title     = str(newFontSelectCombo -> whwnd)
    newFontSelectCombo -> wSizeMode = IIF(iWidth,0,1)
    newFontSelectCombo -> hSizeMode = IIF(iHeight,0,1)
    newFontSelectCombo -> iWidth    = iWidth
    newFontSelectCombo -> iHeight   = iHeight
    newFontSelectCombo -> iState    = 0
    '- Enum/Add List
    Dim as HDC hDC = GetDC(NULL)
    Dim as LOGFONT lf

    lf.lfCharSet = ANSI_CHARSET'DEFAULT_CHARSET

    EnumFontFamiliesEx( hDC, @lf, cast(any ptr,@EnumFontFamiliesExProc), Cast(LPARAM,newFontSelectCombo), NULL )

    ReleaseDC(NULL, hDC)
    '-
    LOGSTRING(Time & " | INFO  | " & FontSelectComboID & " " & newFontSelectCombo -> Title & " created on " & ItemHandle -> ID & " " & ItemHandle -> Title & ".")

    Globals.ItemList.AddItem(newFontSelectCombo)

    return newFontSelectCombo
End Function

Function AddFontSelectCombo(byref ItemHandle as Item, byval FontName as String) as Integer
    If (ItemHandle = 0) orelse (ItemHandle -> ID <> FontSelectComboID) Then return -1

    Dim as Item_FontSelectCombo ptr FontComboItem = Cast(Item_FontSelectCombo ptr, ItemHandle)
    Dim as Integer expand, iWidth, iHeight, ListHeight
    Dim as RECT     wRECT, cRECT
    Dim as HDC      dDC = GetDC(NULL)
    Dim as HDC      fDC = CreateCompatibleDC(dDC)
    Dim as LOGFONT  lf
    Dim as HFONT    fnt
    Dim as SIZE     fSize
    Dim as String   SubItemID

    lf.lfFaceName = FontName
    fnt = CreateFontIndirect(@lf)

    SelectObject(fDC,fnt)
    GetTextExtentPoint32(fDC,FontName,len(FontName),@fSize)
    DeleteObject(fnt)
    DeleteDC(fDC)
    ReleaseDC(NULL,dDC)

    expand  = GetSystemMetrics(SM_CXVSCROLL)*1.25
    expand += GetSystemMetrics(SM_CXEDGE)*4

    iWidth  = fSize.CX + expand
    iHeight = IIF(fSize.CY>255,255,fSize.CY)

    If FontComboItem -> wSizeMode andalso iWidth  > FontComboItem -> iWidth  Then FontComboItem -> iWidth  = iWidth
    If FontComboItem -> hSizeMode andalso iHeight > FontComboItem -> iHeight Then FontComboItem -> iHeight = iHeight

    GetClientRect(GetParent(FontComboItem -> whwnd), @wRECT)
    GetClientRect(FontComboItem -> whwnd, @cRECT)
    ListHeight = (wRECT.bottom - wRECT.top)
    MapWindowPoints(ItemHandle -> whwnd, GetParent(ItemHandle -> whwnd), Cast(LPPOINT, @wRECT),2)
    ListHeight = ListHeight - (cRECT.bottom-cRECT.top)

    If ((FontComboItem -> iCount+3) * FontComboItem -> iHeight) < ListHeight Then ListHeight = ((FontComboItem -> iCount+3) * FontComboItem -> iHeight)

    FontComboItem -> iCount += 1

    SubItemID = FontName

    SendMessage(FontComboItem -> whwnd, CB_ADDSTRING, NULL, cast(LPARAM,strptr(SubItemID)))

    If SendMessage(FontComboItem -> whwnd, CB_GETCURSEL, NULL, NULL) = -1 Then SendMessage(FontComboItem -> whwnd, CB_SETCURSEL, Cast(WPARAM, 0), NULL)

    MapWindowPoints(FontComboItem -> whwnd, GetParent(FontComboItem -> whwnd), Cast(LPPOINT,@cRECT),2)
    MoveWindow(FontComboItem -> whwnd, cRECT.left, cRECT.top, FontComboItem -> iWidth, ListHeight, TRUE)
    SendMessage(FontComboItem -> whwnd, CB_SETITEMHEIGHT, -1, FontComboItem -> iHeight)
    SendMessage(FontComboItem -> whwnd, CB_SETITEMHEIGHT,  FontComboItem -> iCount - 1, iHeight)

    If FontComboItem -> iState = FALSE Then
        ShowWindow(FontComboItem -> whwnd, SW_SHOW)
        FontComboItem -> iState = TRUE
    End If
End Function