XProfan

Italia

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Text: 3D-Textausgabe mit erweiterten Fontmöglichkeiten
PRFellow-Vorlage
Autor: Thomas Hölzer
Zeichnet einfachen 3D-Text und nutzt erweiterte Fontmöglichkeiten
Def CreateFontIndirect(1) !GDI32,CreateFontIndirectA
Def DeleteObject(1) !GDI32,DeleteObject
Def SelectObject(2) !GDI32,SelectObject
Def GetSysColor(1) !USER32,GetSysColor
Declare LF#,font&

Proc CreateFont

    Parameters facename$,height%,width%,bold%,italic%,ul%,strikeout%
    Case bold%: Let bold%=700
    Dim LF#,60
    Long LF#,0=height%
    Long LF#,4=width%
    Long LF#,8=0
    Long LF#,12=0
    Long LF#,16=bold%
    Byte LF#,20=italic%
    Byte LF#,21=ul%
    Byte LF#,22=strikeout%
    Byte LF#,23=1
    Byte LF#,24=0
    Byte LF#,25=0
    Byte LF#,26=0
    Byte LF#,27=2
    String LF#,28=Add$(facename$,Chr$(0))
    Let font&=CreateFontIndirect(LF#)
    Dispose LF#
    Return font&

EndProc

Proc Draw3DText

    Parameters x%,y%,factor%,text$
    Declare x1%,x2%,y1%,y2%
    Let x1%=Add(x%,factor%)
    Let y1%=Add(y%,factor%)
    Let x2%=Add(x1%,factor%)
    Let y2%=Add(y1%,factor%)
    TextColor GetSysColor(14),-1
    DrawText x%,y%,text$
    TextColor GetSysColor(16),-1
    DrawText x2%,y2%,text$
    TextColor GetSysColor(15),-1
    DrawText x1%,y1%,text$

EndProc

SetTrueColor 1
Cls GetSysColor(15)
CreateFont Times New Roman,70,0,0,1,0,0
Let font&=&(0)
SelectObject(%hdc,font&)
SelectObject(%hdc2,font&)
Draw3DText 20,90,1,PRFellow sticht hervor
Draw3DText 20,250,-1,... und prägt sich ein
WaitInput
Delet