XProfan

#############################
Test-Programm für :
XProfan
#############################
Author : Andreas Miethe
Juli 2003
#############################
Thema : Menu-Manipulationen
#############################
 $H windows.ph
 $H structs.ph
 $H messages.ph
 $H shellapi.ph
 $H commctrl.ph
Def HiWord(1) Div&(&(1),$10000)
Def LoWord(1) And(&(1),$FFFF)
Struct Item = Text$(20),hIco&,hFont&,hTextColor&,hBackColor&
Struct lpmis = ~MEASUREITEMSTRUCT
Struct lpdis = ~DRAWITEMSTRUCT
Struct Size = ~Size
Struct Rect = ~Rect
Declare dwImageXY&,Imagewidth&,Imageheight&,WinBrush&,StatusWindow&
Declare lpMyItem#
Declare lpmis#,lpdis#
Declare lpMyitem&
Declare Size#
Declare ItemData&,IconFile$,Ico&
Declare Rect#
Declare Item1#,Item2#,Item3#
Dim Item1#,Item
Dim Item2#,Item
Dim Item3#,Item
Dim lpmis#,24lpmis
Dim lpMyItem#,Item
Dim Size#,Size
Dim lpdis#,lpdis
Dim Rect#,Rect
SetTrueColor 1
Declare ende%,hMenu&
Declare OldProc&

Proc DeleteObjects

    ~DeleteObject(Item1#.hIco&)
    ~DeleteObject(Item2#.hIco&)
    ~DeleteObject(Item3#.hIco&)
    ~DeleteObject(Item1#.hFont&)
    ~DeleteObject(Item2#.hFont&)
    ~DeleteObject(Item3#.hFont&)
    ~DeleteObject(WinBrush&)
    Dispose Item1#
    Dispose Item2#
    Dispose Item3#
    Dispose lpmis#
    Dispose lpMyItem#
    Dispose Size#
    Dispose lpdis#
    Dispose Rect#

EndProc

DEF &WM_MOUSEWHEEL $20A
Declare wheel&

proc windowProc

    Declare ItemIco&,Itemtext$,dwCheckXY&,wCheckX&,nTextX&,nTextY&
    Declare hOldFont&
    parameters Wnd&, Msg&, wParam&, lParam&

    If Msg& = &WM_MOUSEWHEEL

        Wheel& = wheel& + HiWord(wParam&)/120 * 4
        Settext wnd&,str$(wheel&)

    Endif

    If Msg& = ~WM_PAINT

        ~Invalidaterect(Wnd&,0,0)

    Endif

    If Msg& = ~WM_SIZE

        SetWindowPos StatusWindow& = 0,0-0,0

    Endif

    If Msg& = ~WM_MENUSELECT

        If LoWord(wParam&) = 1

            Settext StatusWindow&,Laden  -> lädt ein neues Dokoment

        ElseIf LoWord(wParam&) = 2

            Settext StatusWindow&,Speichern  -> speichert das aktuelle Dokument

        ElseIf LoWord(wParam&) = 3

            Settext StatusWindow&,Ende  -> beendet das Programm

        Else

            Settext StatusWindow&,

        Endif

    Endif

    If Msg& = ~WM_MEASUREITEM

        lpmis# = lParam&
        lpMyItem# = Long(lParam&,20)
        ItemText$ = lpMyItem#.Text$
        hOldFont& = ~SelectObject(%hdc,Long(lpMyItem#,sizeof(lpMyItem#)-4))
        ~GetTextExtentPoint32(%hdc,Addr(ItemText$),Len(ItemText$),Size#)
        Long lpmis#,12 = Size#.cx&
        Long lpmis#,16 = Size#.cy&
        ~SelectObject(%hdc,hOldFont&)
        Return 1

    Endif

    If Msg& = ~WM_DRAWITEM

        lpdis# = lParam&
        lpMyItem# = Long(lpdis#,44)
        dwCheckXY& = ~GetMenuCheckMarkDimensions()
        ImageWidth& = HiWord(dwCheckXY&)
        ImageHeight& = LoWord(dwCheckXY&)
        wCheckX& = HiWord(dwCheckXY&)+ 8
        ntextX& = wCheckX& + Long(lpdis#,28)
        ntextY& = Long(lpdis#,32)
        ItemText$ = lpMyItem#.Text$
        hOldFont& = ~SelectObject(lpdis#.hdc&,lpMyItem#.hFont&)

        If and(Long(lParam&,16),1)wenn selektiert

            ~SetTextColor(lpdis#.hdc&,~GetSysColor(~COLOR_HIGHLIGHTTEXT))original-Farbwert
            ~SetBkColor(lpdis#.hdc&,~GetSysColor(~COLOR_HIGHLIGHT))original-Farbwert
            ~SetTextColor(lpdis#.hdc&,lpMyItem#.hTextColor&)
            ~SetBkColor(lpdis#.hdc&,lpMyItem#.hBackColor&)

        EndIf

        Long Rect#,0 = Long(lpdis#,28) + wCheckX&
        Long Rect#,4 = Long(lpdis#,32)
        Long Rect#,8 = Long(lpdis#,36)
        Long Rect#,12 = Long(lpdis#,40)
        ~ExtTextOut(lpdis#.hdc&,nTextX&,nTextY&,~ETO_OPAQUE,Rect#,addr(Itemtext$),Len(Itemtext$),0)
        ~DrawIconEx(lpdis#.hdc&,Long(lpdis#,28)+2,Long(lpdis#,32),lpMyItem#.hIco&,ImageWidth&,ImageHeight&,0,~GetClassLong(hMenu&,~GCL_HBRBACKGROUND),3)
        ~SelectObject(lpdis#.hdc&,hOldFont&)
        Return 1

    Endif

    If Msg& = ~WM_CLOSE

        DeleteObjects
        Messagebox(und Tschüss,Ende,64)

    Endif

    alle Messages die nicht behandelt wurden an die Original-Prozedur weiterleiten
    return ~CallWindowProc(OldProc&,Wnd&, Msg&, WParam&, LParam&)

endproc

set(FastMode,1)
Windowstyle 31
window 0,0 -640,480
cls ~GetSysColor(~COLOR_BTNFACE)
WinBrush& = ~CreateSolidBrush(~GetSysColor(~COLOR_BTNFACE))
~SetClassLong(%hwnd,~GCL_HBRBACKGROUND,WinBrush&)
PopUp Datei
AppendMenu 1,
AppendMenu 2,
Separator
AppendMenu 3,
IconFile$ = Shell32.dll
MenuItems mit Werten bestücken
Item1#.Text$ = Laden  Menütext
~ExtractIconEx(ADDR(IconFile$),1,0,ADDR(ico&),1)
Item1#.hIco& = Ico&Menüicon
Item1#.hFont& = CreateFont(Roman,16,0,1,0,0)Menufont
Item1#.hTextColor& = RGB(255,255,255)Menütextfarbe
Item1#.hBackColor& = RGB(255,0,0)Menühintergrundfarbe
nächstes Item
Item2#.Text$ = Speichern
~ExtractIconEx(ADDR(IconFile$),20,0,ADDR(ico&),1)
Item2#.hIco& = Ico&
Item2#.hFont& = CreateFont(Roman,16,0,1,1,1)
Item2#.hTextColor& = RGB(255,255,255)
Item2#.hBackColor& = RGB(0,255,0)
nächstes Item
IconFile$ = Par$(0)aus der eigenen EXE
Item3#.Text$ = Ende
~ExtractIconEx(ADDR(IconFile$),0,0,ADDR(ico&),1)
Item3#.hIco& = Ico&
Item3#.hFont& = CreateFont(Roman,16,0,1,1,0)
Item3#.hTextColor& = RGB(255,255,255)
Item3#.hBackColor& = RGB(0,0,255)
Menü modifizieren
hMenu& = ~GetMenu(%hwnd)
~ModifyMenu(hMenu&,1,or(~MF_BYCOMMAND,~MF_OWNERDRAW),1,Item1#)
~ModifyMenu(hMenu&,2,or(~MF_BYCOMMAND,~MF_OWNERDRAW),2,Item2#)
~ModifyMenu(hMenu&,3,or(~MF_BYCOMMAND,~MF_OWNERDRAW),3,Item3#)
Window-Prozedur ersetzen, in OldProc wird die Adresse der Original-Prozedur gesichert
OldProc& = ~SetWindowLong(%hwnd,~GWL_WNDPROC, ProcAddr(windowProc,4))
Repaint
StatusWindow& = ~CreateStatusWindow($56000000,0,%hwnd,100)

whilenot ende%

    waitinput

    If MenuItem(1)

        Messagebox(MenüItem 1,Item,64)

    ElseIf MenuItem(2)

        Messagebox(MenüItem 2,Item,64)

    ElseIf MenuItem(3)

        SendMessage(%hwnd,~WM_CLOSE,0,0)

    Endif

Wend

end