'#############################
'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#,24'lpmis
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