XProfan

 $H windows.ph
Declare Hicon&,Ende%,Show%
Declare Checkmerker%,Menuhandle&
Declare hbmChecked&,hbmUnchecked&
DEF SetMenuItemBitmaps(5) !USER32,SetMenuItemBitmaps

Proc Ico2SizedBmp

    Parameters Icon&, dx&, dy&
    Weiße temporäre Bitmap in Größe 32 * 32 erzeugen
    Var TempBmp& = Create(hNewPic, 32, 32, RGB(255,255,255))
    Auf diese Bitmap das Icon zeichnen
    StartPaint TempBmp&
    DrawIcon Icon&, 0, 0
    EndPaint
    Weiße Bitmap in Größe dx& * dy& erzeugen
    Var IBmp& = Create(hNewPic, dx&, dy&, RGB(255,255,255))
    Auf diese Bitmap die temporäre Bitmap verkleinert zeichnen
    StartPaint IBmp&
    DrawSizedPic TempBmp&, 0, 0 - dx&, dy&; 0
    EndPaint
    DeleteObject TempBmp&
    Return IBmp&

EndProc

Proc Menue

    CreateMenu
    AppendMenu 101, &Info
    SubPopup Test
    SetMenuItemBitmaps(&hMenu,1,$400,hbmChecked&,hbmUnChecked&)Menu-Grafik ändern...
    ##### NEU ####
    SubPopup Test1 SubPopUp in SubPopUp
    SetMenuItemBitmaps(~GetSubMenu(&hMenu,1),0,$400,hbmChecked&,hbmUnChecked&)Menu-Grafik ändern...
    AppendMenu 202, &test1
    Endsub
    ##########
    AppendMenu 202, &test2
    Endsub
    AppendMenu 102, &deaktiviert
    SetMenuItemBitmaps(&hMenu,102,$10,hbmChecked&,hbmUnChecked&)Menu-Grafik ändern...
    AppendMenu 106, Hauptfenster &sichtbar
    SetMenuItemBitmaps(&hMenu,106,$10,hbmChecked&,hbmUnChecked&)Menu-Grafik ändern...
    AppendMenu 104, -
    AppendMenu 103, &Beenden
    CheckMenu 106, Show%
    CheckMenu 102, Checkmerker%
    Return @TrackMenu()

EndProc

Windowstyle 26 + 512
WindowTitle TrayIcon_Test
Window 0,0-640,480
@ShowWindow(%hWnd,0)
Hicon&        = @create(hIcon,Profan)
hbmChecked&   = Ico2SizedBmp(@create(hIcon, A),13,13)
hbmUnChecked& = Ico2SizedBmp(@create(hIcon, Baum),13,13)
@TrayIcon(Add, %hWnd, 1, hIcon&, TrayIcon 11)

Whilenot Ende%

    Waitinput

    If @TrayIcon(Msg, 1) = $203Doppelklick links

        Ende%=1

    Elseif @TrayIcon(Msg, 1) = $204Rechter Mausbutton gedrückt

        @SetActiveWindow(%hWnd)
        Menue()

        If (%MenuItem = 102)

            Checkmerker% = @Not(Checkmerker%)Zustandsänderung merken...

            If Checkmerker% = 0

                Hicon& = @create(hIcon, A)
                @TrayIcon(SetIcon, %hWnd, 1, hIcon&)

            Else

                Hicon& = @create(hIcon, Baum)
                @TrayIcon(SetIcon, %hWnd, 1, hIcon&)

            EndIf

            Setmenuitem 0

        ElseIf (%MenuItem = 101)

            @Messagebox(Programmiert in XProfan 11,Hinweis,64)
            Setmenuitem 0

        ElseIf (%MenuItem = 103)

            Ende%=1

        ElseIf (%MenuItem = 106)

            Show% = @Not(Show%)
            @Showwindow(%hWnd,Show%)
            Setmenuitem 0

        EndIf

    Endif

Endwhile

@TrayIcon(Delete, %hWnd, 1)
End

Header-Dateien
 $H windows.ph
 $H messages.ph
Strukturen
Struct SIZE = cx&,cy&
Struct RECT = Left&,Top&,Right&,Bottom&
Struct MEASUREITEMSTRUCT  = CtlType&,CtlID&,itemID&,itemWidth&,itemHeight&,itemData&
Struct DRAWITEMSTRUCT = CtlType&,CtlID&,itemID&,itemAction&,itemState&,hwndItem&,hDC&,rcItem!RECT,itemData&
Declare Ende&,Brush&,MenuPic&,PicWidth&,PicHeight&
Declare Rect1#,hIcon1&,lpmis#,Size#
Declare ReadItem#,lpdis#,ItemInfo#
Dim lpmis#,MEASUREITEMSTRUCT
Dim lpdis#,DRAWITEMSTRUCT
Dim Size#,SIZE
Dim Rect1#,RECT
Var i& = Importdll(Msimg32.dll,)
Menu-Bildbreite festlegen ( Farbverlauf )
PicWidth& = 20
Declare MyItem#[5]reicht für 3 Menü-Einträge
Die Struktur nimmt die Zeiger für den Text und das Icon auf
Struct Item = Eintrag&,Icon&
Dim MyItem#[],Item
Dim ReadItem#,Item  wird benötigt um die Informationen auszulesen
Strukturen füllen
Var Text$ = Info
Var Text2$ = Beenden
Var TextSep$ = -
Var Sub$ = Schriftschnitte
Var f$ = fett
Var k$ = kursiv
MyItem#[0].Eintrag& = Addr(Text$)
MyItem#[1].Eintrag& = Addr(Text2$)
MyItem#[0].Icon&    = ~LoadIcon(%hInstance,A)
MyItem#[1].Icon&    = ~LoadIcon(%hInstance,Eimer)
MyItem#[2].Eintrag& = Addr(TextSep$)
MyItem#[2].Icon&    = 0
MyItem#[3].Eintrag& = Addr(Sub$)
MyItem#[3].Icon&    = ~LoadIcon(%hInstance,Drucker)
MyItem#[4].Eintrag& = Addr(f$)
MyItem#[4].Icon&    = ~LoadIcon(%hInstance,Eis)
MyItem#[5].Eintrag& = Addr(k$)
MyItem#[5].Icon&    = ~LoadIcon(%hInstance,Gesicht)

Proc Menue

    Ownerdraw-Menü anlegen und anzeigen
    CreateMenu
    AppendMenu 101, Info0
    ~ModifyMenu(&hMenu,101,~MF_BYCOMMAND | ~MF_OWNERDRAW,101,MyItem#[0])
    AppendMenu 102, -1
    ~ModifyMenu(&hMenu,102,~MF_BYCOMMAND | ~MF_OWNERDRAW,102,MyItem#[2])
    SubPopUp Schriftschnitte 2  ModifyMenu muss per position und  nicht per Command bestimmt werden
    Das Zählen fängt bei Null an
    ~ModifyMenu(&hMenu,2,~MF_BYPOSITION | ~MF_OWNERDRAW,2,MyItem#[3])
    AppendMenu 214,fett
    AppendMenu 215,kursiv
    ~ModifyMenu(&hMenu,214,~MF_BYCOMMAND | ~MF_OWNERDRAW,214,MyItem#[4])
    ~ModifyMenu(&hMenu,215,~MF_BYCOMMAND | ~MF_OWNERDRAW,215,MyItem#[5])
    EndSub
    AppendMenu 103, Beenden
    ~ModifyMenu(&hMenu,103,~MF_BYCOMMAND | ~MF_OWNERDRAW,103,MyItem#[1])
    Return @TrackMenu()

EndProc

Windowstyle 26 + 512
WindowTitle Test
Window 0,0-640,480
GradientRect(%hdc2,0,0,Width(%hwnd),Height(%hwnd),$FFFFFF,$FFC1C1,0)
Repaint
SubClass %HWnd, 1

Whilenot Ende&

    Waitinput

    If %MousePressed = 2Rechter Mausbutton gedrückt

        Menue()

        If (%MenuItem = 101)

            @Messagebox(Programmiert in XProfan 11,Hinweis,64)

        ElseIf (%MenuItem = 103)

            Ende&=1

        EndIf

    Endif

Endwhile

Dispose lpmis#,Size#,lpdis#,Rect1#
End

SubClassProc

    If SubClassMessage(%hWnd,~WM_MEASUREITEM)

        lpmis# = &slParam
        ReadItem# = lpmis#.itemData&
        Texbreite für Item ermitteln, muss übergeben werden !!
        ~GetTextExtentPoint32(%hdc,ReadItem#.Eintrag&,Len(String$(ReadItem#.Eintrag&,0)),Size#)
        lpmis#.itemWidth&  = Size#.cx& + PicWidth&

        If String$(ReadItem#.Eintrag&,0) = -Separator behandeln

            lpmis#.itemHeight& = -2

        Endif

        lpmis#.itemHeight& = lpmis#.itemHeight& + 6
        PicHeight& = PicHeight& + lpmis#.itemHeight&
        Set(WinProc, 0)

    ElseIf SubClassMessage(%hWnd,~WM_DRAWITEM)

        lpdis# = &slParam

        If lpdis#.CtlType& = ~ODT_MENU	nur wenn Menu

            ReadItem# = lpdis#.itemData&

            If String$(ReadItem#.Eintrag&,0) <> -fass kein Separator

                IF lpdis#.itemState& & ~ODS_SELECTED	wenn selektiert

                    ~SetTextColor(lpdis#.hDC&,$FFFFFF)
                    ~SetBkColor(lpdis#.hDC&,$FFC1C1)
                    Else wenn nicht selektiert
                    ~SetTextColor(lpdis#.hDC&,0)
                    ~SetBkColor(lpdis#.hDC&,$FFFFFF)

                EndIf

            Endif

            Ausgabe

            If String$(ReadItem#.Eintrag&,0) <> -  falls kein Separator

                lpdis#.rcItem!Left& = lpdis#.rcItem!Left& + PicWidth&
                ~ExtTextOut(lpdis#.hDC&,lpdis#.rcItem!Left&+10,lpdis#.rcItem!Top&+4,~ETO_OPAQUE,lpdis#.rcItem,ReadItem#.Eintrag&,Len(String$(ReadItem#.Eintrag&,0)) ,0)
                GradientRect(lpdis#.hDC&,0,lpdis#.rcItem!Top&,PicWidth&,lpdis#.rcItem!Bottom&,$FFFFFF,$FFC1C1,0)
                ~DrawIconEx(lpdis#.hDC&,2,lpdis#.rcItem!Top&+4,ReadItem#.Icon&,13,13,0,0,~DI_NORMAL)
                Else falls Separator
                GradientRect(lpdis#.hDC&,0,lpdis#.rcItem!Top&,PicWidth&,lpdis#.rcItem!Bottom&,$FFFFFF,$FFC1C1,0)
                ~Rectangle(lpdis#.hDC&,0,lpdis#.rcItem!Top&+1,lpdis#.rcItem!Right&,lpdis#.rcItem!Bottom&-2)

            Endif

            Set(WinProc, 0)

        Endif

    EndIf

EndProc

Proc GradientRect

    Parameters DC&,x%,y%,w%,h%,Color1&,Color2&,HV&
    Declare GradRect#,Trivertex#
    Dim GradRect#,8
    Dim Trivertex#,32
    Long Gradrect#,0 = 0
    Long Gradrect#,4 = 1
    Long Trivertex#,0=x%
    Long Trivertex#,4=y%
    word Trivertex#,8=GETRVALUE(Color1&) << 8
    word Trivertex#,10=GETGVALUE(Color1&) << 8
    word Trivertex#,12=GETBVALUE(Color1&) << 8
    word Trivertex#,14=0
    Long Trivertex#,16=w%
    Long Trivertex#,20=h%
    word Trivertex#,24=GETRVALUE(Color2&) << 8
    word Trivertex#,26=GETGVALUE(Color2&) << 8
    word Trivertex#,28=GETBVALUE(Color2&) << 8
    word Trivertex#,30=0
    GradientFill(DC&,Trivertex#,2,Gradrect#,1,HV&)
    Dispose Trivertex#
    Dispose Gradrect#

EndProc