XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Text: Ein Static mit Text färben
PRFellow-Vorlage
Autor: Thomas Hölzer
Ein Control färben, bisher bedingt geeignet für CreateText (Static),
noch bedingter für einzeiliges Edit(Flackern bei der Texteingabe)
Def GetDC(1) !USER32,GetDC
Def ReleaseDC(2) !USER32,ReleaseDC
Def FillRect(3) !USER32,FillRect
Def GetSysColor(1) !USER32,GetSysColor
Def CreateSolidBrush(1) !GDI32,CreateSolidBrush
Def w32_DeleteObject(1) !GDI32,DeleteObject
Def w32_DrawText(5) !USER32,DrawTextA
Def SetTextColor(2) !GDI32,SetTextColor
Def SetBkColor(2) !GDI32,SetBkColor
Def SetBkMode(2) !GDI32,SetBkMode
Def GetClassName(3) !USER32,GetClassNameA
Def SelectObject(2) !GDI32,SelectObject
Def UpdateColors(1) !GDI32,UpdateColors
Declare crect#,ctxt#
Declare cname#

Proc PaintControl

    Parameters h&,bc&,tc&
    Declare dc&,brush&,t$
    Dim cname#,16
    GetClassName(h&,cname#,16)

    If Equ$(Trim$(String$(cname#,0)),Edit)

        Let bc&=GetSysColor(5)

    EndIf

    Dispose cname#
    Dim crect#,16
    Long crect#,0=0
    Long crect#,4=0
    Long crect#,8=Width(h&)
    Long crect#,12=Height(h&)
    Let t$=GetText$(h&)
    Dim ctxt#,Add(Len(t$),1)
    String ctxt#,0=t$
    Let dc&=GetDC(h&)
    SelectObject(dc&,SendMessage(h&,$31,0,0))
    Let brush&=CreateSolidBrush(bc&)
    SelectObject(dc&,brush&)
    SetBKColor(dc&,bc&)
    SetBKMode(dc&,1)
    SetTextColor(dc&,tc&)
    UpdateColors(dc&)
    FillRect(dc&,crect#,brush&)
    w32_DrawText(dc&,ctxt#,Len(t$),crect#,0)
    Dispose crect#
    Dispose ctxt#
    w32_DeleteObject(brush&)
    ReleaseDC(h&,dc&)

EndProc

Beispiel
Declare hText&,htext2&
SetTrueColor 1
Cls GetSyscolor(4)
UseFont ,15,0,0,0,0
SetDialogFont 1
Let htext&=CreateEdit(%hwnd,Borussia Dortmund,10,10,200,20)
Let htext2&=CreateText(%hwnd,Das ist ein Static,10,50,200,20)
Hauptprogrammschleife

While 1

    PaintControl htext&,$00FFFF,0
    PaintControl htext2&,RGB(255,0,0),RGB(0,0,255)
    WaitInput

Wend

'Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
'Text: Ein Static mit Text färben
'PRFellow-Vorlage
'Autor: Thomas Hölzer
'Ein Control färben, bisher bedingt geeignet für CreateText (Static),
'noch bedingter für einzeiliges Edit(Flackern bei der Texteingabe)
 $I Profalt.inc
Def GetDC(1) "USER32","GetDC"
Def ReleaseDC(2) "USER32","ReleaseDC"
Def FillRect(3) "USER32","FillRect"
Def GetSysColor(1) "USER32","GetSysColor"
Def CreateSolidBrush(1) "GDI32","CreateSolidBrush"
Def w32_DeleteObject(1) "GDI32","DeleteObject"
Def w32_DrawText(5) "USER32","DrawTextA"
Def SetTextColor(2) "GDI32","SetTextColor"
Def SetBkColor(2) "GDI32","SetBkColor"
Def SetBkMode(2) "GDI32","SetBkMode"
Def GetClassName(3) "USER32","GetClassNameA"
Def SelectObject(2) "GDI32","SelectObject"
Def UpdateColors(1) "GDI32","UpdateColors"
Declare crect#,ctxt#
Declare cname#

Proc PaintControl

    Parameters h&,bc&,tc&
    Declare dc&,brush&,t$
    Dim cname#,16
    GetClassName(h&,cname#,16)

    If Equ$(Trim$(String$(cname#,0)),"Edit")

        Let bc&=GetSysColor(5)

    EndIf

    Dispose cname#
    Dim crect#,16
    Long crect#,0=0
    Long crect#,4=0
    Long crect#,8=Width(h&)
    Long crect#,12=Height(h&)
    Let t$=GetText$(h&)
    Dim ctxt#,Add(Len(t$),1)
    String ctxt#,0=t$
    Let dc&=GetDC(h&)
    SelectObject(dc&,SendMessage(h&,$31,0,0))
    Let brush&=CreateSolidBrush(bc&)
    SelectObject(dc&,brush&)
    SetBKColor(dc&,bc&)
    SetBKMode(dc&,1)
    SetTextColor(dc&,tc&)
    UpdateColors(dc&)
    FillRect(dc&,crect#,brush&)
    w32_DrawText(dc&,ctxt#,Len(t$),crect#,0)
    Dispose crect#
    Dispose ctxt#
    w32_DeleteObject(brush&)
    ReleaseDC(h&,dc&)

EndProc

'Beispiel
Declare hText&,htext2&
SetTrueColor 1
Cls GetSyscolor(4)
UseFont "Western",15,0,0,0,0
SetDialogFont 1
Let htext&=CreateEdit(%hwnd,"Borussia Dortmund",10,10,200,20)
Let htext2&=CreateText(%hwnd,"Das ist ein Static",10,50,200,20)
'Hauptprogrammschleife

While 1

    PaintControl htext&,$0000FF,0
    PaintControl htext2&,RGB(255,0,0),RGB(0,0,255)
    WaitInput

Wend