XProfan

 $P*
USERMESSAGES 16
Declare lvdll&,exit%,liste&,freelist&,text$,lvfont&,idx%,idx2%,Kalender&,HeuteWT$,DateTimePick#,WahlDatum$,IstDatum$,X&
Def GSC(1) !USER32,GetSysColor
Def GetWindowLong(2) !USER32,GetWindowLongA
Def SetWindowLong(3) !USER32,SetWindowLongA
Def SetWinPos(7) !USER32,SetWindowPos
DEF DTP_GETSYSTEMTIME(2) SendMessage(&(1),4097,0,&(2))
Dim DateTimePick#,20
lvdll&=usedll($ProgDir+Listview.dll)
 $I ListView_Include.inc
Register(123456) Oder so ähnlich ;-)
lvfont&=Create(Font,Verdana,14,0,1,0,0)
 $I date.inc
##### Ermittelt den Wochentag zum Datum #####

Proc Wochentag

    Parameters datum$
    Declare tag$,monat$,jahr$
    tag$=substr$(datum$,1,.)
    monat$=substr$(datum$,2,.)
    jahr$=substr$(datum$,3,.)
    Return fdate(%l,mktime(0,0,0,monat$,tag$,jahr$))

EndProc

##### ListView #####

Proc Liste

    liste&=CreateListview(%hwnd,%hinstance,0,-1,-1,$400)
    InsertColumn liste&,,52,0
    InsertColumn liste&,HeuteWT$,200,0
    freelist&=SetLineHeight(liste&,22)
    DestroyImageList(freelist&)
    text$=$ProgDir+lvback.gif
    SetBackImage(liste&,addr(text$),1)

    WhileLoop 48

        SetItem liste&,,

    EndWhile

    SetFont liste&,lvfont&
    ShowListview(liste&,10,10,273,623)
    SelectLine(liste&,41,3) Scrollt runter bis 08:00 Uhr ganz oben ist.
    SelectLine(liste&,16,3) Selektiert 08:00
    InitMessages(%hwnd)

EndProc

##### Kalender #####

Proc Kal

    Kalender&=Control(SysMonthCal32,,$54000004,290,10,180,620,%hwnd,2000,%hinstance)
    SetWindowLong(Kalender&,-20,Or(GetWindowLong(Kalender&,-20),512))
    SetWinPos(Kalender&,0,0,0,0,0,$023)
    SetFont Kalender&,lvfont&
    SendMessage(Kalender&,$100A,4,rgb(255,255,210))
    SendMessage(Kalender&,$100A,5,rgb(125,125,125))

Endproc

##### Fügt ggf. eine Null vor dem Tag oder Monat #####

Proc NullZumDatum

    Parameters Datum$
    Declare Tag$,Monat$,Jahr$,NeuDatum$
    Tag$=substr$(datum$,1,.)
    Monat$=substr$(datum$,2,.)
    Jahr$=substr$(datum$,3,.)
    Case Len(Tag$)=1:Tag$=0+Tag$
    Case Len(Monat$)=1:Monat$=0+Monat$
    NeuDatum$=Tag$+.+Monat$+.+Jahr$
    Return NeuDatum$

EndProc

##### Wählt das Datum, und setzt es als Spaltenüberschrift

Proc WahlDatum

    Declare Datum#,Colum$
    Wochentag IstDatum$
    Colum$=$(0)+, +IstDatum$
    Dim Datum#,256
    String Datum#,0=Colum$
    SetColumnName(liste&,Datum#,1)
    Dispose Datum#

EndProc

##### Hauptfenster #####

Proc Hauptfenster

    SetTrueColor 1
    WindowStyle 26
    WindowTitle ListView-Terminkalender
    Window ((%maxX/2)-242),((%maxY/2)-335)-485,670
    CLS GSC(15)

EndProc

##### Hauptprogramm #####
Hauptfenster
Wochentag Date$(0)
HeuteWT$=$(0)
Liste
Kal
##### Hauptprogrammschleife #####
DTP_GETSYSTEMTIME(Kalender&,DateTimePick#)
IstDatum$=Str$(word(DateTimePick#,6));.;Str$(word(DateTimePick#,2));.;Str$(word(DateTimePick#,0))
NullZumDatum IstDatum$
IstDatum$=$(0)

WhileNot exit%

    GetMessage
    Case %Umessage=16:exit%=1
    DTP_GETSYSTEMTIME(Kalender&,DateTimePick#)
    WahlDatum$=Str$(word(DateTimePick#,6));.;Str$(word(DateTimePick#,2));.;Str$(word(DateTimePick#,0))
    NullZumDatum WahlDatum$
    WahlDatum$=$(0)

    ifnot WahlDatum$=IstDatum$

        IstDatum$=WahlDatum$
        WahlDatum

    endif

Wend

CloseMessages(%hwnd)
8800"> $I ListView_Dispose.inc
Dispose DateTimePick#