vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
sevDataGrid - Gönnen Sie Ihrem SQL-Kommando diesen krönenden Abschluß!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
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:  18.675 
www.martinwalcher.deSystem:  WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 Beispielprojekt auf CD 

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 18.675 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-2024 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