vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
sevAniGif - als kostenlose Vollversion auf unserer vb@rchiv CD Vol.5  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2015
 
zurück
Rubrik: Oberfläche · Menüs   |   VB-Versionen: VB607.02.05
Menüs á la MS-Office verwenden

Dieser Code verzaubert das Standard Menü Ihrer Anwendung in ein modernes Office-Menü, so wie es bspw. MS-Office XP verwendet.

Autor:   Martin WalcherBewertung:     [ Jetzt bewerten ]Views:  13.614 
www.martinwalcher.deSystem:  WinNT, Win2k, WinXP, Vista, Win7, Win8 Beispielprojekt auf CD 

Summer-Special bei Tools & Components!
Gute Laune Sommer bei Tools & Components
Top Summer-Special - Sparen Sie teilweise über 100,- EUR
Alle sev-Entwicklerkomponenten und Komplettpakete jetzt bis zu 25% reduziert!
zum Beispiel:
  • Developer CD nur 455,- EUR statt 569,- EUR
  • sevDTA 2.0 nur 224,30 EUR statt 299,- EUR
  •  
  • vb@rchiv   Vol.6 nur 18,70 EUR statt 24,95 EUR
  • sevCoolbar 3.0 nur 58,70 EUR statt 69,- EUR
  • - Werbung -Und viele weitere Angebote           Aktionspreise nur für kurze Zeit gültig

    Mit folgenden Code wird das Menü verwendet, dass z. B. in OfficeXP zur anwendung kommt.

    Auf der linken Menüseite können zusätzlich noch Icons mit einer Auflösung von 16 x 16 Pixeln angezeigt werden. Ist deren Hintergrund Magenta (= &HFF00FF), so wird dieser transparent.

    ACHTUNG: Die Prozedur verwendet Subclassing! Bei Programmfehlern kann die ganze IDE abschmiern!!! Außerdem sollte das Subclassing vor dem Beenden deaktiviert und die Form mit Unload entladen werden!

    Menü im modernen OfficeXP-Look
    Abb.: Menü im modernen OfficeXP-Look

    Folgender Code muss in die Form eingefügt werden, deren Menüs im Office-Look angezeigt werden soll:

    Private Sub Form_Load()
      ' OfficeMenü verwenden
      SetProc Me.hwnd
      MakeMenuOfficeStyle Me.hwnd
     
      ' Icon zu Menü-Eintrag hinzufügen
      ' > MenunID = Fortlaufende Nummer des Menüeintrags
      ' > Unchecked = Handle des Menü-Icons (hdc)
      ' > Checked = Icon wenn Menü-Eintrag ausgewählt
      SetMenuItemPicture 2, Picture1(0).hdc
      SetMenuItemPicture 5, Picture1(1).hdc
      SetMenuItemPicture 6, Picture1(2).hdc
      SetMenuItemPicture 11, Picture1(3).hdc
    End Sub
    Private Sub mMenu_Click(Index As Integer)
      ' Beenden
      If Index = 5 Then
        Unload Me
      End If  
    End Sub
    Private Sub Form_Unload(Cancel As Integer)
      ' Subclassing korrekt beenden
      DelProc Me.hwnd
    End Sub

    Die darzustellenden Symbole befinden sich in obigem Beispiel in einem PictureBox-Controlarray.

    Der restliche Code kommt in ein Modul:

    Option Explicit
     
    ' Code by Martin Walcher
    ' info@martinwalcher.de
    ' http://www.martinwalcher.de/
     
    Private Declare Function SetWindowLong Lib "user32.dll" _
      Alias "SetWindowLongA" ( _
      ByVal hwnd As Long, _
      ByVal nIndex As Long, _
      ByVal dwNewLong As Long) As Long
     
    Private Declare Function CallWindowProc Lib "user32.dll" _
      Alias "CallWindowProcA" ( _
      ByVal lpPrevWndFunc As Long, _
      ByVal hwnd As Long, _
      ByVal msg As Long, _
      ByVal wParam As Long, _
      ByVal lParam As Long) As Long
     
    Private Declare Function SetPixel Lib "gdi32.dll" ( _
      ByVal hdc As Long, _
      ByVal x As Long, _
      ByVal y As Long, _
      ByVal crColor As Long) As Long
     
    Private Declare Function GetSysColor Lib "user32.dll" ( _
      ByVal nIndex As Long) As Long
     
    Private Declare Function CreatePen Lib "gdi32.dll" ( _
      ByVal nPenStyle As Long, _
      ByVal nWidth As Long, _
      ByVal crColor As Long) As Long
     
    Private Declare Function CreateSolidBrush Lib "gdi32.dll" ( _
      ByVal crColor As Long) As Long
     
    Private Declare Function Rectangle Lib "gdi32.dll" ( _
      ByVal hdc As Long, _
      ByVal X1 As Long, _
      ByVal Y1 As Long, _
      ByVal X2 As Long, _
      ByVal Y2 As Long) As Long
     
    Private Declare Function SelectObject Lib "gdi32.dll" ( _
      ByVal hdc As Long, _
      ByVal hObject As Long) As Long
     
    Private Declare Function DeleteObject Lib "gdi32.dll" ( _
      ByVal hObject As Long) As Long
     
    Private Declare Function SetTextColor Lib "gdi32.dll" ( _
      ByVal hdc As Long, _
      ByVal crColor As Long) As Long
     
    Private Declare Function TextOut Lib "gdi32.dll" _
      Alias "TextOutA" ( _
      ByVal hdc As Long, _
      ByVal x As Long, _
      ByVal y As Long, _
      ByVal lpString As String, _
      ByVal nCount As Long) As Long
     
    Private Declare Function SetBkMode Lib "gdi32.dll" ( _
      ByVal hdc As Long, _
      ByVal nBkMode As Long) As Long
     
    Private Declare Function GetMenu Lib "user32.dll" ( _
      ByVal hwnd As Long) As Long
     
    Private Declare Function GetSubMenu Lib "user32.dll" ( _
      ByVal hMenu As Long, _
      ByVal nPos As Long) As Long
     
    Private Declare Function GetMenuString Lib "user32.dll" _
      Alias "GetMenuStringA" ( _
      ByVal hMenu As Long, _
      ByVal wIDItem As Long, _
      ByVal lpString As String, _
      ByVal nMaxCount As Long, _
      ByVal wFlag As Long) As Long
     
    Private Declare Function LineTo Lib "gdi32.dll" ( _
      ByVal hdc As Long, _
      ByVal x As Long, _
      ByVal y As Long) As Long
     
    Private Declare Function GetMenuState Lib "user32.dll" ( _
      ByVal hMenu As Long, _
      ByVal wID As Long, _
      ByVal wFlags As Long) As Long
     
    Private Declare Function ModifyMenu Lib "user32.dll" _
      Alias "ModifyMenuA" ( _
      ByVal hMenu As Long, _
      ByVal nPosition As Long, _
      ByVal wFlags As Long, _
      ByVal wIDNewItem As Long, _
      ByVal lpString As Any) As Long
     
    Private Declare Function GetMenuItemID Lib "user32.dll" ( _
      ByVal hMenu As Long, _
      ByVal nPos As Long) As Long
     
    Private Declare Function SetMenuItemBitmaps Lib "user32.dll" ( _
      ByVal hMenu As Long, _
      ByVal nPosition As Long, _
      ByVal wFlags As Long, _
      ByVal hBitmapUnchecked As Long, _
      ByVal hBitmapChecked As Long) As Long
     
    Private Declare Function GetMenuItemCount Lib "user32.dll" ( _
      ByVal hMenu As Long) As Long
     
    Private Declare Function GetMenuItemInfo Lib "user32.dll" _
      Alias "GetMenuItemInfoA" ( _
      ByVal hMenu As Long, _
      ByVal un As Long, _
      ByVal b As Boolean, _
      ByRef lpMenuItemInfo As MENUITEMINFO) As Long
     
    Private Declare Function TransparentBlt Lib "msimg32.dll" ( _
      ByVal hdc As Long, _
      ByVal x As Long, _
      ByVal y As Long, _
      ByVal nWidth As Long, _
      ByVal nHeight As Long, _
      ByVal hSrcDC As Long, _
      ByVal xSrc As Long, _
      ByVal ySrc As Long, _
      ByVal nSrcWidth As Long, _
      ByVal nSrcHeight As Long, _
      ByVal crTransparent As Long) As Long
     
    Private Declare Sub CopyMemory Lib "kernel32.dll" _
      Alias "RtlMoveMemory" ( _
      ByRef Destination As Any, _
      ByRef Source As Any, _
      ByVal Length As Long)
     
    Private Type RECT
      Left As Long
      Top As Long
      Right As Long
      Bottom As Long
    End Type
     
    Private Type MEASUREITEMSTRUCT
      CtlType As Long
      CtlID As Long
      itemID As Long
      itemWidth As Long
      itemHeight As Long
      itemData As Long
    End Type
     
    Private Type DRAWITEMSTRUCT
      CtlType As Long
      CtlID As Long
      itemID As Long
      itemAction As Long
      itemState As Long
      hwndItem As Long
      hdc As Long
      rcItem As RECT
      itemData As Long
    End Type
     
    Private Type MENUITEMINFO
      cbSize As Long
      fMask As Long
      fType As Long
      fState As Long
      wID As Long
      hSubMenu As Long
      hbmpChecked As Long
      hbmpUnchecked As Long
      dwItemData As Long
      dwTypeData As String
      cch As Long
    End Type
     
    Private Const GWL_WNDPROC As Long = -4
    Private Const WM_MEASUREITEM As Long = &H2C
    Private Const WM_DRAWITEM As Long = &H2B
    Private Const COLOR_BACKGROUND As Long = 1
    Private Const COLOR_MENU As Long = 4
    Private Const COLOR_MENUTEXT As Long = 7
    Private Const PS_SOLID As Long = 0
    Private Const TRANSPARENT As Long = 1
    Private Const MF_SEPARATOR As Long = &H800&
    Private Const MF_BYPOSITION As Long = &H400&
    Private Const MF_OWNERDRAW As Long = &H100&
    Private Const MIIM_CHECKMARKS As Long = &H8
    Private Const MIIM_STATE As Long = &H1
    Private Const MF_CHECKED As Long = &H8&
     
    Dim oldProc As Long
    Dim menuhandle As Long
    Sub DelProc(ByVal hwnd As Long)
      SetWindowLong hwnd, GWL_WNDPROC, oldProc
    End Sub
    Public Function MakeMenuOfficeStyle(ByVal hwnd As Long) As Boolean
      Dim xm As Long, m As Long, i As Long
     
      xm = GetMenu(hwnd)
      menuhandle = xm
     
      For i = 0 To GetMenuItemCount(xm)
        m = GetSubMenu(xm, i)
        If m > 0 Then StyleSubMenu m
      Next i
    End Function
    Private Function StyleSubMenu(ByVal xm As Long)
      Dim m As Long, i As Long
     
      For i = 0 To GetMenuItemCount(xm)
        m = GetMenuItemID(xm, i)
        If m = -1 Then
          m = GetSubMenu(xm, i)
          If m > 0 Then StyleSubMenu m
        End If
        If m > 0 Then 
          ModifyMenu xm, m, GetMenuState(xm, m, 0) _
            Or MF_OWNERDRAW, m, GetMenuText(xm, m)
        End If
      Next i
    End Function
    Private Function GetMenuText(ByVal m As Long, _
      ByVal id As Long, _
      Optional ByVal flags As Long = 0) As String
     
      GetMenuText = Space(64)
      GetMenuString m, id, GetMenuText, Len(GetMenuText), flags
      GetMenuText = Left(GetMenuText, InStr(GetMenuText & Chr(0), Chr(0)) - 1)
    End Function
    Private Function GetMenuBitmap(ByVal MenuID As Long) As Long
      On Error Resume Next
      Dim itemchecked As Boolean, mi As MENUITEMINFO, lngTmp As Long
     
      mi.cbSize = Len(mi)
      mi.fMask = MIIM_STATE
      GetMenuItemInfo menuhandle, MenuID, False, mi
      itemchecked = ((mi.fState And MF_CHECKED) = MF_CHECKED)
     
      mi.fMask = MIIM_CHECKMARKS
      GetMenuItemInfo menuhandle, MenuID, False, mi
      If itemchecked Then 
        GetMenuBitmap = mi.hbmpChecked
      Else
        GetMenuBitmap = mi.hbmpUnchecked
      End If
    End Function
    Sub SetProc(ByVal hwnd As Long)
      oldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewProc)
    End Sub
    Private Function NewProc(ByVal hwnd As Long, _
      ByVal msg As Long, _
      ByVal wParam As Long, _
      ByVal lParam As Long) As Long
     
      Dim mis As MEASUREITEMSTRUCT, dis As DRAWITEMSTRUCT
      Dim r As RECT, s As String, x As Long, y As Long
      Dim c As Long, rc As Long, gc As Long, bc As Long
     
      Select Case msg
        Case WM_MEASUREITEM
          CopyMemory mis, ByVal lParam, Len(mis)
          If mis.itemID > 0 Then 
            mis.itemWidth = 173
            If (GetMenuState(GetMenu(hwnd), mis.itemID, 0) _
              And MF_SEPARATOR) = MF_SEPARATOR Then 
              mis.itemHeight = 3 
            Else 
              mis.itemHeight = 24
            End If
            CopyMemory ByVal lParam, mis, Len(mis)
          End If
     
        Case WM_DRAWITEM
          CopyMemory dis, ByVal lParam, Len(dis)
          If dis.itemID >0 Then
            s = Space(64)
            GetMenuString GetMenu(hwnd), dis.itemID, s, Len(s), 0
            s = Left(s, InStr(s & Chr(0), Chr(0)) - 1)
            If Not s = "" Then s = Split(s, vbTab, 2)(0)
            s = Replace(s, "&", "")
          End If
     
          Select Case dis.itemState And 1
            Case 0
              DrawRect dis.hdc, dis.rcItem, vbWhite, &HFFFFFF
              For x = dis.rcItem.Left To dis.rcItem.Left + 25
                rc = 255 - Round(x / 26 * (257 - 212))
                gc = 255 - Round(x / 26 * (257 - 208))
                bc = 255 - Round(x / 26 * (257 - 200))
                c = rc + gc * 256 + bc * 256 ^ 2
                For y = dis.rcItem.Top To dis.rcItem.Bottom
                  SetPixel dis.hdc, x, y, c
                Next y
              Next x
     
              Select Case (dis.itemState And 6) = 6
                Case True
                  r.Left = dis.rcItem.Left + 30
                  r.Right = dis.rcItem.Right
                  r.Top = dis.rcItem.Top + 2
                  r.Bottom = r.Top + 1
                  DrawRect dis.hdc, r, &H808080, &H808080
                Case False
                  SetBkMode dis.hdc, TRANSPARENT
                  SetTextColor dis.hdc, 0
                  TextOut dis.hdc, dis.rcItem.Left + 34, dis.rcItem.Top + _
                    (dis.rcItem.Bottom - dis.rcItem.Top) / 2 - 12 / 2, s, Len(s)
              End Select
     
            Case 1
              r.Left = dis.rcItem.Left + 1
              r.Top = dis.rcItem.Top + 1
              r.Right = dis.rcItem.Right - 1
              r.Bottom = dis.rcItem.Bottom
              DrawRect dis.hdc, r, &H6A240A, &HD0BAB2
              ' für unregelmäßige Rechtecke ' vor MakeDiffuseRect entfernen
              ' MakeDiffuseRect dis.hdc, r, 20
              SetBkMode dis.hdc, TRANSPARENT
              SetTextColor dis.hdc, 0
              TextOut dis.hdc, dis.rcItem.Left + 34, dis.rcItem.Top + _
                (dis.rcItem.Bottom - dis.rcItem.Top) / 2 - 12 / 2, s, Len(s)
          End Select
     
          c = GetMenuBitmap(dis.itemID)
          If Not c = 0 Then TransparentBlt dis.hdc, dis.rcItem.Left + 5 - (dis.itemState And 1), _
            dis.rcItem.Top + 4 - (dis.itemState And 1), 16, 16, c, 0, 0, 16, 16, vbMagenta
     
      End Select
     
      NewProc = CallWindowProc(oldProc, hwnd, msg, wParam, lParam)
    End Function
    Private Sub DrawRect(ByVal hdc As Long, r As RECT, _
      ByVal bc As Long, ByVal fc As Long)
     
      Dim hp As Long, hb As Long
     
      hp = CreatePen(PS_SOLID, 0, bc)
      hb = CreateSolidBrush(fc)
      SelectObject hdc, hp
      SelectObject hdc, hb
      Rectangle hdc, r.Left, r.Top, r.Right, r.Bottom
      DeleteObject hb
      DeleteObject hp
    End Sub
    Private Function MakeDiffuseRect(ByVal hdc As Long, _
      r As RECT, ByVal anzahl As Long) As Boolean
     
      Dim i As Long
     
      For i = 1 To anzahl
        DrawDiffuseRect hdc, r
      Next i
    End Function
    Private Function DrawDiffuseRect(ByVal hdc As Long, _
      r As RECT) As Boolean
     
      Dim nr As RECT, c As Long
     
      nr.Left = Rnd * (r.Right - r.Left - Rnd * 40) + r.Left
      If nr.Left <= r.Left Then nr.Left = r.Left + 1
      nr.Right = nr.Left + Rnd * 30 + 10
      If nr.Right >= r.Right Then nr.Right = r.Right - 1
      nr.Top = Rnd * (r.Bottom - r.Top - Rnd * 30) + r.Top
      If nr.Top <= r.Top Then nr.Top = r.Top + 1
      nr.Bottom = nr.Top + Rnd * 20 + 10
      If nr.Bottom >= r.Bottom Then nr.Bottom = r.Bottom - 1
     
      c = 20
      c = RGB(178 + Rnd * c - c / 2, 186 + Rnd * c - c / 2, 208 + Rnd * c - c / 2)
      DrawRect hdc, nr, c, c
    End Function
    Public Function SetMenuItemPicture(ByVal MenuID As Long, _
      Optional ByVal Unchecked As Long = 0, _
      Optional ByVal Checked As Long = 0) As Long
     
      Dim lngTmp As Long
      Dim lngEntry As Long
     
      lngEntry = FindMenuHandle(menuhandle, MenuID)
      SetMenuItemPicture = SetMenuItemBitmaps(menuhandle, lngEntry, _
        0, Unchecked, Checked)
    End Function
    Private Function FindMenuHandle(ByVal lngMenu As Long, _
      lngID As Long) As Long
     
      Select Case GetMenuState(lngMenu, lngID, 0)
        Case -1
          FindMenuHandle = FindMenuHandleb(lngMenu, lngID)
        Case Else
          FindMenuHandle = lngID
      End Select
    End Function
    Private Function FindMenuHandleb(ByVal lngMenu As Long, lngID As Long, _
      Optional lngCur As Long = 1) As Long
     
      Dim lngSubMenu As Long
      Dim i As Long
     
      For i = 0 To GetMenuItemCount(lngMenu) - 1
        lngSubMenu = GetMenuItemID(lngMenu, i)
        If lngSubMenu = -1 Then
          lngSubMenu = GetSubMenu(lngMenu, i)
          If lngCur = lngID Then FindMenuHandleb = lngSubMenu: Exit For
          lngCur = lngCur + 1
          FindMenuHandleb = FindMenuHandleb(lngSubMenu, lngID, lngCur)
          If Not FindMenuHandleb = 0 Then Exit Function
        Else
          If lngCur = lngID Then FindMenuHandleb = lngSubMenu: Exit For
          lngCur = lngCur + 1
        End If
      Next i
    End Function

    Dieser Tipp wurde bereits 13.614 mal aufgerufen.

    Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

    Über diesen Tipp im Forum diskutieren
    Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

    Aktuelle Diskussion anzeigen (5 Beiträge)

    nach obenzurück


    Anzeige

    Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
    (einschl. Beispielprojekt!)

    Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
    - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
    - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
    Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
     
       

    Druckansicht Druckansicht Copyright ©2000-2015 vb@rchiv Dieter Otter
    Alle Rechte vorbehalten.

    Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

    Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel